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