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 | |
Re: Unix text-mode CB Client
by turo (Friar) on Dec 14, 2005 at 00:48 UTC | |
Re: Unix text-mode CB Client
by jakobi (Pilgrim) on Sep 28, 2009 at 23:00 UTC | |
by ambrus (Abbot) on Sep 29, 2009 at 08:30 UTC |
Back to
Craft