sourcecode
strredwolf
<code>
#!/usr/bin/perl
### Modules
use Tk;
use IO::Socket;
### Win32 junk
BEGIN {
my($win32)=1 if($^O eq 'MSWin32');
if($win32) {
eval 'use Win32::Shell';
die "$@\n" if($@);
}
}
### Configurables
$maxlines=500;
$blanknode=14532;
$delaysec=10;
# $proxy='';
### Code starts here
# HTTP request (w/o LWP's complexity)
sub httpreq {
my($method,$url,$headers,$content)=@_;
my($site,$dir,$port,$remote,$req,$result,$code,@top,$bot,$sock);
my($e)="\r\n";
# if(defined $proxy) {
# print "Through proxy....";
# $proxy=~ m#^http://([^/]+)(/.*)?$#i;
# } else {
$url=~ m#^http://([^/]+)(/.*)?$#i;
# }
$site=$1;$dir=$2;
$dir="/" unless($dir);
if($site =~ /^([^:]+):(\d+)$/)
{
$remote=$1; $port=$2;
} else {
$remote=$site; $port=80;
}
# if(defined $proxy) {
# $req="\U$method\E $url HTTP\\1.0$e";
# } else {
$req="\U$method\E $dir HTTP\\1.0$e";
# }
foreach $j (@$headers)
{
$req .= "$j$e";
}
if($method =~ /POST/i)
{
my($l)=length $content;
$req .= "Content-Length: $l$e$e";
$req .= $content;
} else {
$req .= $e;
}
$sock=IO::Socket::INET->new(
Proto => "tcp",
PeerAddr => $remote,
PeerPort => $port)
or return ''; #Nothing
$sock->autoflush(1);
print $sock $req;
$code=<$sock>;
my($i)=0;
while(<$sock>)
{
tr/\r\n//d;
last if(/^$/);
$top[$i++]=$_;
$main->update;
}
$bot='';
while(<$sock>) { $bot .= $_; $main->update; }
($code,$bot,@top);
}
### XML minipharser
# Splits a message up along XML tags. Returns the message in an array.
sub splitxml {
my($d,$fl,@j)=@_;
my(@tags,$i,$last);
while($d)
{
"" =~ /(.?)/;
if($d =~ s/^(<[^>]+>)//s) {
$tags[$i++]=$1;
} elsif( $fl && $d =~ s/^(\[[^\]]+\])//s ) {
$tags[$i++]=$1;
} else {
$d=~s/^([^<]+)//s unless($fl);
$d=~s/^([^<\[]+)//s if($fl);
if(length $1) {
$tags[$i++]=$1;
} else {
$d.=">" if($d=~/^\</);
$d.="]" if($d=~/^\[/);
}
}
}
(@tags);
}
# Takes a tag and splits it up into options.
# Returns a tag name and an hash.
sub splittag {
my($tag)=@_;
my($i,$j,$k,%opts,@t,$ti);
$tag=~ s/^<//; $tag=~ s/>$//;
$tag=~ s/^(\S+)\s+//; $ti=$1;
while($tag) {
$tag =~ s/^([^=]+)(=[\"\']([^\"\']+)[\"\']\s?)?//;
$opts{$1}=($2 ? $3 : 1);
}
($ti, %opts);
}
# Pharses a line and translantes all those & thingies...
sub xlateamp {
my($l,@j)=@_;
$l=~ s/</</g;
$l=~ s/>/>/g;
$l=~ s/&/&/g;
$l=~ s/&#(\d+);/chr($1)/eg;
return($l);
}
###
# URL launcher
sub do_url {
my($tag)=@_;
my($i,$h);
if($tag =~ /^url(\d+)/) {
$i=$1;
$h=$url[$i];
$h=~ s#^id:\/\/(\d+)$#http:\/\/perlmonks.org\/index.pl?node_id=$1#;
if($h !~ /^http:\/\// ) {
$h =~ s/([^\w ])/sprintf("%%%02X",ord($1))/eg;
$h =~ s/ /+/g;
$h="http://perlmonks.org/index.pl?node=$h";
}
if($win32) {
Win32::Shell::Execute("open", $h, undef,undef, "SW_SHOWNORMAL");
} else {
system("netscape -remote 'openURL($h)'");
}
}
}
# statnode
sub statnode {
my($node)=@_;
my($i,$j,$k,$l,$fl);
my($cd,$doc,@head)=&httpreq("GET",
"http://perlmonks.org/index.pl?node=node+query+xml+generator&nodes=$node",
["Cookie: $cookie"], "");
my(@lines)=splitxml($doc);
$fl=0;
for($i=0;$i<@lines;$i++) {
$l=$lines[$i];
$l=~ tr/\n\r//d;
$l=~ s/^\s+//;
$fl++ if($l=~/^<node/i);
$fl=0 if($l=~/^<\/node/i);
$k=$l if($fl);
}
$k="id://$node" unless($k);
return($k);
}
# LinePharzer
sub do_add {
my($msg)=@_;
if($raw)
{
$main_index_list->insert("end","\n$msg");
} else {
my($i,$j,$k,$l,%tags,$op);
my(@lines)=splitxml($msg,1);
$main_index_list->insert("end","\n");
$op='';
for($i=0;$i<scalar @lines;$i++)
{
$l=$lines[$i];
$tags{'code'}++, next if($l=~/^<\s*code/i && !$tags{'code'});
$tags{'code'}=$op='', next if($l=~/^<\/code/i);
unless($tags{'code'})
{
if($l=~/^\[([^\]]+)\]/) {
$j=$1; $k=$1;
if($j=~/^id:\/\/(\d+)$/) {
$k=statnode($1);
}
$j=$1, $k=$2 if($j=~/^([^\|]+)\|(.+)$/);
$url[$uc]=$j; $l=$k; $op="url$uc"; $uc++;
$main_index_list->insert("end",$l,$op);
$main_index_list->tagConfigure($op,-foreground=>"blue",
-data=>$j,
-underline=>1);
# merlyn code...
$main_index_list->tagBind($op, "<1>", do { my $thing = $op; sub { do_url($thing) } } );
$op='';
next;
}
if($l=~/^<a/i) {
my($t,%opt)=splittag($l);
$url[$uc]=$opt{'href'}; $tags{'a'}=$op="url$uc"; $uc++;
$main_index_list->insert("end",'',$op);
$main_index_list->tagConfigure($op,-foreground=>"blue",
-data=>$j,
-underline=>1);
# merlyn code...
$main_index_list->tagBind($op, "<1>", do { my $thing = $op; sub { do_url($thing) } } );
next;
}
if($l=~/^<\/a/i) {
$tags{'a'}=$op='';
next;
}
$l=xlateamp($l);
}
$main_index_list->insert("end",$l,$op) if($op);
$main_index_list->insert("end",$l) unless($op);
}
}
}
# Do an update of the tags.
sub do_update {
return if($uplock);
$uplock=1;
$main_bot_stat->configure(-text=>"Updating...");
my($c,$d,@h)=&httpreq("GET",
"http://perlmonks.org/index.pl?node=chatterbox+xml+ticker",
"","");
my($i,$l,$t,$au,$bt,$m,$fl,$uid,$ti,%opts);
if($c =~ /200 OK/ )
{
my(@lines)=splitxml($d);
$fl=0;
for($i=0;$i<@lines;$i++)
{
$l=$lines[$i];
$l=~ tr/\n\r//d;
$l=~ s/^\s+//;
if($l=~ /^<message/)
{
$au=$t=$uid='';
($ti,%opts)=splittag($l);
$au=$opts{'author'};
$t=$opts{'time'};
$uid=$opts{'user_id'};
$fl=1; $t=~ s/^....//;
$t=~ /^....(..)(..)/;$t+=0;
$m="$1:$2: [id://$uid|$au]";
next;
}
if( $l =~ /^<\/message>/ )
{
$t+=.01 while($msg{$t} && $msg{$t} ne $m);
$msg{$t}=$m;
$bt=$t; $fl=0;
next;
}
if( $fl==1 )
{
$l=xlateamp($l);
if( $l=~ /^\/me(.+)$/) { $m.=$1; } else { $m.=": $l"; }
$fl++;
} elsif ($fl>1) {
$m .= xlateamp($l);
}
}
if($prv) {
if($justin) {
$justin=0;
$j=(int $lasttime)+.01;
foreach $z (sort keys %pmsg)
{
$msg{$j}=$pmsg{$z};
$bt=$j; $j+=.01;
}
}
foreach $j (sort keys %pmsg) {
$i=$j; $i+=.01 while($msg{$i} && $msg{$i} ne $pmsg{$j});
$msg{$i}=$pmsg{$j};
$bt=$i if($bt < $i);
}
$prv=0; %pmsg=();
}
$bt=$bt+0;
if($bt > $lasttime)
{
my($f)=0;
my(@ti)=sort keys %msg;
$lasttime=$ti[0]-1 unless($lasttime);
foreach $i (@ti)
{
$f++ if($i > $lasttime);
do_add($msg{$i}) if($f);
}
$lasttime=$ti[-1]+0;
$main_index_list->see("end") if($f && $jump);
}
}
$main_bot_stat->configure(-text=>" ");
$uplock=0;
}
# We need a cookie for this routine. It's the XP and Private stuff.
sub do_userprv {
return 1 unless($in);
# Get the privates...
my($c,$ml,@h)=&httpreq("GET","http://perlmonks.org/index.pl?node=private+message+xml+ticker",
["Cookie: $cookie"],"");
my(@lines)=splitxml($ml);
my($i,$fl,$l,$au,$t,$m,@mid,$mi,$z,$ft,$uid);
for($i=0;$i<@lines;$i++)
{
$l=$lines[$i];
$l=~ tr/\n\r//d;
$l=~ s/^\s+//;
if($l=~ /^<message/)
{
$au=$t=$uid='';
($ti,%opts)=splittag($l);
$au=$opts{'author'};
$t=$opts{'time'};
$uid=$opts{'user_id'};
$z=$opts{'message_id'};
$mid[$mi++]="deletemsg_$z=yup";
$fl=1; $t=~ s/^....//;
$t=~ /^....(..)(..)/;$t+=0;
$m="$1:$2: [id://$uid|$au]";
next;
}
if($l=~ /^<message message_id=(.+) author=(.+) time=(.+)>/)
{
$z=$1;
$au=$2; $t=$3;
$au=~ tr/\"\'//d; $t=~ tr/\"\'//d;
$z=~ tr/\"\'//d; $t=~ s/^....//;
$mid[$mi++]="deletemsg_$z=yup";
$fl=1;
$t=~ /^....(..)(..)/; $t+=0;
$m="$1:$2: $au";
next;
}
if( $l =~ /^<\/message>/ )
{
$pmsg{$t}=$m; $prv++;
$bt=$t; $fl=0; $ft=$t unless($ft);
next;
}
if( $fl==1 )
{
$l=~ s/</</g;
$l=~ s/>/>/g;
$l=~ s/&/&/g;
if( $l=~ /^\/me(.+)$/) {
$m.=" (privately) ";
} else {
$m.="> ";
}
$m .= $l;
$fl++;
} elsif ($fl>1) {
$l=~ s/</</g;
$l=~ s/>/>/g;
$l=~ s/&/&/g;
$m .= $l;
}
}
# Now clear 'em...
my($req)=join "&",@mid;
$req.="&message=&message_send=talk&op=message";
($c,$ml,@h)=&httpreq("POST","http://perlmonks.org/index.pl",
["Cookie: $cookie"], $req)
if($oktoclear && $mi);
# Get XP.
($c,$ml,@h)=&httpreq("GET","http://perlmonks.org/index.pl?node=XP+xml+ticker",["Cookie: $cookie"], "");
@lines=splitxml($ml);
for($i=0;$i<@lines;$i++)
{
$l=$lines[$i];
$l=~ tr/\n\r//d;
$l=~ s/^\s+//;
if($l =~ /^<XP level=(.+) xp=(.+) xp2nextlevel=(.+) votesleft=(.+)>/)
{
my($lv,$xp)=($1, $2);
$lv=~ tr/\'\"//d; $xp=~ tr/\'\"//d;
$main_bot_xp->configure(-text=>"Lev: $lv XP: $xp");
}
}
}
# Do Login/out
sub do_loginout
{
my($i,$a,$c,@b);
unless($in)
{
$user=$main_btns_user->get;
$pass=$main_btns_pass->get;
# Log us in...
($a,$c,@b)=&httpreq("POST","http://perlmonks.org/index.pl","",
"op=login&user=$user&passwd=$pass&expires=%2b10y&login=Login&node_id=$blanknode");
if($a =~ /200 OK/)
{
foreach $i (@b)
{
$cookie=$1 if($i =~/Set\-Cookie: (userpass=[^;]+);/ );
}
if($cookie)
{
$main_bot_stat->configure(-text=>"Logged in.");
$in++; $justin++;
$main_btns_open->configure(-text=>"Logout");
$main_btns_user->configure(-state=>"disabled");
$main_btns_pass->configure(-state=>"disabled");
$main_art_text->configure(-state=>"normal");
do_userprv;
}
}
} else {
($a,$c,@b)= &httpreq("GET",
"http://perlmonks.org/index.pl?op=logout&node_id=$blanknode",
["Cookie: $cookie"], "");
if($a =~ /200 OK/) {
$cookie=''; $in=0;
$main_bot_stat->configure(-text=>"Logged out.");
$main_btns_open->configure(-text=>"Login");
$main_btns_user->configure(-state=>"normal");
$main_btns_pass->configure(-state=>"normal");
$main_art_text->configure(-state=>"disabled");
}
}
}
# Do some smackdowns.
sub do_chatter {
my($a,$b,@c,$z);
my($line)=$main_art_text->get;
$main_art_text->delete(0,end);
$line =~ s/([^\w ])/sprintf("%%%02X",ord($1))/eg;
$line =~ s/ /+/g;
($a,$c,@b)=&httpreq("POST","http://perlmonks.org/index.pl",
["Cookie: $cookie"],
"op=message&message=$line&node_id=$blanknode");
do_update;
}
# Menu handler
sub do_menu {
$menued=0 if($main_opts->state ne "normal");
unless($menued) {
$main_opts->post($main_btns_opts->rootx,
$main_btns_opts->rooty+$main_btns_opts->height);
} else {
$main_opts->unpost;
}
$menued=1-$menued;
}
sub do_regen {
my($i);
$main_index_list->delete("1.0", "end");
my(@ti)=sort keys %msg;
foreach $i (@ti)
{
do_add($msg{$i});
}
$lasttime=$ti[-1]+0;
$main_index_list->see("end");
}
$user=$pass=$line=$cookie=$lasttime='';
$in=$prv=$oktoclear=$justin=$menued=$uc=$uplock=0;
$jump=$raw=1;
@url=();
$main=MainWindow->new(-height=>320, -width=>240);
$main->geometry("240x320");
$main_btns = $main->Frame;
$main_btns_user = $main_btns->Entry(-width=> 10);
$main_btns_user->insert(0,"(username)");
$main_btns_pass = $main_btns->Entry(-show=> "*", -width=> 10);
$main_btns_open = $main_btns->Button(-text=> "Login",-padx=>1,-pady=>1,
-command=>sub{do_loginout});
$main_btns_opts=$main_btns->Button(-text=>">>",-padx=>1,-pady=>1,
-command=>sub{do_menu });
$main_btns_opts->pack(-side=>"right");
$main_btns_open->pack(-side=>"right");
$main_btns_user->pack(-anchor=>"w", -side=>"left", -fill=>"x", -expand=>1);
$main_btns_pass->pack(-anchor=>"w", -side=>"left", -fill=>"x", -expand=>1);
$main_btns->pack(-anchor=>"w",-side=>"top",-fill=>"x",-expand=>1);
$main_opts=$main->Menu(-tearoff=>1,-title=>"Options");
$main_opts->add("command", -label=>"Regenerate", -command=>sub{do_regen});
$main_opts->add("separator");
$main_opts->add("checkbutton", -variable=>\$jump, -label=>"Jump on scroll");
$main_opts->add("checkbutton", -variable=>\$oktoclear,
-label=>"Autoclear private messages");
$main_opts->add("checkbutton", -variable=>\$raw,
-label=>"Don't do fancy formatting");
#$main_opts=$main->Frame;
#$main_opts_jump=$main_opts->Checkbutton(-variable=>\$jump, -text=>"Jumpscroll");
#$main_opts_jump->pack(-anchor=>"w", -side=>"left");
#$main_opts_clear=$main_opts->Checkbutton(-variable=>\$oktoclear, -text=>"AutoClear PrvMsg");
#$main_opts_clear->pack(-anchor=>"w",-side=>"left");
#$main_opts->pack(-anchor=>"e",-side=>"top",-fill=>"x",-expand=>1);
$main_bot=$main->Frame;
$main_bot_stat=$main_bot->Label(-text=>"RedWolf MonkChatter");
$main_bot_stat->pack(-anchor=>"w",-side=>"left");
$main_bot_xp=$main_bot->Label(-text=>"Lev: 0 XP: 0");
$main_bot_xp->pack(-anchor=>"e",-side=>"right");
$main_bot->pack(-anchor=>"s",-side=>"bottom",-fill=>"x",-expand=>1);
$main_index = $main->Frame;
$main_index_list = $main_index->Text(-wrap=>"word");
$main_index_list->configure(-font=>"fixed") unless($win32);
$main_index_scroll = $main_index->Scrollbar(-width=> 10,
-command=> ["yview", $main_index_list]);
$main_index_list->configure(-yscrollcommand=>['set', $main_index_scroll]);
$main_index_scroll->pack(-side=>"right",-fill=>"y");
$main_index_list->pack(-fill=>"both", -expand=>1);
$main_art = $main->Frame;
$main_art_text = $main_art->Entry(-state=>"disable");
$main_art_text->bind("<Return>",sub{do_chatter;});
$main_art_text->pack(-fill=>'x', -expand=>1);
$main_art->pack(-fill=>"x", -expand=>1, -anchor=>"w", -side=>"bottom");
$main_index->pack(-fill=>"both", -anchor=>"w",-side=>"bottom");
do_update;
$main->repeat($delaysec*1000,sub{do_update});
$main->repeat(60*1000,sub{do_userprv});
MainLoop;
</code>
A chatterbox client in Perl/TK. Doesn't need XML or the
PerlMonks module. Fairly complete now.<P>
This has a newer XML pharser (it's not XML::Simple). It
also works in Windows. (Hey! ActiveState doesn't have Tk
pre-bundled!) Also, Level and XP stats, Jumpscroll control,
and clearing of the private messages once received (which
will automagically sweep previous items you've seen as a side
benifit). Also a raw client view and processing of
<code>[jumptags]</code> and some HTML(CODE and A tags).<P>
<B>To use:</b> Run as is, and log in via the top line like
the Java Chatterbox client (which it's style borrows from).
Once logged in, hit the "Return" key to send in a line of
chatter on the bottom entryline. There's several options on
the ">>" menu worth perusing; "Regenerate" will redo the
chatter log.<P>
Chatterbox Clients
[strredwolf]