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: }
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.