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: }
Back to
Craft