Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Unix text-mode CB Client

by mr.nick (Chaplain)
on May 24, 2001 at 07:57 UTC ( [id://82809]=perlcraft: print w/replies, xml ) Need Help??

   1: #!/usr/bin/perl -w 
   2: 
   3:  
   4: ##  
   5: ## pmchat by Nicholas J. Leon ala mr.nick (nicholas@binary9.net) 
   6: ##                                    http://www.mrnick.binary9.net 
   7: 
   8: ## A text mode client for the Chatter Box of Perl Monks 
   9: ## this is not an attempt to be complete, but small and useful 
  10: ## Use it or not. No guaranteee, no warranty, blah blah 
  11: 
  12: ## Now supports Win32 installations with a different ReadLine
  13: ## call.
  14: 
  15: ## Autoupdate now actually autoupdates
  16: 
  17: ## Oh, and it has no error checking :) 
  18: 
  19: 
  20: my $ID='$Id: pmchat,v 1.42 2001/06/03 17:49:22 nicholas Exp $'; #'
  21:  
  22: use strict; 
  23: use XML::Simple; 
  24: use LWP::Simple; 
  25: use LWP::UserAgent; 
  26: use HTTP::Cookies; 
  27: use HTTP::Request::Common; 
  28: use Data::Dumper; 
  29: use Text::Wrap qw($columns wrap); 
  30: use Term::ReadLine; 
  31: use Term::ReadKey qw(GetTerminalSize); 
  32: use HTML::Parser;
  33: use File::Copy;
  34:  
  35: $|++; 
  36: 
  37: my $pm='http://www.perlmonks.org/index.pl'; 
  38: my $cookie="$ENV{HOME}/.pmcookie"; 
  39: my $cffile="$ENV{HOME}/.pmconfig"; 
  40: my %config=( 
  41:             timestamp => 0, 
  42:             colorize => 1, 
  43:             browser => '/usr/bin/lynx %s',
  44:             newnodes => 25,
  45:             updateonlaunch => 0,
  46:             timeout => 15,
  47:            ); 
  48:  
  49: my %seenmsg; 
  50: my %seenprv; 
  51: my %xp;
  52: my $ua;
  53:  
  54: ## some color stuff (if you want) 
  55: my %colormap= 
  56:   (  
  57:    node => [ "\e[33m", "\e[0m" ], 
  58:    user => [ "\e[1m", "\e[0m" ], 
  59:    code => [ "\e[32m", "\e[0m" ], 
  60:    me => [ "\e[36m", "\e[0m" ], 
  61:    private => [ "\e[35m","\e[0m" ],
  62:    important => [ "\e[1;34m","\e[0m" ],
  63:   ); 
  64: 
  65: ## 
  66: ##############################################################################
  67: ##############################################################################
  68: 
  69: sub writeconfig { 
  70:   unless (open(OUT,">$cffile")) { 
  71:     warn "Couldn't open '$cffile' for writing: $!\n"; 
  72:     return; 
  73:   } 
  74: 
  75:   print OUT "$_ $config{$_}\n" for keys %config; 
  76: 
  77:   close OUT; 
  78: } 
  79: sub readconfig { 
  80:   unless (open(IN,$cffile)) { 
  81:     warn "Couldn't open '$cffile' for reading: $!\n"; 
  82:     return; 
  83:   } 
  84:   
  85:   %config=(%config,(map /^([^\s]+)\s+(.+)$/,<IN>));
  86:   
  87:   close IN; 
  88: } 
  89: 
  90: ## testing ... autoupdate
  91: sub autoupdate {
  92:   my $quiet=shift;
  93:   my $r=$ua->request(GET "http://www.mrnick.binary9.net/pmchat/version");
  94:   my($ver)=$r->content=~/^([\d\.]+)$/;
  95:   my($this)=$ID=~/,v\s+([\d\.]+)/;
  96:   
  97:   print "This version is $this, the current version is $ver.\n" unless $quiet;
  98: 
  99:   if ($this >= $ver) {
 100:     print "There is no need to update.\n" unless $quiet;
 101:     return;
 102:   }
 103: 
 104:   print "A new version is available, $ver.\n";
 105: 
 106:   $r=$ua->request(GET "http://www.mrnick.binary9.net/pmchat/pmchat");
 107: 
 108:   my $tmp=$ENV{TMP} || $ENV{TEMP} || "/tmp";
 109:   my $fn="$tmp/pmchat-$ver";
 110: 
 111:   unless (open (OUT,">$fn")) {
 112:     print "Unable to save newest version to $fn\n";
 113:     return;
 114:   }
 115: 
 116:   print OUT $r->content;
 117:   close OUT;
 118: 
 119:   ## okay, a couple checks here: we can autoupdate IF the following
 120:   ## are true
 121:   if ($^O=~/win32/i) {
 122:     print "Sorry, autoupdate not available for Windows installations.\n";
 123:     print "The newest version has been saved in $tmp/pmchat.$ver.\n";
 124:     return;
 125:   }
 126: 
 127:   ## moving the old version someplace else 
 128:   if (!move($0,"$0.bak")) {
 129:     print "Couldn't move $0 to $0.bak, aborting.\n";
 130:     print "The newest version has been saved in $fn.\n";
 131:     return;
 132:   }
 133:   ## moving the new version to the old's location
 134:   if (!move($fn,$0)) {
 135:     print "Couldn't move $fn to $0, aborting $!.\n";
 136:     move("$0.bak",$0);
 137:     print "The newest version has been saved in $fn.\n";
 138:     return;
 139:   }
 140:   ## okay! Reload!
 141:   chmod 0755,$0;
 142:   writeconfig;
 143:   exec $0;
 144: }
 145:   
 146: 
 147: ##############################################################################
 148: ##############################################################################
 149: 
 150: sub colorize {
 151:   my $txt=shift;
 152:   my $type=shift;
 153: 
 154:   return $txt unless $config{colorize};
 155:   return $txt if $^O=~/win32/i;
 156: 
 157:   "$colormap{$type}[0]$txt$colormap{$type}[1]";
 158: }
 159: 
 160: sub user {
 161:   colorize(shift,"user");
 162: }
 163: sub imp {
 164:   colorize(shift,"important");
 165: }  
 166: sub content {
 167:   my $txt=shift;
 168: 
 169:   return $txt unless $config{colorize};
 170:   return $txt if $^O=~/win32/i;
 171: 
 172:   unless ($txt=~s/\<code\>(.*)\<\/code\>/$colormap{code}[0]$1$colormap{code}[1]/mig) {
 173:     $txt=~s/\[([^\]]+)\]/$colormap{node}[0]$1$colormap{node}[1]/g;
 174:   }
 175: 
 176:   $txt;
 177: }
 178: ##############################################################################
 179: ##############################################################################
 180: 
 181: sub cookie {
 182:   $ua->cookie_jar(HTTP::Cookies->new());
 183:   $ua->cookie_jar->load($cookie);
 184: }
 185: 
 186: sub login {
 187:   my $user; 
 188:   my $pass; 
 189:   
 190:   ## fixed <> to <STDIN> via merlyn
 191:   print "Enter your username: "; chomp($user=<STDIN>); 
 192:   print "Enter your password: "; chomp($pass=<STDIN>); 
 193:   
 194:   $ua->cookie_jar(HTTP::Cookies->new(file => $cookie, 
 195:                                      ignore_discard => 1, 
 196:                                      autosave => 1, 
 197:                                     ) 
 198:                  ); 
 199:   
 200:   my $r=$ua->request( POST ($pm,[  
 201:                                  op=> 'login',  
 202:                                  user=> $user,  
 203:                                  passwd => $pass, 
 204:                                  expires => '+1y',  
 205:                                  node_id => '16046'  
 206:                                 ])); 
 207: }
 208: 
 209: sub xp { 
 210:     my $r=$ua->request(GET("$pm?node_id=16046")); 
 211:     my $xml=XMLin($r->content); 
 212:     
 213:     $config{xp}=$xml->{XP}->{xp} unless defined $config{xp};
 214:     $config{level}=$xml->{XP}->{level} unless defined $config{level};
 215: 
 216: 
 217:     print "\nYou are logged in as ".user($xml->{INFO}->{foruser}).".\n"; 
 218:     print "You are level $xml->{XP}->{level} ($xml->{XP}->{xp} XP).\n"; 
 219:     if ($xml->{XP}->{level} > $config{level}) {
 220:       print imp "You have gained a level!\n";
 221:     }
 222:     print "You have $xml->{XP}->{xp2nextlevel} XP left until the next level.\n"; 
 223: 
 224:     if ($xml->{XP}->{xp} > $config{xp}) {
 225:       print imp "You have gained ".($xml->{XP}->{xp} - $config{xp})." experience!\n";
 226:     }
 227:     elsif ($xml->{XP}->{xp} < $config{xp}) { 
 228:       print imp "You have lost ".($xml->{XP}->{xp} - $config{xp})." experience!\n"; 
 229:     }                               
 230: 
 231:     ($config{xp},$config{level})=($xml->{XP}->{xp},$xml->{XP}->{level});
 232: 
 233:     print "\n"; 
 234:   } 
 235:  
 236: sub who { 
 237:   my $req=GET("$pm?node_id=15851"); 
 238:   my $res=$ua->request($req); 
 239:   my $ref=XMLin($res->content,forcearray=>1); 
 240:  
 241:   print "\nUsers current online (";
 242:   print $#{$ref->{user}} + 1;
 243:   print "):\n";
 244: 
 245:   print wrap "\t","\t",map { user($_->{username})." " } @{$ref->{user}};
 246: 
 247:   print "\n";
 248: } 
 249:  
 250: sub newnodes { 
 251:   my $req=GET("$pm?node_id=30175"); 
 252:   my $res=$ua->request($req); 
 253:   my $ref=XMLin($res->content,forcearray=>1); 
 254:   my $cnt=1; 
 255:   my %users=map { ($_->{node_id},$_->{content}) } @{$ref->{AUTHOR}}; 
 256:   
 257:   print "\nNew Nodes:\n";
 258:   
 259:   if ($ref->{NODE}) {
 260:     for my $x (sort { $b->{createtime} <=> $a->{createtime} } @{$ref->{NODE}}) { 
 261:       print wrap "\t","\t\t", 
 262:       sprintf("%d. [%d] %s by %s (%s)\n",$cnt,
 263:               $x->{node_id},$x->{content},
 264:               user(defined $users{$x->{author_user}} ? $users{$x->{author_user}}:"Anonymous Monk"),
 265:               $x->{nodetype});
 266:       last if $cnt++==$config{newnodes}; 
 267:     } 
 268:   }
 269:   print "\n";
 270:   
 271: } 
 272: 
 273: ##############################################################################
 274: ##############################################################################
 275: 
 276: sub showmessage {
 277:   my $msg=shift;
 278:   my $type=shift || '';
 279:   
 280:   for my $k (keys %$msg) {
 281:     $msg->{$k}=~s/^\s+|\s+$//g
 282:   }
 283: 
 284:   print "\r";
 285:   
 286:   if ($type eq 'private') {
 287:     print wrap('',"\t",
 288:                ($config{timestamp}?sprintf "%02d:%02d:%02d/",(unpack("A8A2A2A2",$msg->{time}))[1..3]:'').
 289:                colorize("$msg->{author} says $msg->{content}","private").
 290:                "\n");
 291:   }
 292:   else {
 293:     if ($msg->{content}=~s/^\/me\s+//) {
 294:       print wrap('',"\t",
 295:                  ($config{timestamp}?sprintf "%02d:%02d:%02d/",(unpack("A8A2A2A2",$msg->{time}))[1..3]:'').
 296:                  colorize("$msg->{author} $msg->{content}","me"),
 297:                  "\n");
 298:     }
 299:     else {
 300:       print wrap('',"\t",
 301:                  ($config{timestamp}?sprintf "%02d:%02d:%02d/",(unpack("A8A2A2A2",$msg->{time}))[1..3]:'').
 302:                  colorize($msg->{author},"user").
 303:                  ": ".
 304:                  content($msg->{content}).
 305:                  "\n");
 306:     }
 307:   }
 308: }
 309:              
 310: 
 311: sub getmessages { 
 312:   my $req=GET("$pm?node_id=15834"); 
 313:   my $res=$ua->request($req); 
 314:   my $ref=XMLin($res->content, forcearray=>1 ); 
 315:   
 316:   if (defined $ref->{message}) { 
 317:     for my $mess (@{$ref->{message}}) { 
 318:       ## ignore this message if we've already printed it out 
 319:       next if $seenmsg{"$mess->{user_id}:$mess->{time}"}++; 
 320: 
 321:       showmessage $mess; 
 322:     } 
 323:   } 
 324:   else { 
 325:     ## if there is nothing in the list, reset ours 
 326:     undef %seenmsg; 
 327:   } 
 328: } 
 329: 
 330: sub getprivatemessages { 
 331:   my $req=GET("$pm?node_id=15848"); 
 332:   my $res=$ua->request($req); 
 333:   my $ref=XMLin($res->content,forcearray=>1); 
 334:   
 335:   if (defined $ref->{message}) { 
 336:     for my $mess (@{$ref->{message}}) { 
 337:       ## ignore this message if we've already printed it out 
 338:       next if $seenprv{"$mess->{user_id}:$mess->{time}"}++; 
 339:  
 340:       showmessage $mess,"private"; 
 341:     } 
 342:   } 
 343:   else { 
 344:     undef %seenprv; 
 345:   } 
 346: } 
 347: 
 348: sub postmessage { 
 349:   my $msg=shift; 
 350:   my $req=POST ($pm,[ 
 351:                      op=>'message', 
 352:                      message=>$msg, 
 353:                      node_id=>'16046', 
 354:                     ]); 
 355:   
 356:   $ua->request($req); 
 357: } 
 358: 
 359: sub node {
 360:   my $id=shift;
 361: 
 362:   system(sprintf($config{browser},"$pm?node_id=$id"));
 363: }
 364: 
 365: sub help {
 366:   print <<EOT
 367: The following commands are available:
 368:     /help         :: Shows this message
 369:     /newnodes     :: Displays a list of the newest nodes (of all types)
 370:                      posted. The number of nodes displayed is limited by
 371:                      the "newnodes" user configurable variable.
 372:     /node ID      :: Retrieves the passed node and launches your user
 373:                      configurable browser ("browser") to view that node.
 374:     /reload       :: UNIX ONLY. Restarts pmchat.
 375:     /set          :: Displays a list of all the user configurable
 376:                      variables and their values.
 377:     /set X Y      :: Sets the user configurable variable X to
 378:                      value Y.
 379:     /update       :: Checks for a new version of pmchat, and if it
 380:                      exists, download it into a temporary location.
 381:                      This WILL NOT overwrite your current version.
 382:     /quit         :: Exits pmchat
 383:     /who          :: Shows a list of all users currently online
 384:     /xp           :: Shows your current experience and level.
 385: EOT
 386:   ;
 387: }
 388: 
 389: ##############################################################################
 390: ##############################################################################
 391: my $old;
 392: my $term=new Term::ReadLine 'pmchat';
 393: 
 394: sub getlineUnix {
 395:   my $message;
 396: 
 397:   eval {
 398:     local $SIG{ALRM}=sub { 
 399:       $old=$readline::line; 
 400:       die 
 401:     };
 402:     
 403:     ## I don't use the version of readline from ReadKey (that includes a timeout)
 404:     ## because this version stores the interrupted (what was already typed when the
 405:     ## alarm() went off) text in a variable. I need that so I can restuff it 
 406:     ## back in.
 407: 
 408:     alarm($config{timeout}) unless $^O=~/win32/i;
 409:     $message=$term->readline("Talk: ",$old);
 410:     $old=$readline::line='';
 411:     alarm(0) unless $^O=~/win32/i;
 412:   };    
 413: 
 414:   $message;
 415: }
 416: 
 417: sub getlineWin32 {
 418:   my $message=ReadLine($config{timeout});
 419: 
 420:   ## unfortunately, there is no way to preserve what was already typed
 421:   ## when the timeout occured. If you are typing when it happens,
 422:   ## you lose your text.
 423: 
 424:   $message;
 425: }
 426: 
 427: ## initialize our user agent
 428: $ua=LWP::UserAgent->new;
 429: $ua->agent("pmchat-mrnick"); 
 430: 
 431: ## trap ^C's
 432: ## for clean exit
 433: $SIG{INT}=sub { 
 434:   writeconfig;
 435:   exit 
 436: };
 437: 
 438: ## load up our config defaults
 439: readconfig;
 440: 
 441: ## for text wrapping
 442: $columns=(Term::ReadKey::GetTerminalSize)[0] || $ENV{COLS} || $ENV{COLUMNS} || 80;
 443: 
 444: if (-e $cookie) {
 445:   cookie;
 446: }
 447: else {
 448:   login;
 449: }
 450: 
 451: my($this)=$ID=~/,v\s+([\d\.]+)/;
 452: 
 453: print "This is pmchat version $this.\n";
 454: 
 455: autoupdate(1) if $config{updateonlaunch};
 456: xp();
 457: print "Type /help for help.\n";
 458: who();
 459: newnodes();
 460: getprivatemessages;
 461: getmessages();
 462: 
 463: 
 464: while (1) {
 465:   my $message;
 466: 
 467:   getprivatemessages;
 468:   getmessages;
 469:   
 470:   if ($^O=~/win32/i) {
 471:     $message=getlineWin32;
 472:   }
 473:   else {
 474:     $message=getlineUnix;
 475:   }
 476: 
 477:   if (defined $message) {
 478:     ## we understand a couple of commands
 479:     if ($message=~/^\/who/i) {
 480:       who;
 481:     }
 482:     elsif ($message=~/^\/quit/i) {
 483:       writeconfig;
 484:       exit;
 485:     }
 486:     elsif ($message=~/^\/set\s+([^\s]+)\s+(.+)$/) {
 487:       $config{$1}=$2;
 488:       print "$1 is now $2\n";
 489:     }
 490:     elsif ($message=~/^\/set$/) {
 491:       for my $k (sort keys %config) {
 492:         printf "\t%-10s %s\n",$k,$config{$k};
 493:       }
 494:     }
 495:     elsif ($message=~/^\/new\s*nodes/) {
 496:       newnodes;
 497:     }
 498:     elsif ($message=~/^\/xp/) {
 499:       xp;
 500:     }
 501:     elsif ($message=~/^\/node\s+(\d+)/) {
 502:       node($1);
 503:     }
 504:     elsif ($message=~/^\/help/) {
 505:       help;
 506:     }
 507:     elsif ($message=~/^\/reload/) {
 508:       print "Reloading $0!\n";
 509:       writeconfig;
 510:       exec $0;
 511:     }
 512:     elsif ($message=~/^\/update/) {
 513:       autoupdate;
 514:     }
 515:     elsif ($message=~/^\/me/ || $message=~/^\/msg/) {
 516:       postmessage($message);
 517:     }
 518:     elsif ($message=~/^\//) {
 519:       print "Unknown command '$message'.\n";
 520:     }
 521:     else {
 522:       postmessage($message);
 523:     }
 524:   }
 525: }

Replies are listed 'Best First'.
Re: Unix text-mode CB Client
by btrott (Parson) on May 24, 2001 at 11:51 UTC
    Another way to implement a timeout on a user input read (that is what you're doing, right?) is to use Term::ReadKey and its ReadLine method (or ReadKey, but here you want to read a line, so...).

    use Term::ReadKey; my $message = ReadLine(10); ## timeout of 10 seconds
    This manages all of the timeout issues for you. Although it may not do so in a way that suits you, who knows. And you may already have tried it, even. Anyway.
Re: Unix text-mode CB Client
by turo (Friar) on Dec 14, 2005 at 00:48 UTC
    Nice program, but it echoes the password in clear-text when you type it on the term console ... i suggest to add 'ReadMode' func:
    use Term::ReadKey qw(GetTerminalSize ReadMode);
    and change the line 191 for this one:
    print "Enter your password: "; ReadMode 2; chomp($pass=<STDIN>); ReadM +ode 0;

    happy chatterboxing! ^_^

    perl -Te 'print map { chr((ord)-((10,20,2,7)[$i++])) } split //,"turo"'
Re: Unix text-mode CB Client
by jakobi (Pilgrim) on Sep 28, 2009 at 23:00 UTC
    Just a note: do check node 720870 instead, which is a more recent incarnation of this script.

      Instead of that I'd recommend checking out Other CB Clients, which is linked from the chatterbox nodelet and will be updated point to any new public chatterbox clients in the future.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others pondering the Monastery: (7)
As of 2024-03-28 14:15 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found