Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??
#!/usr/bin/perl -w my $VERSION = '1.99'; ## revisions by Sam Denton, aka samwyse; email me at gmail.com ## original program by Nicholas J. Leon, aka mr.nick ## 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 guarantee, no warranty, blah blah ## Now supports Win32 installations with a different ReadLine call. ## Autoupdate now actually autoupdates ## Oh, and it has no error checking :) 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 ReadLine ReadMode); use HTML::Parser; use File::Copy; $|++; my $pm = 'http://www.perlmonks.org/index.pl'; my $win32 = ($^O =~ /win32/i); my $home = $win32 ? ( $ENV{HOME} || $ENV{APPDATA} || $ENV{USERPROFILE} || "." ) : ( $ENV{HOME} || "." ); my $cookie = "$home/.pmcookie"; my $cffile = "$home/.pmconfig"; my %config = ( timestamp => 0, colorize => 1, browser => '/usr/bin/lynx %s', newnodes => 25, updateonlaunch => 0, xponlaunch => 1, whoonlaunch => 1, newnodesonlaunch => 0, timeout => 15, homepage => 'http://www.perlmonks.org/?displaytype=display +code;node_id=720870', ); 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 { unless (open(OUT, ">$cffile")) { warn "Couldn't open '$cffile' for writing: $!\n"; return; } print OUT "$_ $config{$_}\n" for keys %config; close OUT; } sub readconfig { unless (-r $cffile) { warn "'$cffile' does not exist, skipping.\n"; return; } unless (open(IN, $cffile)) { warn "Couldn't open '$cffile' for reading: $!\n"; return; } %config =( %config, (map /^([^\s]+)\s+(.+)$/, <IN>)); close IN; } ## testing ... autoupdate sub autoupdate { my $quiet = shift; my $r = $ua->request(GET "$config{homepage}"); unless ($r) { print "Unable to access the most recent version via the Internet.\ +n"; return; } $r->content =~ /^\s*my\s*\$VERSION\s*=\s*'(\d+\.\d+)'\s*;\s*$/m; unless ($1) { print "Unable to parse the version number found at $config{homepag +e}.\n"; return; } my $ver = $1; print "This version is $VERSION, the most recent version is $ver.\n" unless $quiet; if ($VERSION >= $ver) { print "There is no need to update.\n" unless $quiet; return; } print "Version $ver is available.\n"; 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; ## a couple checks here: we can autoupdate IF the following are true if ($win32) { print "Sorry, autoupdate is not available for Windows installation +s.\n"; print "The newest version has been saved in $tmp/pmchat.$ver.\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; writeconfig; exec $0; } ###################################################################### ###################################################################### sub colorize { my $txt = shift; my $type = shift; return $txt unless $config{colorize}; return $txt if $win32; "$colormap{$type}[0]$txt$colormap{$type}[1]"; } sub user { colorize(shift, "user"); } sub imp { colorize(shift, "important"); } sub content { my $txt = shift; return $txt unless $config{colorize}; return $txt if $win32; unless ($txt =~ s/\<code\>(.*)\<\/code\>/$colormap{code}[0]$1$colorm +ap{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>); print "Enter your password: "; ReadMode 2; chomp($pass = <STDIN>); ReadMode 0; $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' ])); } sub xp { my $r = $ua->request(GET("$pm?node_id=16046")); my $xml = XMLin($r->content); $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}->{le +vel}); print "\n"; } sub who { my $req = GET("$pm?node_id=15851"); my $res = $ua->request($req); my $ref = XMLin($res->content, forcearray => 1); print "\nUsers current online ("; print $#{$ref->{user}} + 1; print "):\n"; print wrap "\t", "\t", map { user($_->{username})." " } @{$ref->{use +r}}; print "\n"; } sub newnodes { my $req = GET("$pm?node_id=30175"); my $res = $ua->request($req); my $ref = XMLin($res->content, 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->{aut +hor_user}}:"Anonymous Monk"), $x->{nodetype}); last if $cnt++ == $config{newnodes}; } } print "\n"; } ###################################################################### ###################################################################### sub showmessage { my $msg = shift; my $type = shift || ''; my $fmt = "%02d:%02d:%02d "; my $tmplt = "A8xA2xA2xA2"; for my $k (keys %$msg) { $msg->{$k} =~ s/^\s+|\s+$//g } print "\r"; if ($type eq 'private') { print wrap('', "\t", ($config{timestamp}?sprintf $fmt, (unpack($tmplt, $msg- +>{time}))[1..3]:''). colorize("$msg->{author} says $msg->{content}", "privat +e"). "\n"); } else { if ($msg->{content} =~ s/^\/me\b/$msg->{author}/) { print wrap('', "\t", ($config{timestamp}?sprintf $fmt, (unpack($tmplt, $ms +g->{time}))[1..3]:''). colorize("$msg->{content}", "me"), "\n"); } else { print wrap('', "\t", ($config{timestamp}?sprintf $fmt, (unpack($tmplt, $ms +g->{time}))[1..3]:''). colorize($msg->{author}, "user"). ": ". content($msg->{content}). "\n"); } } } sub getmessages { my $req = GET("$pm?node_id=15834"); my $res = $ua->request($req); my $ref = XMLin($res->content, 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 $req = GET("$pm?node_id=15848"); my $res = $ua->request($req); my $ref = XMLin($res->content, 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 $msg = shift; my $req = POST ($pm, [ op => 'message', message => $msg, node_id => '16046', ]); $ua->request($req); } sub node { my $id = shift; system(sprintf($config{browser}, "$pm?node_id = $id")); } sub help { print <<EOT The following commands are available: /help :: Shows this message. /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. /node ID :: Retrieves the passed node and launches your user configurable browser ("browser") to view that nod +e. /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 into a temporary location. This WILL NOT 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 typed when the alarm() went off) text in a variable +. ## I need that so I can restuff it back in. alarm($config{timeout}) unless $win32; $message = $term->readline("Talk: ", $old); $old = $readline::line = ''; alarm(0) unless $win32; }; $message; } sub getlineWin32 { ## unfortunately, there is no way to preserve what was already typed ## when the timeout occured. If you are typing when it happens, ## you lose your text. my $message = $term->readline("Talk: "); $message; } ## initialize our user agent $ua=LWP::UserAgent->new; $ua->agent("pmchat-samwyse"); ## trap ^C's ## for clean exit $SIG{INT}=sub { writeconfig; exit }; ## load up our config defaults readconfig; ## for text wrapping $columns = (GetTerminalSize)[0] || $ENV{COLS} || $ENV{COLUMNS} || 80; if (-e $cookie) { cookie; } else { login; } print "This is pmchat version $VERSION.\n"; autoupdate(1) if $config{updateonlaunch}; xp() if $config{xponlaunch}; who() if $config{whoonlaunch}; newnodes() if $config{newnodesonlaunch}; getprivatemessages; getmessages(); print "Type /help for help.\n"; while (1) { getprivatemessages; getmessages; #my $message = $win32 ? getlineWin32() : getlineUnix(); my $message = getlineUnix(); if (defined $message) { ## we understand a couple of commands $message =~ s/^\s*//; if ($message =~ /^\/who\b/i) { who; } elsif ($message =~ /^\/q(uit)?\b/i) { writeconfig; exit; } elsif ($message =~ /^\/set\s+([^\s]+)\s+(.+)$/) { $config{$1} = $2; print "$1 is now $2\n"; } elsif ($message =~ /^\/set$/) { my $width = 0; map { $width = length() if $width < length() } keys %config; for my $k (sort keys %config) { printf "\t%-${width}s %s\n", $k, $config{$k}; } } elsif ($message =~ /^\/new\s*nodes\b/) { newnodes; } elsif ($message =~ /^\/xp\b/) { xp; } elsif ($message =~ /^\/node\s+(\d+)/) { node($1); } elsif ($message =~ /^\/h(elp)?\b/) { help; } elsif ($message =~ /^\/reload\b/) { print "Reloading $0!\n"; writeconfig; exec $0; } elsif ($message =~ /^\/update\b/) { autoupdate; } elsif ($message =~ /^\/(msg|me|em|tell|(un)?ignore|chattero(ff|n)) +\b/) { postmessage($message); } elsif ($message =~ /^\//) { print "Unknown command '$message'.\n"; } elsif ($message =~ /^\s*$/) { ; } else { postmessage($message); } } }

In reply to pmchat-2 by samwyse

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!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • 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 cooling their heels in the Monastery: (7)
    As of 2020-03-29 10:05 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      To "Disagree to disagree" means to:









      Results (169 votes). Check out past polls.

      Notices?