Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

pmchat-2

by samwyse (Scribe)
on Nov 01, 2008 at 17:14 UTC ( [id://720870]=sourcecode: print w/replies, xml ) Need Help??
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);
    }
  }
}
Replies are listed 'Best First'.
Re: pmchat-2 Unix Patch for Safe signal issue
by jakobi (Pilgrim) on Sep 28, 2009 at 23:06 UTC

    I had problems in using this script, as at least on recent Linux systems (Ubuntu jaunty 64bit), readline doesn't honor ALRM at all.

    The following workaround is a bit simpleminded, but at least automatically updates the display every n seconds, at the cost of the user entering an extra CR to reach the readline prompt (just normal reading from stdin, which still honors ALRM...).

    Patch -u for just the workaround follows

    Read more... (2 kB)

    Update: Slight clean up. The 2nd variant below does fix the ALRM issue nicely, but I cannot get the partial user input when interrupted, regardless of using PERL_RL=Gnu or not; which makes it impossible to type longer answers, esp. with a low timeout. So this version is the one to use for now.

    There's also a little issue when PM doesn't return a page. Can happen every few hours, leading to XMLin dying, as LWP didn't provide sane input and the return isn't tested. It seems to be sufficient to change the XMLin statements to my $xml; eval{$xml = XMLin($r->content)}; return if $@;. Another small one in case you print timestamps: Change the unpack template from 8x to 10x to account for the modified timestamp fields. chmod 0600 on cookie file. Changed to add the node titles on numeric id:// links.

    Note that type-ahead isn't affected by the alarm issue, so I now just insert the type-ahead into the readline handling in case you start typing w/o pressing RETURN first for the readline-prompt. This way start typing, press RETURN for full line editing and continue typing, then press a 2nd RETURN to send the message.

    pm_chat2 in the version I'm currently using (as of 20091021; slightly extended, see /help), and which I'll keep updated in this node.

    Read more... (24 kB)

    pm_self: A quick&dirty crippled down companion version to just message yourself. Suited to resolve shortcut urls and nothing else (pointers to maintained Unix-capable replacements: welcome, *: a wrong thing(TM) to do and even worse to publish, I know)

    Read more... (5 kB)
[reply]
[d/l]
[select]
      Maybe you need unsafe signals?
[reply]

        (5.8 sounds interesting from the time frame. Will check this tomorrow & update this reply node. thx!)

        OK/fail*: just setting PERL_SIGNALS=unsafe in the shell indeed does the trick, however this affects the whole program, even if it makes the original program work again.

        FAIL: there are low level readline lib variables with interesting names e.g. in Term::ReadLine::Gnu: _rl_vars{rl_catch_signals}=['C',20]; however these reliably fail for me as I'm too lazy to actually read both the library and XS to make sense of them :/.

        FAIL: there were some related pointers via google that PERLIO=perlio instead of stdio solves some recent trouble with 5.10 with IO. Changing the environment variable alone is insufficient. And readline might well do it's own IO in parallel to perlio!?

        probably OK and localized: Perl::Unsafe::Signals

        OK/fail* and localized: POSIX::sigaction, see search.cpan.org/~dapm/perl-5.10.1/pod/perlrun.pod#PERL_SIGNALS and search.cpan.org/~dapm/perl-5.10.1/pod/perlipc.pod#Deferred_Signals_(Safe_Signals) (sorry, the shortcut perlipc and perlrun docs are different, incomplete versions; thus the cpan links instead).

        *) "fail" as I cannot see a way to get the partial line on ALARM. For both POSIX::sigaction and also PERL_SIGNALS=unsafe, the original way to access it seems broken.

[reply]
[d/l]
[select]
Re: pmchat-2
by jakobi (Pilgrim) on Sep 29, 2009 at 13:10 UTC

    Here is the POSIX::sigaction variant of the short patch updating the script to work with UNIX again. It no longer requires the extra CR, instead using unsafe signals locally for interrupting readline.

    Thanx to anonymous for the pointer.

    Please use the earlier Patch for the time being.

    (partial line lost, as noted below; so it's patch is merely a valid example for interrupting linked code with POSIX::sigaction, and annoying the user, but not for sane interrupted ReadLine use

    Read more... (1253 Bytes)

    It might be another improvement to also comment-out the undef of the handler and move the setting of the handler to just below the use Term::Readline; as SIGALRM shouldn't happen without us using alarm().

    Update 1: with the change of the Alarm, I cannot obtain the partial input line (noticed when reducing the timeout). While there's a tantalizing rl_set_keyboard_input_timeout(int usec) for Gnu ReadLine, it's probably not worth the effort, as the version of the patch in the first post works well enough. KISS wins, I guess.

    Please drop me a line if you've a trick to try and get the partial line buffer. Thanx.

[reply]
[d/l]

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://720870]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others scrutinizing the Monastery: (4)
As of 2025-01-21 01:15 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Which URL do you most often use to access this site?












    Results (59 votes). Check out past polls.