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

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
    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: }

In reply to Unix text-mode CB Client by mr.nick

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

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

    How do I use this? | Other CB clients
    Other Users?
    Others chilling in the Monastery: (14)
    As of 2015-07-07 14:36 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









      Results (89 votes), past polls