perlcraft
mr.nick
#!/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 supports Win32 installations with a different ReadLine
## call.
## Autoupdate now actually autoupdates
## Oh, and it has no error checking :)
my $ID='$Id: pmchat,v 1.42 2001/06/03 17:49:22 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);
use HTML::Parser;
use File::Copy;
$|++;
my $pm='http://www.perlmonks.org/index.pl';
my $cookie="$ENV{HOME}/.pmcookie";
my $cffile="$ENV{HOME}/.pmconfig";
my %config=(
timestamp => 0,
colorize => 1,
browser => '/usr/bin/lynx %s',
newnodes => 25,
updateonlaunch => 0,
timeout => 15,
);
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 (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 "http://www.mrnick.binary9.net/pmchat/version");
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");
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 $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 $^O=~/win32/i;
"$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 $^O=~/win32/i;
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>);
print "Enter your password: "; chomp($pass=<STDIN>);
$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})." experience!\n";
}
($config{xp},$config{level})=($xml->{XP}->{xp},$xml->{XP}->{level});
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->{user}};
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->{author_user}}:"Anonymous Monk"),
$x->{nodetype});
last if $cnt++==$config{newnodes};
}
}
print "\n";
}
##############################################################################
##############################################################################
sub showmessage {
my $msg=shift;
my $type=shift || '';
for my $k (keys %$msg) {
$msg->{$k}=~s/^\s+|\s+$//g
}
print "\r";
if ($type eq 'private') {
print wrap('',"\t",
($config{timestamp}?sprintf "%02d:%02d:%02d/",(unpack("A8A2A2A2",$msg->{time}))[1..3]:'').
colorize("$msg->{author} says $msg->{content}","private").
"\n");
}
else {
if ($msg->{content}=~s/^\/me\s+//) {
print wrap('',"\t",
($config{timestamp}?sprintf "%02d:%02d:%02d/",(unpack("A8A2A2A2",$msg->{time}))[1..3]:'').
colorize("$msg->{author} $msg->{content}","me"),
"\n");
}
else {
print wrap('',"\t",
($config{timestamp}?sprintf "%02d:%02d:%02d/",(unpack("A8A2A2A2",$msg->{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 node.
/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 $^O=~/win32/i;
$message=$term->readline("Talk: ",$old);
$old=$readline::line='';
alarm(0) unless $^O=~/win32/i;
};
$message;
}
sub getlineWin32 {
my $message=ReadLine($config{timeout});
## 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.
$message;
}
## initialize our user agent
$ua=LWP::UserAgent->new;
$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{COLUMNS} || 80;
if (-e $cookie) {
cookie;
}
else {
login;
}
my($this)=$ID=~/,v\s+([\d\.]+)/;
print "This is pmchat version $this.\n";
autoupdate(1) if $config{updateonlaunch};
xp();
print "Type /help for help.\n";
who();
newnodes();
getprivatemessages;
getmessages();
while (1) {
my $message;
getprivatemessages;
getmessages;
if ($^O=~/win32/i) {
$message=getlineWin32;
}
else {
$message=getlineUnix;
}
if (defined $message) {
## we understand a couple of commands
if ($message=~/^\/who/i) {
who;
}
elsif ($message=~/^\/quit/i) {
writeconfig;
exit;
}
elsif ($message=~/^\/set\s+([^\s]+)\s+(.+)$/) {
$config{$1}=$2;
print "$1 is now $2\n";
}
elsif ($message=~/^\/set$/) {
for my $k (sort keys %config) {
printf "\t%-10s %s\n",$k,$config{$k};
}
}
elsif ($message=~/^\/new\s*nodes/) {
newnodes;
}
elsif ($message=~/^\/xp/) {
xp;
}
elsif ($message=~/^\/node\s+(\d+)/) {
node($1);
}
elsif ($message=~/^\/help/) {
help;
}
elsif ($message=~/^\/reload/) {
print "Reloading $0!\n";
writeconfig;
exec $0;
}
elsif ($message=~/^\/update/) {
autoupdate;
}
elsif ($message=~/^\/me/ || $message=~/^\/msg/) {
postmessage($message);
}
elsif ($message=~/^\//) {
print "Unknown command '$message'.\n";
}
else {
postmessage($message);
}
}
}