Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
#!/usr/bin/perl -w ## ## pmchat by Nicholas J. Leon ala mr.nick (nicholas@binary9.net) ## http://www.mrnick.binary9.net ## ## A text mode client for the Chatter Box of Perl Monks ## This is not an attempt to be complete, but small and useful ## Use it or not. No guaranteee, no warranty, blah blah ## now features a debugging mode! Guaranteed to piss off less ## CB users than before! my $ID='$Id: pmchat,v 1.65 2001/08/07 01:02:15 nicholas Exp $'; #' use strict; use XML::Simple; use LWP::Simple; use LWP::UserAgent; use HTTP::Cookies; use HTTP::Request::Common; use Data::Dumper; use Text::Wrap qw($columns wrap); use Term::ReadLine; use Term::ReadKey qw(GetTerminalSize ReadMode ReadLine); use HTML::Parser; use File::Copy; use Storable; use MD5; use URI::Escape; use HTML::Parser; $|++; my $pm='http://www.perlmonks.org/index.pl'; my $cookie="$ENV{HOME}/.pmcookie"; my $cffile="$ENV{HOME}/.pmconfig"; my %config=( timestamp => 0, colorize => $^O=~/win/i ? 0 : 1, browser => '/usr/bin/lynx %s', newnodes => 25, updateonlaunch => 0, timeout => 45, away => 0, debug => 0, logfile => 'none', ); my %seenmsg; my %seenprv; my %xp; my $ua; ## some color stuff (if you want) my %colormap= ( node => [ "\e[33m", "\e[0m" ], user => [ "\e[1m", "\e[0m" ], code => [ "\e[32m", "\e[0m" ], me => [ "\e[36m", "\e[0m" ], private => [ "\e[35m","\e[0m" ], important => [ "\e[1;34m","\e[0m" ], ); ## <readmore> ###################################################################### +######## ###################################################################### +######## sub writeconfig { store \%config,$cffile; } sub readconfig { %config=(%config,%{ retrieve $cffile }) if -f $cffile; ## away is ALWAYS unset $config{away}=0; } sub autoupdate { my $quiet=shift; my $r=$ua->request(GET "http://www.mrnick.binary9.net/pmchat/version +"); if ($r->{_rc} != 200) { print "Sorry, update request failed: $r->{_rc}/$r->{_msg}\n"; return; } my($ver)=$r->content=~/^([\d\.]+)$/; my($this)=$ID=~/,v\s+([\d\.]+)/; print "This version is $this, the current version is $ver.\n" unless + $quiet; if ($this >= $ver) { print "There is no need to update.\n" unless $quiet; return; } print "A new version is available, $ver.\n"; $r=$ua->request(GET "http://www.mrnick.binary9.net/pmchat/pmchat"); if ($r->{_rc} != 200) { print "Sorry, update request failed: $r->{_rc}/$r->{_msg}\n"; return; } my $tmp=$ENV{TMP} || $ENV{TEMP} || "/tmp"; my $fn="$tmp/pmchat-$ver"; unless (open (OUT,">$fn")) { print "Unable to save newest version to $fn\n"; return; } print OUT $r->content; close OUT; ## okay, a couple checks here: we can autoupdate IF the following ## are true if ($^O=~/win32/i) { print "Sorry, autoupdate not available for Windows installations.\ +n"; print "The newest version has been saved in $fn.\n"; return; } ## moving the old version someplace else if (!move($0,"$0.bak")) { print "Couldn't move $0 to $0.bak, aborting.\n"; print "The newest version has been saved in $fn.\n"; return; } ## moving the new version to the old's location if (!move($fn,$0)) { print "Couldn't move $fn to $0, aborting $!.\n"; move("$0.bak",$0); print "The newest version has been saved in $fn.\n"; return; } ## okay! Reload! chmod 0755,$0; reload(); } ###################################################################### +######## ###################################################################### +######## sub xml { my $r=shift; my $xml=$r->content; $xml=~ tr/\x80-\xff/\?/; $xml; } sub colorize { my $txt=shift; my $type=shift; return $txt unless $config{colorize}; "$colormap{$type}[0]$txt$colormap{$type}[1]"; } my %usermap; my @colors=(31..36,41..46); sub user { ## see if this user has b colorize(shift,"user"); } sub imp { colorize(shift,"important"); } sub content { my $txt=shift; return $txt unless $config{colorize}; unless ($txt=~s/\<code\>(.*)\<\/code\>/$colormap{code}[0]$1$colormap +{code}[1]/mig) { $txt=~s/\[([^\]]+)\]/$colormap{node}[0]$1$colormap{node}[1]/g; } $txt; } ###################################################################### +######## ###################################################################### +######## sub cookie { $ua->cookie_jar(HTTP::Cookies->new()); $ua->cookie_jar->load($cookie); } sub login { my $user; my $pass; ## fixed <> to <STDIN> via merlyn print "Enter your username: "; chomp($user=<STDIN>); ReadMode 2; print "Enter your password: "; chomp($pass=<STDIN>); ReadMode 0; print "\n"; $ua->cookie_jar(HTTP::Cookies->new(file => $cookie, ignore_discard => 1, autosave => 1, ) ); my $r=$ua->request( POST ($pm,[ op=> 'login', user=> $user, passwd => $pass, expires => '+1y', node_id => '16046' ])); if ($r->{_rc} != 200) { print "Sorry, login request failed: $r->{_rc}/$r->{_msg}\n"; return; } } sub xp { my $r=$ua->request(GET("$pm?node_id=16046")); if ($r->{_rc} != 200) { print "Sorry, XP request failed: $r->{_rc}/$r->{_msg}\n"; return; } my $xml=XMLin(xml($r)); $config{xp}=$xml->{XP}->{xp} unless defined $config{xp}; $config{level}=$xml->{XP}->{level} unless defined $config{level}; print "\nYou are logged in as ".user($xml->{INFO}->{foruser}).".\n +"; print "You are level $xml->{XP}->{level} ($xml->{XP}->{xp} XP).\n" +; if ($xml->{XP}->{level} > $config{level}) { print imp "You have gained a level!\n"; } print "You have $xml->{XP}->{xp2nextlevel} XP left until the next +level.\n"; if ($xml->{XP}->{xp} > $config{xp}) { print imp "You have gained ".($xml->{XP}->{xp} - $config{xp})." +experience!\n"; } elsif ($xml->{XP}->{xp} < $config{xp}) { print imp "You have lost ".($xml->{XP}->{xp} - $config{xp})." ex +perience!\n"; } ($config{xp},$config{level})=($xml->{XP}->{xp},$xml->{XP}->{level} +); print "\n"; } sub who { my $r=$ua->request(GET("$pm?node_id=15851")); if ($r->{_rc} != 200) { print "Sorry, who request failed: $r->{_rc}/$r->{_msg}\n"; return; } my $ref=XMLin(xml($r),forcearray=>1); print "\nUsers current online ("; print $#{$ref->{user}} + 1; print "):\n"; print wrap "\t","\t",map { $_->{username}." " } @{$ref->{user}}; print "\n"; } sub newnodes { my $r=$ua->request(GET("$pm?node_id=30175")); if ($r->{_rc} != 200) { print "Sorry, newnodes request failed: $r->{_rc}/$r->{_msg}\n"; return; } my $ref=XMLin(xml($r),forcearray=>1); my $cnt=1; my %users=map { ($_->{node_id},$_->{content}) } @{$ref->{AUTHOR}}; print "\nNew Nodes:\n"; if ($ref->{NODE}) { for my $x (sort { $b->{createtime} <=> $a->{createtime} } @{$ref-> +{NODE}}) { print wrap "\t","\t\t", sprintf("%d. [%d] %s by %s (%s)\n",$cnt, $x->{node_id},$x->{content}, user(defined $users{$x->{author_user}} ? $users{$x->{author_ +user}}:"Anonymous Monk"), $x->{nodetype}); last if $cnt++==$config{newnodes}; } } print "\n"; } sub nodeinfo { my $r=$ua->request(GET "$pm?node_id=32704"); if ($r->{_rc} != 200) { print "Sorry, node info failed: $r->{_rc}/$r->{_msg}\n"; return; } my $ref=XMLin(xml($r),forcearray=>1); $config{nodes}=$ref->{NODE} unless defined $config{nodes}; if (defined $ref->{NODE}) { for my $id (keys %{$ref->{NODE}}) { $config{nodes}->{$id}->{reputation}=0 if ! defined $config{nodes +}->{$id}->{reputation}; my $ch=$ref->{NODE}->{$id}->{reputation}-$config{nodes}->{$id}-> +{reputation}; if ($ch) { print wrap "\t","\t\t","$ref->{NODE}->{$id}->{content} ($id) has " +; print imp (($ch>0?"gained":"lost")." $ch "); print "reputation!\n"; $config{nodes}->{$id}->{reputation}=$ref->{NODE}->{$id}->{reputati +on}; } } print "\n"; } } sub getnode { my $id=shift; system(sprintf($config{browser},"$pm?node_id=$id")); } sub quit { writeconfig; exit; } sub set { my $args=shift; if ($args) { if ($args=~/([^\s]+)\s+(.+)$/) { $config{$1}=$2; print "\t$1 is now $2\n"; } elsif ($args=~/([^\s+]+)$/) { print "\t$1 is $config{$1}\n"; } } else { for my $k (sort keys %config) { next if ref $config{$k}; printf "\t%-15s %s\n",$k,$config{$k}; } } } sub reload { print "Reloading $0...\n"; writeconfig; exec $0; } sub away { my $args=shift; print wrap '','',"You are now away. Checking your XP or sending a me +ssage will negate this.\n"; $config{away}=1; } sub logfile { my $buff=shift; if ($config{logfile} && $config{logfile} ne '0' && $config{logfile} +ne 'none') { if (!open(OUT,">>$config{logfile}")) { warn "Couldn't open log file '$config{logfile}': $!\n"; return; } print OUT $buff,"\n"; close OUT; } } ###################################################################### +######## ###################################################################### +######## sub showmessage { my $msg=shift; my $type=shift || ''; for my $k (keys %$msg) { $msg->{$k}=~s/^\s+|\s+$//g } print "\r"; my $content=$msg->{content}; if ($type eq 'private') { print wrap('',"\t", ($config{timestamp}?sprintf "%02d:%02d:%02d/",(unpack("A8A2 +A2A2",$msg->{time}))[1..3]:''). colorize("$msg->{author} says $msg->{content}","private"). "\n"); logfile (($config{timestamp}?sprintf "%02d:%02d:%02d/",(unpack("A8 +A2A2A2",$msg->{time}))[1..3]:''). "$msg->{author} says $msg->{content}"); } else { if ($msg->{content}=~s/^\/me\s+//) { print wrap('',"\t", ($config{timestamp}?sprintf "%02d:%02d:%02d/",(unpack("A8A2A2 +A2",$msg->{time}))[1..3]:''). colorize("$msg->{author} $msg->{content}","me"), "\n"); logfile (($config{timestamp}?sprintf "%02d:%02d:%02d/",(unpack(" +A8A2A2A2",$msg->{time}))[1..3]:''). "$msg->{author} $msg->{content}"); } else { print wrap('',"\t", ($config{timestamp}?sprintf "%02d:%02d:%02d/",(unpack("A8A2A2 +A2",$msg->{time}))[1..3]:''). colorize($msg->{author},"user"). ": ". content($msg->{content}). "\n"); logfile (($config{timestamp}?sprintf "%02d:%02d:%02d/",(unpack(" +A8A2A2A2",$msg->{time}))[1..3]:''). "$msg->{author}: $msg->{content}"); } } } sub getmessages { my $r; ## alright, something wacky here. If $config{away} is true, then ## don't use the users cookie to grab the list if ($config{away}) { my $nua=LWP::UserAgent->new; $nua->agent("pmchat-mrnick-anon"); $r=$nua->request(GET("$pm?node_id=15834")); } else { $r=$ua->request(GET("$pm?node_id=15834")); } if ($r->{_rc} != 200) { print "Sorry, message request failed: $r->{_rc}/$r->{_msg}\n"; return; } ## we'll cheese-out here ... for XML::Simple my $xml=xml($r); my $ref=XMLin(uri_escape($xml,"\x80-\xff"), forcearray=>1 ); if (defined $ref->{message}) { for my $mess (@{$ref->{message}}) { ## ignore this message if we've already printed it out next if $seenmsg{"$mess->{user_id}:$mess->{time}"}++; showmessage $mess; } } else { ## if there is nothing in the list, reset ours undef %seenmsg; } } sub getprivatemessages { my $r=$ua->request(GET("$pm?node_id=15848")); if ($r->{_rc} != 200) { print "Sorry, private message request failed: $r->{_rc}/$r->{_msg} +\n"; return; } my $ref=XMLin(xml($r),forcearray=>1); if (defined $ref->{message}) { for my $mess (@{$ref->{message}}) { ## ignore this message if we've already printed it out next if $seenprv{"$mess->{user_id}:$mess->{time}"}++; showmessage $mess,"private"; } } else { undef %seenprv; } } sub postmessage { my $junk=shift; my $msg=shift; if ($config{debug}) { print ">> $msg\n"; return; } my $req=POST ($pm,[ op=>'message', message=>$msg, node_id=>'16046', ]); my $r=$ua->request($req); if ($r->{_rc} != 200) { print "Sorry, post message failed: $r->{_rc}/$r->{_msg}\n"; return; } } sub help { print <<EOT The following commands are available: /away :: Sets pmchat to anonymously pull Chatterbox messag +es. The effect is that you will not appear in Other Users + unless you send a message or check your XP. /help :: Shows this message /getnode ID :: Retrieves the passed node and launches your user configurable browser ("browser") to view that nod +e. /newnodes :: Displays a list of the newest nodes (of all types +) posted. The number of nodes displayed is limited +by the "newnodes" user configurable variable. /nodeinfo :: Displays changes in reputation for your nodes. /reload :: UNIX ONLY. Restarts pmchat. /set :: Displays a list of all the user configurable variables and their values. /set X Y :: Sets the user configurable variable X to value Y. /update :: Checks for a new version of pmchat, and if it exists, download it. This WILL overwrite your current version. /quit :: Exits pmchat /who :: Shows a list of all users currently online /xp :: Shows your current experience and level. EOT ; } ###################################################################### +######## ###################################################################### +######## my $old; my $term=new Term::ReadLine 'pmchat'; sub getlineUnix { my $message; eval { local $SIG{ALRM}=sub { $old=$readline::line; die }; ## I don't use the version of readline from ReadKey (that includes + a timeout) ## because this version stores the interrupted (what was already t +yped when the ## alarm() went off) text in a variable. I need that so I can rest +uff it ## back in. alarm($config{timeout}) unless $^O=~/win32/i; $message=$term->readline("(Talk) ",$old); $old=$readline::line=''; alarm(0) unless $^O=~/win32/i; }; $message; } sub getlineWin32 { ## sorry, non-blocking reads are not supported on Windows, it appear +s print "(Talk) "; chomp($_=<STDIN>); $_; } ## initialize our user agent $ua=LWP::UserAgent->new || die "Couldn't init UserAgent: $!\n"; $ua->agent("pmchat-mrnick"); ## trap ^C's ## for clean exit $SIG{INT}=sub { writeconfig; exit }; ## load up our config defaults readconfig; ## for text wrapping $columns=(Term::ReadKey::GetTerminalSize)[0] || $ENV{COLS} || $ENV{COL +UMNS} || 80; if (-e $cookie) { cookie; } else { login; } my($this)=$ID=~/,v\s+([\d\.]+)/; print "This is pmchat version $this.\n"; if ($config{updateonlaunch}) { autoupdate(1); } else { print "Consider checking for a new version with /update.\n"; } xp(); nodeinfo(); print "Type /help for help.\n"; who(); newnodes(); getprivatemessages; getmessages(); ## testing, please ignore my %cmdmap=( '/me' => \&postmessage, '/msg' => \&postmessage, '/away', => \&away, '/who' => \&who, '/quit' => \&quit, '/set' => \&set, '/new\s*nodes' => \&newnodes, '/xp' => \&xp, '/getnode' => \&getnode, '/help' => \&help, '/reload' => \&reload, '/update' => \&autoupdate, '/nodeinfo' => \&nodeinfo, ); while (1) { my $message; getprivatemessages unless $config{away}; getmessages; if ($^O=~/win32/i) { $message=getlineWin32; } else { $message=getlineUnix; } if (defined $message) { if ($message=~/^\//) { foreach (keys %cmdmap) { if ($message=~/^$_\s*(.*)/) { &{$cmdmap{$_}}($1,$message); last; } } } else { postmessage undef,$message; } } }

In reply to pmchat 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 surveying the Monastery: (14)
    As of 2014-07-10 22:29 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      When choosing user names for websites, I prefer to use:








      Results (217 votes), past polls