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

pmchat

by mr.nick (Chaplain)
on Jun 03, 2001 at 19:28 UTC ( [id://85317]=sourcecode: print w/replies, xml ) Need Help??
Category: PerlMonks Related Scripts
Author/Contact Info mr.nick @ Perlmonks.org (email: mrnick@binary9.net)
Description: A text-mode client for the Chatterbox.

Main features:

  • Colorized output via ANSI escape sequences
  • Compatible with both *nix and Win32 (mostly :)
  • 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)
  • Requires NO configuration, download and run!
  • Displays Other Users
  • User configurable options (inside Pmchat) for
    • Time-stamping each message (for long-term running)
    • Turn off/on colorization
    • Number of New Nodes listed
    • Which browser to use for node viewing
    • Update 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".

Because pmchat is a text-mode client, it has the following shortcomings

  • Doesn't render HTML tags
  • Doesn't render special HTML entities (eg: &) 
#!/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;
    }
  }
}
Replies are listed 'Best First'.
Re: pmchat
by merlyn (Sage) on Jun 03, 2001 at 20:43 UTC
    Brief code review item...

    It's bad form to mix prompting with <>. Use <STDIN> instead. The <> operator was designed for pipe filters, looking at @ARGV (and therefore the command line) to determine whether to read from files or read from standard input. Since your program isn't wanting that feature (you really need the input to be from the terminal), your use of <> is misleading.

    -- Randal L. Schwartz, Perl hacker

[reply]
[d/l]
[select]
Re: pmchat
by ZZamboni (Curate) on Jun 03, 2001 at 21:42 UTC
[reply]
      Doh! I didn't realize; I do apologize. I had been bouncing this script around here for almost two weeks; having posted it (incorrectly) in "Craft" and hadn't heard it was conflicting with yours.

      Hm.

[reply]
        I really don't mind! I just thought it was funny that you chose the same name. Although "pmchat" is a pretty obvious name for a PerlMonks chat client, I guess :-) Besides, I don't think anyone uses the one included with my modules, since it's very simple and intended more as a test than anything else, so I don't think anyone will get confused.

        I have been very busy lately and only browsing Newest Nodes every once in a while, so I hadn't seen your previous post of the script, sorry about that.

        Cheers,

        --ZZamboni

[reply]
Re: pmchat
by z3d (Scribe) on Feb 09, 2004 at 11:55 UTC
    OK, so a few years later...Thanks! Tried the pmchat that comes with the PerlMonks PM's, but it didn't work out too well (no offense to original writer intended). Running your version today like a champ. Heh, still works and kicks!


    "I have never written bad code. There are merely unanticipated features."
[reply]
      Funny story: I just returned here after very long absence as well. My first thought was to remove this node as I figured there was no way it could still work :)

      mr.nick ...

[reply]
        Three years later, the code still works, but I've made some improvements: 720870
[reply]

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Node Status?
node history
Node Type: sourcecode [id://85317]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others pondering the Monastery: (6)
As of 2024-09-19 16:50 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    The PerlMonks site front end has:





    Results (25 votes). Check out past polls.
    Notices?
    • erzuuli‥ 🛈The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.