http://www.perlmonks.org?node_id=720870
Category: Chatterbox Clients
Author/Contact Info
Description:

A text-mode client for the Chatterbox, revised from mr. nick's original version. Several features that were promised were apparently never implemented, and have been struck out in the list below. Consider them enhancement requests that I may or may not get around to.

Changes

  • Check for and fetch autoinstall updates from Perl Monks, rather than mr. nick's now-dead home page. (Note: This feature is configurable, but is turned off by default.)
  • User configurable options (inside pmchat) to
    • Show (or not) your XP when launched
    • Show (or not) who's logged on when launched
    • Show (or not) new nodes when launched
    • Change the URL to check for updates

Main features:

  • Colorized output via ANSI escape sequences (*unix only)
  • Compatible with both *nix and Win32 (mostly barely :)
  • Displays most recent New Nodes
  • Can launch a browser to view a node
  • Check for and autoinstall updates
  • An "Away" mode for not being in "Other Users"
  • Uses the various XML Generators of PerlMonks
  • Tracks XP status
  • Tracks Reputation of your nodes (and displays WHICH nodes have changed -- and by how much)
  • Can launch a browser to view a node
  • Requires NO configuration, just download and run!
  • User configurable options (inside pmchat) for
    • Time-stamping each message (for long-term running) Broken, don't use this.
    • Turn off/on colorization (*unix only)
    • Which browser to use for node viewing
    • Check for and install code updates on launch
    • Seconds between polls for new messages (n/a on Windows)
    • Debugging mode. No output is sent to Perlmonks
    • Log file. Keeps a log of all messages. Set "logfile" to the desired filename. To stop, set "logfile" to "0" or "none".

Shortcomings (because this is a text-mode client):

  • Doesn't render HTML tags
  • Doesn't render special HTML entities (eg: &)
#!/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);
    }
  }
}