Beefy Boxes and Bandwidth Generously Provided by pair Networks
XP is just a number
 
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
  • Outside of code tags, you may need to use entities for some characters:
            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 having an uproarious good time at the Monastery: (5)
    As of 2014-09-21 09:41 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      How do you remember the number of days in each month?











      Results (168 votes), past polls