|
#!perl -Tw
# framechat v2.04 by epoptai, view help for changes and credits
# http://www.perlmonks.org/index.pl?node=framechat
# usage:
# Must set first few config variables first, then call it from a web b
+rowser.
# On first run you'll be prompted for the password you set in config v
+ars.
# Make sure that access to your script installation is secure.
# Intended for use on localhost but other setups should work.
# Once running select 'help' for usage details.
use strict;
use CGI::Cookie;
use CGI qw(param header url escape unescape redirect -debug);
eval "use XML::Simple 'XMLin'"; # required xml parser
$@ && install_xml_simple();
use Data::Dumper;
use URI::Escape;
use LWP::UserAgent;
use LWP::Simple 'get';
use HTML::Entities;
use HTTP::Cookies;
use HTTP::Request::Common;
use vars qw(
$bodytag $boxmem $boxmode $broken $config_cols $config_rows $expand_ti
+tles $fborder $font_open
$frame_top_2columns $frame_column1_rows $frame_column2_rows @friends $
+history %launch_urls
$mnt $msgt $newestnodes $nnnodes $nnt $nodes $nr $password $perlmonks
+$perlmonks_off $proxy
$proxyid $proxypass $rct $refresh_chat $refresh_nn $refresh_pchat $ref
+resh_rep $refresh_user
$refresh_xp $repframe_rows $repurl $reverse_inbox $reverse_pchat $sear
+ch_max $stylesheet
$tablestyle @tags $temp $trgt $use_proxy $username @verb
); # declare all config variables
# NOTE: If a config file exists it will override the following setting
+s!
# begin config variables, must set first 5 (don't edit this line)
$perlmonks = 'www.perlmonks.org'; # the domain you usually use for per
+lmonks, should have a www. prefix
$perlmonks_off = ''; # a domain for which you have no browser cookie f
+or perlmonks
$username = ''; # perlmonks username
$password = ''; # perlmonks password
$temp = './'; # dir where files are saved, must be able to create, wri
+te and read files in the temp dir.
# must also have a trailing directory delimiter!
$broken = ''; # set to 'yes' if running on IIS (see perlmonks node 760
+03)
# display options
@friends = qw(); # put usernames you want bold in the userlist
$bodytag = '<BODY bgcolor="#000000" text="#CCCCCC" link="#CCFFFF" vlin
+k="FFFFCC">'; # used everywhere
$stylesheet = ''; # global stylesheet
$tablestyle = '<style><!-- td{ font-family:arial;font-size:80%; }// --
+></style>'; # small fonts in td tags
$font_open = ''; # chat and userlist font, use <font size="-1"> or <sm
+all> for smaller text
$mnt = ' target="monks"'; # username target window
$trgt = ' target="_blank"'; # user supplied link target
$nodes = ' target="_blank"'; # target for new, best, worst, etc.
$nnt = ' target="newnodes"'; # new nodes target
$rct = ' target="repnodes"'; # rep change target
$reverse_pchat = 'yes'; # yes for msgchat message order newest first
$reverse_inbox = 'yes'; # yes for active inbox message order newest fi
+rst
$expand_titles = 'yes'; # yes to lookup node titles for [id://node_id]
+ links
@verb = qw(lurking romping hanging wandering stumbling floating); # n
+others $verb[x] around the monastery
push @friends, $username; # comment this to not bold own name in userl
+ist
$newestnodes = ''; # url to newest nodes client, blank = perlmonks lin
+k
$nnnodes = 60; # default minutes worth of new nodes, redefined lat
+er by a cookie
$config_cols = 80; # width of textarea where config is edited
$config_rows = 30; # height
# frames
$fborder = 2; # frameborder, less than 2 is hard
+to grab onto
$frame_top_2columns = '*,20%'; # parent frame for 2 columns of 3 r
+ows: inbox/chat/input & xp/users/links
$frame_column1_rows = '20%,*,20%'; # inbox/chat/input
$frame_column2_rows = '20%,*,20%'; # xp/users/links
$repframe_rows = '50%,50%'; # rep/chat frame
$boxmode = 'url'; # default top frame: either 'inbox', 'url', or 'nn'
$boxmem = 'yes'; # leave blank to always load $boxmode, 'yes' for coo
+kie memory
# refresh rates (seconds)
$refresh_chat = 12; # chatterbox
$refresh_user = 30; # userlist
$refresh_xp = 120; # xp nodelet
$refresh_pchat = 15; # private chat
$refresh_nn = 90; # new nodes default, redefined by a cookie
$refresh_rep = 5; # rep change MINUTES default, redefined by a coo
+kie
$nr = 500; # 1 in $nr chance of a nodereaper quip
# history
$history = 'on'; # 'on' enables daily history file
$search_max = 5000; # max history search results
# proxy
$use_proxy = ''; # 'on' enables use thru a proxy
$proxy = 'http://proxy.dom:port'; # must define this
$proxyid = '';
$proxypass = '';
# menus
%launch_urls = ( # launchpad menu, add your favorite search engines!
default => 'default',
google => 'http://www.google.com/search?q=',
lucky => 'http://www.google.com/search?btnI=lucky&q=',
cpan => 'http://search.cpan.org/search?mode=module&query=',
isbn => 'http://www1.fatbrain.com/asp/BookInfo/BookInfo.asp?fro
+m=MDZ411&theisbn=',
merlyn => 'http://www.stonehenge.com/perl/googlecolumnsearch?sear
+ch_for=',
perldoc => 'http://www.perldoc.com/cgi-bin/htsearch?words=',
define => 'http://www.dict.org/bin/Dict?Form=Dict1&Strategy=*&Dat
+abase=*&Query=',
jargon => 'http://www.science.uva.nl/cng/search/htsearch.CGI?rest
+rict=%2F%7Emes%2Fjargon%2F&words=',
kobe => 'http://theoryx5.uwinnipeg.ca/mod_perl/cpan-search?file
+type=+distribution+name+or+description&j&case=clike&search=',
pad => "http://$perlmonks/index.pl?node_id=108949&user=",
);
# tag menu - tags to insert in input area
# these values are used for the menu display, and are the inserted dat
+a
@tags = (
'/me ',
'/msg ',
'[id://] ',
'[pad://] ',
'[cpan://] ',
'[kobe://] ',
'[perldoc://] ',
'[jargon://] ',
'[google://] ',
'[lucky://] ',
'[isbn://] ',
'[http://] ',
'[ftp://] ',
'<code></code> ',
'<tt></tt> ',
'<a href=""></a> ',
'/ignore ',
'/unignore ',
'/login ',
'/logout '
);
# end config variables (don't edit this line)
my%i = map {$_ => param($_)} param; # param hash
# files
my$present = time;
my@time = localtime $present; # current history, prefix with _ as of v
+1.3
my$today = sprintf("${temp}_%4u%02u%02u.txt", $time[5]+1900, $time[4]+
+1, $time[3]); # don't change this
my$normfile = $temp.'framechat-norm';
my$cookies = $temp.'framechat-cookies';
my$config = $temp.'framechat-config';
my$repfile = $temp.'framechat-rep';
my$rephistfile = $temp.'framechat-rephist';
eval "require '$config'"; # use external config file if it exists and
+has valid syntax
my(@ck,$c,$erc) = ();
if($@){ # internal config
$c = CGI::Cookie->new(-name=>"config",-value=>'0',-expires=>'+10y'
+);
push @ck, $c;
$erc = 0
}
else{ # external config
$c = CGI::Cookie->new(-name=>"config",-value=>'1',-expires=>'+10y'
+);
push @ck, $c;
$erc = 1
}
my%cookie = CGI::Cookie->fetch(); # get cookies
my$cookie_names = 'framechatpass|nnnodes|refresh_n?r?|xp|boxmode|logou
+t|config';
my$userpass = crypt($password,$username);
my$state = $present; # used in authentication
# html
my$nb = ' ';
my$pbr = '<p><br>';
my$bq = '<blockquote>';
my$eh = '</body></html>';
# paths
my$uri = url(); # self url
$perlmonks = $perlmonks_off if $cookie{'logout'};
my$pmurl = "http://$perlmonks/index.pl"; # perlmonks
my$new = "$pmurl?node_id=3628"; # link to newest nodes html
$new = $newestnodes if $newestnodes; # link to custom new node u
+rl?
my$chatxml = "$pmurl?node_id=15834"; # Chatterbox XML Ticker
my$mesgxml = "$pmurl?node_id=15848"; # Private Message XML Ticker
my$userxml = "$pmurl?node_id=15851"; # Other Users XML Ticker
my$xpxml = "$pmurl?node_id=16046"; # XP XML Ticker
my$nnxml = "$pmurl?node_id=30175"; # Newest Nodes XML Generator
my$repurl = "$pmurl?node_id=32704"; # User Nodes XML Generator
my$queryxml = "$pmurl?node_id=37150"; # Node query XML Generator
my$normhtml = "$pmurl?node_id=5938"; # Node where $NORM lives
my$chaturl = "$uri?node=showchatmessages&displaytype=raw"; # raw html
my($norm,$req,$res,$ua) = ('') x 4;
my($msgcount,$msg_act,$msg_arc,$login) = (0) x 4;
my$gmt = gmtime $present;
$gmt =~ s/^.*\s(\S+)\s\S+$/$1/;
my$loc = localtime $present;
$loc =~ s/\s(\S+)\s(\S+)$/ $2 $1/;
my$nrl = '<i><a href="$pmurl?node_id=52855">NodeReaper</a>';
my@reaper = (
"$nrl preheats the oven before tossing in a cherry pie</i>",
"$nrl tiptoes up behind an unsuspecting visitor</i>",
"$nrl sharpens his scythe</i>",
);
my(%info,$changes,$credits); # declare info vars
# mod_perl_patch_begin
get_info(); # define info vars
# client authentication
$state = $cookie{'framechatpass'}->value if $cookie{'framechatpass'};
if($i{'passwd'}){
$i{'passwd'} = crypt($i{'passwd'},$username);
$state = $i{'passwd'}
}
getpass('1') if $state ne $userpass && $ENV{'REMOTE_ADDR'};
# launch before headers and cookies
msgsend() if $i{'sexisgood'} && $i{'sexisgood'} eq 'submit'; # send fr
+om inbox or private chat
if($i{'op'} && $i{'op'} eq 'message'){ # input from talk frame
sendit() unless ($i{'n'} && $i{'n'} =~ /tag|en(?:t|code)|int/);
}
# norm and launchpad
if($i{'n'}){
setup() if $i{'n'} =~ /^config saved?$/;
norm() if $i{'n'} eq 'norm';
orbit() if $i{'n'} eq 'launch';
}
orbit() if $i{'payload'};
unless($i{'op'} || $i{'sexisgood'} || $i{'privuser'}){
if($i{'node'}){ # handle links for logout
$i{'node'} = escape($i{'node'});
if($i{'displaytype'}){ $i{'node'} = $i{'node'}.'&displaytype='
+.$i{'displaytype'} }
print redirect(-uri=>"$pmurl?node=$i{'node'}")
}
if($i{'node_id'}){ # handle links for logout
if($i{'displaytype'}){ $i{'node_id'} = $i{'node_id'}.'&display
+type='.$i{'displaytype'} }
print redirect(-uri=>"$pmurl?node_id=$i{'node_id'}")
}
}
# set cookies
if($i{'passwd'}){ # client login
if($i{'passwd'} eq $userpass){
$c = CGI::Cookie->new(-name=>"framechatpass",-value=>"$i{'pass
+wd'}",-expires=>'+10y');
push @ck, $c;
if($i{'login'} == 0){ # server login
$c = CGI::Cookie->new(-name=>"logout",-value=>'1',-expires
+=>'+10y');
push @ck, $c
}
if($i{'login'} == 1){ # server logout
$c = CGI::Cookie->new(-name=>"logout",-value=>'',-expires=
+>'-1h');
push @ck, $c
}
}
if($i{'passwd'} ne $userpass){
$c = CGI::Cookie->new(-name=>"framechatpass",-value=>'',-expir
+es=>'-1h');
push @ck, $c;
}
}
if($i{'the'} && $i{'the'} eq 'end'){
$c = CGI::Cookie->new(-name=>"framechatpass",-value=>'',-expires=>
+'-1h');
push @ck, $c;
print redirect(-uri=>"$uri",-cookie=>[@ck]) unless $broken eq
+'yes';
print redirect(-uri=>"$uri",-cookie=>[@ck],-nph=>1) if $broken eq
+'yes';
}
if($boxmem eq 'yes' && ($i{'n'} && $i{'n'} =~ /^inbox|url|nn$/)){ # in
+box frame memory
$c = CGI::Cookie->new(-name=>"boxmode",-value=>"$i{'n'}",-expires=
+>'+10y');
push @ck, $c;
$boxmode = $i{'n'}
}
if($i{'refresh_rep'} && $i{'refresh_rep'} =~ /\d+/){ # reputation refr
+esh rate
$c = CGI::Cookie->new(-name=>"refresh_rep",-value=>"$i{'refresh_re
+p'}",-expires=>'+10y');
push @ck, $c;
$refresh_rep = $i{'refresh_rep'}
}
if($i{'refresh_nn'} && $i{'refresh_nn'} =~ /\d+/){ # new nodes refresh
+ rate
$c = CGI::Cookie->new(-name=>"refresh_nn",-value=>"$i{'refresh_nn'
+}",-expires=>'+10y');
push @ck, $c;
$refresh_nn = $i{'refresh_nn'}
}
if($i{'nnnodes'} && $i{'nnnodes'} =~ /\d+/){ # amount of new nodes
$c = CGI::Cookie->new(-name=>"nnnodes",-value=>"$i{'nnnodes'}",-ex
+pires=>'+10y');
push @ck, $c;
$nnnodes = $i{'nnnodes'}
}
if($i{'xp'} && $i{'xp'} =~ /\d+/){ # xp memory
$c = CGI::Cookie->new(-name=>"xp",-value=>"$i{'xp'}",-expires=>'+1
+0y');
push @ck, $c
}
print header(-cookie=>[@ck]) if @ck;
print header unless @ck;
# get cookies
$refresh_rep = $cookie{'refresh_rep'}->value if $cookie{'refresh_rep'}
+ && !$i{'refresh_rep'};
$refresh_nn = $cookie{'refresh_nn'}->value if $cookie{'refresh_nn'}
+ && !$i{'refresh_nn'};
$nnnodes = $cookie{'nnnodes'}->value if $cookie{'nnnodes'}
+ && !$i{'nnnodes'};
$i{'xp'} = $cookie{'xp'}->value if $cookie{'xp'}
+ && !$i{'xp'};
$boxmode = $cookie{'boxmode'}->value if $cookie{'boxmode'}
+ && $boxmem eq 'yes';
# launch after headers and cookies
if($i{'refresh_rep'}){ $i{'n'} = 'repframe'; reputation() }
newnodes() if $i{'refresh_nn'};
if($i{'n'}){
setup() if $i{'n'} =~ /^config/;
help() if $i{'n'} =~ /^help/;
reputation() if $i{'n'} =~ /^rep/;
getpass() if $i{'n'} eq 'getpass';
tools() if $i{'n'} eq 'tools';
search() if $i{'n'} eq 'sds';
check_update() if $i{'n'} eq 'update';
history() if $i{'n'} eq 'hist';
msgchat('init') if $i{'n'} eq 'msgchat';
tidy() if $i{'n'} eq 'tidy';
tidy('delete') if $i{'n'} eq 'delete';
inbox() if $i{'n'} eq 'inbox';
users() if $i{'n'} eq 'users';
chatter() if $i{'n'} eq 'chat';
ctrl() if $i{'n'} eq 'ctrl';
xp() if $i{'n'} eq 'xp';
launch() if $i{'n'} eq 'url';
newnodes() if $i{'n'} eq 'nn';
newnodes('n') if $i{'n'} eq 'nnn';
talk() if $i{'n'} eq 'int';
talk('enc') if $i{'n'} eq 'encode';
talk('ent') if $i{'n'} eq 'ent';
talk('tag') if $i{'n'} eq 'tag';
talk('usr') if $i{'n'} eq 'usr';
talk() if $i{'n'} eq 'talk';
tidy('view') if $i{'n'} eq 'view history';
tidy('delete') if $i{'n'} eq 'delete history';
search_history() if $i{'n'} eq 'search history';
search_history() if $i{'n'} eq 'count history';
if($i{'n'} eq 'privchat'){
$i{'privuser'} ? msgchat('frame') : msgchat('init');
}
msgchat('chat') if $i{'n'} eq 'pchat' && ($i{'privuser'} || $i{'pr
+ivchat'});
msgchat('talk') if $i{'n'} eq 'ptalk' && ($i{'privuser'} || $i{'pr
+ivchat'});
}
elsif($i{'find'}){ search_history()}
elsif($state eq $userpass){ # frameset
print qq~<html><title>framechat</title>
<frameset cols="$frame_top_2columns" border="$fborder">
<frameset rows="$frame_column1_rows">
<frame name="mesg" src="$uri?n=$boxmode" marginwidth="10" marginheig
+ht="10" scrolling="auto" frameborder="$fborder">
<frame name="chat" src="$uri?n=chat" marginwidth="10" marginheight="
+10" scrolling="auto" frameborder="$fborder">
<frame name="talk" src="$uri?n=talk" marginwidth="10" marginheight="
+10" scrolling="auto" frameborder="$fborder">
</frameset>
<frameset rows="$frame_column2_rows" border="$fborder">
<frame name="xp" src="$uri?n=xp" marginwidth="3" marginheight="3" sc
+rolling="auto" frameborder="$fborder">
<frame name="user" src="$uri?n=users" marginwidth="10" marginheight=
+"10" scrolling="auto" frameborder="$fborder">
<frame name="ctrl" src="$uri?n=ctrl" marginwidth="0" marginheight="0
+" scrolling="auto" frameborder="$fborder">
</frameset></frameset>
<noframes><blockquote><h1>Error</h1>Something went wrong with the hea
+der or this browser
doesn't support frames.<hr><a href="$uri">framechat</a>/$info{'versio
+n'}</noframes></html>~;
exit
}
else{ getpass()}
# mod_perl_patch_end
sub getpass
{ # client login form
my$bit = pop;
print header if $bit;
my$prnt = open_html('start','',$bodytag);
my($c1,$c2) = ('') x 2;
$cookie{'logout'} ? $c2 = ' checked' : $c1 = ' checked';
$prnt .= qq~<h1>Error</h1> Login is not possible unless both username
+and
password are set either in the script or a <b>valid</b> config file! P
+lease fix
this problem and <a href="$uri" target="_top">reload</a>.~
unless $username && $password && $userpass;
$prnt .= qq~$pbr <table align="center">
<form target="_top" method="post"><tr><td align="center">
password : <input type="password" name="passwd" size="23" maxlength="6
+4">
<input type="submit" value="start"><br>logged
<input type="radio" name="login" value="1"$c1>in or
<input type="radio" name="login" value="0"$c2>out
</form></td></tr></table>~ if $username && $password && $userpass;
$prnt .= $eh;
print $prnt;
exit
}
sub io
{ # generic sub to read and write files
# usage:
# @array = io('read',$file)
# $string = io('read',$file)
# io('write',$file,$string)
# io('write',$file,\@array)
# io('write',$file,$ref,'name') - this one uses Data::Dumper
my($bit,$file,$data,$name) = @_;
if($bit eq 'read'){
open IO,"< $file" or die "Error opening $file for input: $!\n";
my@file = <IO>;
close IO;
return wantarray ? @file : join '', @file;
}
if($bit eq 'write'){
open IO,"> $file" or die "Cannot open $file for output: $!\n";
print IO $data unless ref $data || $name;
print IO @$data if ref $data eq 'ARRAY';
print IO Data::Dumper->new([$data],[$name])->Indent(0)->Quotekeys(
+0)->Dump if $name;
close IO;
}
}
sub setup
{ # create, edit, save, delete or update config file
if($i{'n'} eq 'config make'){
my@self = io('read',$0);
my($c,@vars) = 0;
for(@self){
$c = 2 if (/^.\send\sconfig\svariables/);
push @vars, $_ if $c == 1;
$c = 1 if (/^.\sbegin\sconfig\svariables,/);
last if $c == 2;
}
io('write',$config,\@vars);
tools()
}
my$wrn = qq~<b>Warning:</b> If this file doesn't have valid perl synta
+x it will fail
to be included. <ol><font size="-1">
<li>If username and password are set in the script then a bad conf
+ig file will
silently fail to be included and the variables defined in the scri
+pt body will
be used instead. See <a href="$uri?n=tools">tools</a> for config s
+tatus.<br><p>
<li>If username and password are <b>not</b> set in the script then
+ a bad config
file will <i>prevent client login</i> and you will be locked out.
+If this happens
either manually edit and fix the config file, or put your username
+ and password in
the script so you can edit a bad config file here.<br>
</font></ol>~;
if($i{'n'} eq 'config edit'){
my@config = io('read',$config);
$temp = '<u>valid</u>' if $erc eq '1';
$temp = '<b>invalid</b>' if $erc ne '1';
my$prnt = open_html($i{'n'},'',$bodytag);
$prnt .= qq~<table width=60%><tr><td>$wrn </td></tr></table>
<p>This config file had $temp syntax when it was loaded.
<p><form method='post'><input type="submit" name="n" value="config
+ save">
<br><textarea cols="$config_cols" rows="$config_rows" name="config
+">~;
$prnt .= $_ for @config;
$prnt .= qq~<\/textarea></form> $eh~;
print $prnt;
exit
}
if($i{'n'} eq 'config save'){
$i{'config'} =~ s/\r\n/\n/g;
io('write',$config,$i{'config'});
print redirect(-uri=>"$uri?n=config+saved",-cookie=>[@ck]) unl
+ess $broken eq 'yes';
print redirect(-uri=>"$uri?n=config+saved",-cookie=>[@ck],-nph=>1)
+ if $broken eq 'yes';
}
if($i{'n'} eq 'config saved'){
my$prnt = open_html('config saved','',$bodytag);
$prnt .= qq~$config saved! <a href="$uri?n=tools">ok</a><p>~;
eval "require '$config'";
$prnt .= qq~$config appears to have syntax errors, please fix it.~
+ if $@;
print $eh.$prnt;
}
if($i{'n'} eq 'config delete'){
unlink $config or die "Can't delete $config: $!";
tools()
}
if($i{'n'} eq 'config update'){
my@self = io('read',$0);
my@config = io('read',$config);
my($c,@vars,%seen) = 0;
for(@self){
$c = 2 if (/^.\send\sconfig\svariables/);
push @vars, $_ if $c == 1;
$c = 1 if (/^.\sbegin\sconfig\svariables,/);
last if $c == 2;
}
my$self = join '', @self;
my(%code,%new,@new);
$code{$2} = $1 if $self =~ /^([\$\@%][\S]+)\s*=\s*/;
for(@config){
if(/^([\$\@%][\S]+)\s*=\s*/){ $seen{$1} = 1 }
}
$c = 0;
for(@vars){
my($fu,$ba) = ($1,$2) if /^([\$\@%][\S]+)\s*=[^#]+(#[^\n]+)/;
if($fu && !$seen{$fu}){
$c++;
push @new, $fu;
$new{$fu} = $nb.$ba;
}
}
my($s,$ss) = ('s','');
$s = '' if $c == 1;
$ss = 's' if $c == 1;
my$prnt = open_html('new config variables','',$bodytag);
if($c > 0){
$prnt .= qq~$bq <p><font size="+1">$c new config variable$s fo
+und!</font><p>
The following $c variable$s need$ss to be added to your config
+ file if you wish to
<a href="$uri?n=config+edit">edit</a> them.<ol><tt>~;
$prnt .= qq~<li><b>$_</b> $new{$_}~ for @new;
$prnt .= '</tt></ol>';
$prnt .= qq~<p><form><b>Find and copy the $c new variable$s fr
+om here, paste below and save.</b>
<br><textarea cols="$config_cols" rows="$config_rows" name="co
+nfig">~;
$prnt .= $_ for @vars;
$prnt .= qq~<\/textarea></form>~;
$prnt .= qq~$pbr $wrn
<form method='post'><input type="submit" name="n" value="confi
+g save">
<br><textarea cols="$config_cols" rows="$config_rows" name="co
+nfig">~;
$prnt .= $_ for @config;
$prnt .= qq~<\/textarea></form>~;
}
$prnt .= qq~$bodytag $bq $pbr No new config variables, <a href="$u
+ri?n=tools">return</a>.~ if $c == 0;
$prnt .= $eh;
print $prnt;
}
}
sub tools
{
my($c,$s,$f) = ('0','','0');
$info{'date'} =~ s/(....)(..)(..)/$2\/$3\/$1/;
my$prnt = open_html('tools','',$bodytag);
$prnt .= qq~<blockquote><p><form method="post">
<p>This is <a href="$uri?n=help#new"><b>version $info{'version'}</b></
+a> released $info{'date'}.
Check for an <input type="submit" name="n" value="update"></form>
<li><font size="+1">Ignored Users</font> ~;
for(keys %cookie){
my$fu = $cookie{$_}->value;
my$u = escape($_);
if($fu eq 'ignore'){
$c++;
$prnt .= qq~<font size="-1">(use these links to unignore)</fon
+t>~ if $c == 1 && $broken ne 'yes';
$prnt .= '<ol>' if $c == 1;
$prnt .= qq~<li><a href="$uri?op=message&n=link&message=/unign
+ore+$u">$_</a><br>~ if $broken ne 'yes';
$prnt .= qq~<li>$_<br>~ if $broken eq 'yes';
}
}
$prnt .= '</ol>' if $c > 0;
$prnt .= '<p>none' if $c < 1;
$prnt .= qq~<p><li><font size="+1">Config</font><ul>~;
$f = 1 if -e $config;
if($f == 1){
$_ = (-s $config);
$prnt .= qq~Config file <b>$config</b> ($_ bytes) exists<br>~;
$prnt .= qq~and is currently in use. Syntax is ok.~ if $erc == 1;
$prnt .= qq~but is <b>not</b> in use. Check file syntax!~ unless
+ $erc == 1;
}
else{ $prnt .= qq~<li><a href="$uri?n=config+make">Create</a> config f
+ile~}
if($f == 1){
$prnt .= qq~<p><li><a href="$uri?n=config+edit">Edit</a> config fi
+le.<br>
<font size="-1">Perl syntax <i>must</i> be correct!</font>~;
}
else{ $prnt .= '<p><li>Edit config file' }
if($f == 1){
$prnt .= qq~<p><li><a href="$uri?n=config+update">Update</a> confi
+g file ~;
$prnt .= qq~<br>
<font size="-1">Use when updating to list new config vars to add t
+o your config file.</font>~
}
else{ $prnt .= '<p><li>Update config file'}
if($f == 1){
$prnt .= qq~<p><li><a href="$uri?n=config+delete">Delete</a> confi
+g file<br>
<font size="-1">Deletes the config file, no confirm.</font>~
}
else{ $prnt .= '<p><li>Delete config file'}
$prnt .= qq~</ul><p><li><form>
<font size="+1">Chat history</font> $nb
<input type="submit" value="view/search/delete">
<input type="hidden" name="n" value="tidy">
</form>
<li><font size="+1">Rep history</font> $nb <a href="$uri?n=rephistview
+">view</a>
<p>
<li><font size="+1">XML</font><ul>
<li><a href="$chatxml">Chatterbox XML Ticker</a>
<li><a href="$userxml">Other Users XML Ticker</a>
<li><a href="$mesgxml">Private Message XML Ticker</a>
<li><a href="$repurl">User Nodes XML Generator</a>
<li><a href="$queryxml">Node query XML Generator</a>
</ul>
<li><font size="+1">HTML</font><ul>
<li><a href="$uri?n=msgchat">Private Chat</a>
<li><a href="$uri?n=url">Launchpad</a>
<li><a href="$uri?n=nn">New Nodes</a>
<li><a href="$uri?n=repframe">Reputation Change</a>
<li><a href="$uri?n=rephistview">Reputation History</a>
<p>
<li><a href="$pmurl">The Monastery Gates</a>
<li><a href="$chaturl">rawchat</a>
</ul>
<li><font size="+1">Files</font><ul>
<li><a href="$normfile">$normfile</a>
<li><a href="$cookies">$cookies</a>
<li><a href="$config">$config</a>
<li><a href="$repfile">$repfile</a>
<li><a href="$rephistfile">$rephistfile</a>
</ul>
<li><font size="+1">Cookies</font><ul>~;
for(keys %cookie){ # show named & ignore cookies
next unless $_ =~ /^$cookie_names$/ || $cookie{$_}->value eq 'igno
+re';
$cookie{$_} =~ s/([^;]+);.*/$1/;
$prnt .= qq~<li>$cookie{$_}~
}
$prnt .= '<p>';
$prnt .= qq~</ul> $eh~;
print $prnt;
exit
}
sub install_xml_simple
{ # link to dist on cpan
print header;
print qq~framechat requires
<a href='http://search.cpan.org/search?dist=XML-Simple'>XML::Simple</a
+>~;
exit
}
sub launch
{ # url launch form
print header if $_[0]; # if float
my$prnt = open_html('launchpad','',$bodytag);
$prnt .= qq~<table border="0" cellpadding="0" cellspacing="0" width="1
+00%">
<FORM METHOD="POST" target="_blank"><tr><td>
<INPUT TYPE="text" NAME="payload" SIZE=40>
<INPUT TYPE="submit" name="n" VALUE="launch">
<select name="goto">~;
for(sort { lc($a) cmp lc($b) } keys %launch_urls){ # search engine men
+u
my$extra = '';
if($i{'goto'}){
$extra = ' selected' if $i{'goto'} eq $_;
$extra = '' if $i{'goto'} ne $_;
}
else{
$extra = ' selected' if $_ eq 'default';
}
$prnt .= qq~<option value="$_"$extra>$_ \n~;
}
$prnt .= qq~</select> $nb $nb $nb $nb <input type="reset" value="reset
+"></td>
<td align="right"><font size="-1"><a href="$uri?n=inbox">inbox</a> - <
+a href="$uri?n=nn">new</a></font></td></tr>
<tr><td colspan=2><font size="-1"><b>This form opens a new window and
+loads according to your input:</b>
<p><ul><b>default mode:</b> a query starting with http:// or ftp:// lo
+ads that url, anything else behaves
like the search form at perlmonks. <b>Other modes</b> query the select
+ed search engine. A <b>blank query</b>
has two variations, either press enter for a new framechat frameset, o
+r select 'launch' to float this
frame.</ul></font></td></tr></form></table> $eh~;
print $prnt;
exit
}
sub orbit
{ # launch the url
launch('fu') unless $i{'payload'} =~ /\S/;
if($i{'payload'}){
$i{'payload'} = uri_escape($i{'payload'});
if($i{'goto'} eq 'default'){
print redirect(-uri=>"$i{'payload'}") if $i{'payload'} =~ m|^[
+hf]tt?ps?://|;
print redirect(-uri=>"$pmurl?node=$i{'payload'}") if $i{'paylo
+ad'} !~ m|^[hf]tt?ps?://|;
}
else{
for(keys %launch_urls){
if($_ eq $i{'goto'}){
print redirect(-uri=>"$launch_urls{$_}$i{'payload'}");
}
}
}
}
}
sub ignore
{
my($n,$u) = @_;
unless($n =~ /\S/){ print header; talk($i{'message'})}
$u = unescape($u); # hmm
if($n == 1){
$_ = CGI::Cookie->new(-name=>"$u",-value=>'ignore',-expires=>'+10y
+');
}
if($n == 0){
$_ = CGI::Cookie->new(-name=>"$u",-value=>'',-expires=>'-1h');
}
if ($i{'n'} && $i{'n'} eq 'link'){
print redirect(-uri=>"$uri?n=tools",-cookie=>[$_]) unless $broken
+eq 'yes';
print redirect(-uri=>"$uri?n=tools",-cookie=>[$_],-nph=>1) if $bro
+ken eq 'yes';
}
else{ print header(-cookie=>[$_]); talk() }
}
sub logout
{
my$bit = pop;
if($bit eq '1'){
$_ = CGI::Cookie->new(-name=>'logout',-value=>'1',-expires=>'+10y'
+);
}
if($bit eq '0'){
$_ = CGI::Cookie->new(-name=>'logout',-value=>'',-expires=>'-1h');
}
print header(-cookie=>[$_]); talk()
}
sub sendit
{ # send a message to the chatterbox from the talk frame
if($i{'message'} =~ /^\/log(?:in|on|out|off)/){
logout('1') if $i{'message'} =~ /out|off$/;
logout('0') if $i{'message'} =~ /in|on$/;
}
if($i{'message'} =~ /^\/u?n?ignore/){
ignore('1',$1) if $i{'message'} =~ /^\/ignore\s([\S\s]+)/;
ignore('0',$1) if $i{'message'} =~ /^\/unignore\s([\S\s]+)/;
print header; talk($i{'message'});
}
my($xs,$msg) = ('') x 2;
unless($cookie{'logout'}){
if(length($i{'message'}) > 255){ # chunk large messages
($xs = $i{'message'}) =~ s/(.{1,254}\s)(?=\S)//; # regex from
+tye to break on words
$msg = $1 if $1;
if($msg =~ m/((?:\/msg|\/tell)\s[\S]+\s)/){
$xs = $1.$xs
}
}
else{ $msg = $i{'message'} }
login();
$req = POST ($pmurl, [op=>'message', message=>$msg, node_id=>'3715
+0']);
request();
}
else{ $xs = $i{'message'} }
print header unless $i{'sexisgood'};
talk($xs) if $i{'mode'} eq 'talk' || $cookie{'logout'};
help() if $i{'mode'} eq 'plug';
}
sub msgsend
{ # send a private message from inbox or msgchat
my($xs,$message,$tmp) = ('') x 3;
login();
if($i{'replytotext'} && length($i{'replytotext'}) > 255){ # inbox chun
+k
($xs = $i{'replytotext'}) =~ s/(.{1,254}\s)(?=\S)//;
$tmp = $1 if $1;
$i{'replytotext'} = $tmp;
}
if($i{'message'} && length($i{'message'}) > 255){ # msgchat chunk
# limit to 226 chrs to account for max username and tag bytes
($xs = $i{'message'}) =~ s/(.{1,226}\s)(?=\S)//;
$tmp = $1 if $1;
$i{'message'} = $tmp;
}
my$msg = $i{'message'};
if(!$cookie{'logout'}){
if($i{'privuser'} && ($msg =~ /\S/) && ($i{'n'} && $i{'n'} eq 'pta
+lk')){ # msgchat prefix
$i{'message'} = qq~/msg $i{'privuser'} $msg~;
}
$req = POST ($pmurl, [%i]); # send the whole form (%i)
request();
if($i{'cc'} || $i{'privuser'}){
if($i{'cc'} && $i{'replytotext'} && $i{'replytotext'} =~ /\S/)
+{ # cc to self
$message = qq~/msg $username $i{'replytotext'}~
}
if($i{'privuser'} && ($msg =~ /\S/) && ($i{'n'} && $i{'n'} eq
+'ptalk')){ # msgchat echo
$message = qq~/msg $username To:"$i{'privuser'}"-> $msg~
}
$req = POST ($pmurl, [op=>'message', message=>$message, node_i
+d=>'37150']);
request();
}
}
else{ $xs = $msg }
print header;
if($i{'n'}){
msgchat('chat') if $i{'n'} eq 'pchat';
msgchat('talk',$xs) if $i{'n'} eq 'ptalk';
}
inbox($xs);
}
sub login
{ # setup useragent, load cookies or login
$ua = LWP::UserAgent->new;
$ua->agent('framechat/'.$info{'version'});
$ua->proxy(http=>"$proxy") if $use_proxy eq 'on';
unless($cookie{'logout'}){ # unless logout is enabled
if(-e $cookies){ # if cookie file exists
my@ck = io('read',$cookies); # (checking the cookie file is fa
+ster than logging in)
@ck = join '', @ck;
my$up = $username.'%257C'.$userpass; # simulated pm cookie use
+d to verify the cookie file
if($ck[0] =~ /userpass=.?$up/){ # and seems valid
$ua->cookie_jar(HTTP::Cookies->new());
$ua->cookie_jar->load($cookies); # load the cookie
}
else{ unlink($cookies) or die "Can't unlink $cookies: $!" } #
+delete if it doesn't seem valid
}
unless(-e $cookies){ # unless a cookie file exists, login and crea
+te one
$ua->cookie_jar(HTTP::Cookies->new(file => "$cookies", ignore_
+discard => 1, autosave => 1));
$req = POST ($pmurl, [op=>'login', user=>$username, passwd=>$p
+assword, expires=>'+10y', node_id=>'37150']);
request();
}
}
$login++
}
sub request
{ # make http request
$req->proxy_authorization_basic("$proxyid","$proxypass") if $use_proxy
+ eq 'on';
$res = $ua->request($req);
}
sub encode
{ # UTF-8 to latin1 regex from XML::TiePYX (thanks to mirod)
my($text) = @_;
$text =~ s{([\xc0-\xc3])(.)}{
my $hi = ord($1);
my $lo = ord($2);
chr((($hi & 0x03) <<6) | ($lo & 0x3F))
}ge;
return $text;
}
sub fixxml
{ # fix the xml nodes so they parse correctly
my$xml = shift;
my$fix = q{<?xml version="1.0" encoding="ISO-8859-1"?>
<!DOCTYPE CHATTER SYSTEM "dummy.dtd"[]>}; # mirod to the re
+scue!
$xml = $fix.$xml unless $xml =~ /^\s*\Q<?xml\E/; # thank you tye
$xml =~ s/[\r\n\t]//g; # jcwren
return $xml; # to the xml parser
}
sub makelinks
{ # emulate perlmonks chatterbox link syntax
# forbidden tags are encoded and displayed rather than stripped
my$cpan = 'http://search.cpan.org/search?mode=module&query=';
my$isbn = 'http://www1.fatbrain.com/asp/BookInfo/BookInfo.asp?from=MDZ
+411&theisbn=';
my$jarg = 'http://www.science.uva.nl/cng/search/htsearch.CGI?restrict=
+%2F%7Emes%2Fjargon%2F&words=';
my$kobe = 'http://theoryx5.uwinnipeg.ca/mod_perl/cpan-search?filetype=
++distribution+name+or+description&j&case=clike&search=';
my$pdoc = 'http://www.perldoc.com/cgi-bin/htsearch?words=';
my$spad = "http://$perlmonks/index.pl?node_id=108949&user=";
my$content = shift;
if($content =~ m|<.*?>|){
$content=~s/<code>(.*?)<\/code>/codefix($1)/eig; # encodes the code a
+nd changes pairs of balanced 'code' tags to 'ccc'
$content=~s/(<\/?code>)/encode_entities($1)/eig; # nuke unbalanced co
+de tags
$content=~s/<ccc>/<code>/ig; # restore <ccc>
$content=~s/<\/ccc>/<\/code>/ig; # restore </ccc>
$content=~s/<tt>(.*?)<\/tt>/<ttt>$1<\/ttt>/ig; # same strategy for <t
+t>
$content=~s/(<\/?tt>)/encode_entities($1)/eig; # nuke unbalanced tt t
+ags
$content=~s/<ttt>/<tt>/ig; # restore
$content=~s/<\/ttt>/<\/tt>/ig; # restore
if(($i{'n'} && $i{'n'} =~ /^hist|(?:view|search) history$/) || $i{'hi
+stbyauth'}){
$content=~s/<i>(.*?)<\/i>/<iii>$1<\/iii>/ig; # same strategy for <i
+>
$content=~s/(<\/?i>)/encode_entities($1)/eig; # nuke unbalanced i ta
+gs
$content=~s/<iii>/<i>/ig; # restore
$content=~s/<\/iii>/<\/i>/ig; # restore
}
if($content =~ m|<a\s|i){
(my$pm = $pmurl) =~ s/.index\.pl//;
$content=~s/<a[^>]+href\s*=\s*['"]*([^:]+:\/\/[^'">]+)['"]*>(.*?)<\/
+a>/<a href="$1"$trgt>$2<\/a>/ig; # <a href="proto://url">
$content=~s/<a[^>]+href\s*=\s*['"]*([^:'">]+)['"]*>(.*?)<\/a>/<a hre
+f="$pm$1"$trgt>$2<\/a>/ig; # <a href=""> links without proto://
}
}
if($content =~ /\[[^\]]+\]/){
$content=~s/\[(http:\/\/[^|\]]+)\|([^\]]+)\]/<a href="$1"$trgt>$2<\/a
+>/ig; # [http://url|text]
$content=~s/\[(http:\/\/[^|\]]+)\]/<a href="$1"$trgt>$1<\/a>/ig;
+ # [http://url]
$content=~s/\[(ftp:\/\/[^|\]]+)\|([^\]]+)\]/<a href="$1"$trgt>$2<\/a>
+/ig; # [ftp://url|text]
$content=~s/\[(ftp:\/\/[^|\]]+)\]/<a href="$1"$trgt>$1<\/a>/ig;
+ # [ftp://url]
$content=~s/\[id:\/\/([^|\]]+)\|([^\]]+)\]/<a href="$pmurl?node_id=$1
+"$trgt>$2<\/a>/ig; # [id://node_id|text]
$content=~s/\[id:\/\/([^|\]]+)\]/titles($1)/eig if ($expand_titles eq
+ 'yes'); # [id://node_id] expand node title
$content=~s/\[id:\/\/([^|\]]+)\]/<a href="$pmurl?node_id=$1"$trgt>$1<
+\/a>/ig unless ($expand_titles eq 'yes'); # [id://node_id] don't expa
+nd title
$content=~s/\[cpan:\/\/([^|\]]+)\|([^\]]+)\]/<a href="$cpan$1"$trgt>$
+2<\/a>/ig; # [cpan://module|text]
$content=~s/\[cpan:\/\/([^|\]]+)\]/<a href="$cpan$1"$trgt>$1<\/a>/ig;
+ # [cpan://module]
$content=~s/\[jargon:\/\/([^|\]]+)\|([^\]]+)\]/<a href="$jarg$1"$trgt
+>$2<\/a>/ig; # [jargon://word|text]
$content=~s/\[jargon:\/\/([^|\]]+)\]/<a href="$jarg$1"$trgt>$1<\/a>/i
+g; # [jargon://word]
$content=~s/\[kobe:\/\/([^|\]]+)\|([^\]]+)\]/<a href="$kobe$1"$trgt>$
+2<\/a>/ig; # [kobe://module|text]
$content=~s/\[kobe:\/\/([^|\]]+)\]/<a href="$kobe$1"$trgt>$1<\/a>/ig;
+ # [kobe://module]
$content=~s/\[perldoc:\/\/([^|\]]+)\|([^\]]+)\]/<a href="$pdoc$1"$trg
+t>$2<\/a>/ig; # [perldoc://query|text]
$content=~s/\[perldoc:\/\/([^|\]]+)\]/<a href="$pdoc$1"$trgt>$1<\/a>/
+ig; # [perldoc://query]
$content=~s/\[pad:\/\/([^|\]]+)\|([^\]]+)\]/<a href="$spad$1"$trgt>$2
+<\/a>/ig; # [pad://user|text]
$content=~s/\[pad:\/\/([^|\]]+)\]/<a href="$spad$1"$trgt>$1's scratch
+ pad<\/a>/ig; # [pad://user]
$content=~s/\[google:\/\/([^|\]]+)\|([^\]]+)\]/google('G',$1,$2)/eig;
+ # [google://query|text]
$content=~s/\[google:\/\/([^|\]]+)\]/google('G',$1)/eig;
+ # [google://query]
$content=~s/\[lucky:\/\/([^|\]]+)\|([^\]]+)\]/google('L',$1,$2)/eig;
+ # [lucky://query|text]
$content=~s/\[lucky:\/\/([^|\]]+)\]/google('L',$1)/eig;
+ # [lucky://query]
$content=~s/\[isbn:\/\/([^|\]]+)\|([^\]]+)\]/<a href="$isbn$1"$trgt>$
+2<\/a>/ig; # [isbn://number|text]
$content=~s/\[isbn:\/\/([^|\]]+)\]/<a href="$isbn$1"$trgt>$1<\/a>/ig;
+ # [isbn://number]
$content=~s/\[([^|\]]+)\|([^\]]+)\]/nodetitle2($1,$2)/eig;
+ # [node title|text]
$content=~s/\[([0-9^|\]]+)\]/titles($1)/eig if ($expand_titles eq 'ye
+s'); # [node_id]
$content=~s/\[([0-9^|\]]+)\]/node_id($1)/eig unless ($expand_titles e
+q 'yes'); # [node_id]
$content=~s/\[([^|\]]+)\]/nodetitle1($1)/eig;
+ # [node title]
}
if(($i{'n'} && $i{'n'} =~ /^hist|(?:view|search) history$/) || $i{'his
+tbyauth'}){
$content=~s/(<(?!(a\s|tt>|code>|i>|\/a>|\/tt>|\/code>|\/i>)))/encode_
+entities($1)/eig; # only allow a, tt, i & code tags
}
else{
$content=~s/(<(?!(a\s|tt>|code>|\/a>|\/tt>|\/code>)))/encode_entities
+($1)/eig; # or only allow a, tt & code tags
}
return $content;
}
# next 6 are makelinks() support subs
sub titles
{ # expand node title for [id://node_id] links
my$node = shift;
my$id = $node;
my$nt = "$queryxml&nodes=$node"; # node query xml generator
login() if ($login < 1);
$req = GET ($nt);
request();
$nt = $res->content;
unless($nt=~/\S/){
$node = "<a href='$pmurl?node_id=$node'$trgt>$node</a>";
return $node;
}
$nt = fixxml($nt);
my$data = eval{ XMLin($nt, forcearray => 1)};
if(defined @{$data->{'NODE'}}){
for $nt (@{$data->{'NODE'}}){
$node = $nt->{'content'}
}
}
$node = "<a href='$pmurl?node_id=$id'$trgt>$node</a>";
return $node;
}
sub google
{ # [google://] and [lucky://]
my$google = 'http://www.google.com/search?q=';
my$luck = '&btnI=lucky';
my($fu,$g,$n) = shift;
if($fu eq 'G'){ undef($luck) }
$n = escape($_[0]);
if(@_ == 2){
$g = qq~<a href="$google$n$luck"$trgt>$_[1]</a>~;
}
if(@_ == 1){
$g = qq~<a href="$google$n$luck"$trgt>$_[0]</a>~;
}
return $g;
}
sub node_id
{ # [node_id]
my$node = shift;
$node = "<a href='$pmurl?node=$node'$trgt>$node</a>";
return $node;
}
sub nodetitle1
{ # [node title]
my$node = shift;
my$name = $node;
$node = escape($node);
$node = "<a href='$pmurl?node=$node'$trgt>$name</a>";
return $node;
}
sub nodetitle2
{ # [node title|link text]
my($node,$text) = @_;
$node = escape($node);
$node = "<a href='$pmurl?node=$node'$trgt>$text</a>";
return $node;
}
sub codefix
{ # prepare content inside code tags
my$code = shift;
encode_entities($code);
$code =~ s/\[/[/g;
$code =~ s/\]/]/g;
$code = "<ccc>$code<\/ccc>"; # ccc gets changed back to code after sca
+n for unbalanced tags
return $code;
}
sub inbox
{ # display the message inbox
my$xs = pop; # returns any excess of 255 chr limit
my($msgxml,$data);
if(!$cookie{'logout'}){
login();
$req = GET ($mesgxml);
request();
$msgxml = $res->content;
$msgxml = fixxml($msgxml);
$data = eval{ XMLin($msgxml, keyattr => 'message', forcearray => 1
+)};
$@ && xml_parse_failure('30','n=inbox','Inbox',"Load the <a href='
+$uri?n=url'>launchpad</a> or <a href='$uri?n=nn'>new nodes</a>?<p>$@"
+);
}
$pmurl = $uri; # so links can change between login and logout without
+a refresh
my$prnt = open_html('inbox','',$bodytag);
$prnt .= qq~<table border="0" cellpadding="0" cellspacing="0" width="1
+00%"><tr><td>
<FORM METHOD="POST">
<INPUT type=hidden name="op" value="message">
<INPUT TYPE="hidden" NAME="node_id" VALUE="37150">
<INPUT TYPE="text" NAME="replytotext" SIZE="60" value="$xs">
<INPUT TYPE="hidden" NAME="sexisgood" VALUE="submit">
<INPUT TYPE="submit" VALUE="talk"></td>
<td align="right"><font size="-1"><a href="$uri?n=inbox" target="_blan
+k">float</a></font></td></tr>
<tr><td colspan="2">
<table border="1" cellpadding="0" cellspacing="0"><tr><td>
<font size="-1">reply to nobody <INPUT TYPE="radio" name="replyto" val
+ue=""></font></td>
<td>$nb$nb <font size="-1">cc to self <INPUT TYPE="checkbox" name="cc"
+ value="self"></font></td>
<td>$nb$nb$nb$nb <font size="-1"><a href="$uri?n=msgchat" target="_bla
+nk">private chat</a></font></td>
<td>$nb$nb$nb$nb <a href="$uri?n=url" target="_self"><font size="-1">l
+aunchpad</font></a></td>
<td>$nb$nb$nb$nb <a href="$uri?n=nn" target="_self"><font size="-1">ne
+w nodes</font></a></td>
</tr></table></td></tr></table><p>~;
if($cookie{'logout'}){
$prnt .= qq~<p><font size="-1"><i>Logout enabled...</i></font> $eh
+~;
print $prnt;
exit
}
if(defined @{$data->{'message'}}){
my($cm,$cma,$ca,$cn) = (0) x 4;
if($reverse_inbox eq 'yes'){@{$data->{'message'}} = reverse(@{$dat
+a->{'message'}})} # reverse order
for my $msg(@{$data->{'message'}}){
if($msg->{'status'} eq 'active'){$cm++; $cn++}
if($msg->{'status'} eq 'archived'){$ca++}
}
if($cm > 0){ $prnt .= qq~<font size="-2">archive - del - reply</fo
+nt><br> $font_open~}
for my $msg(@{$data->{'message'}}){
if($msg->{'status'} eq 'active'){ # active messages
my$content = makelinks($msg->{'content'});
$content = encode($content); # UTF8 to latin1
$msg->{'time'} =~ m/^(....)(..)(..)(..)(..)(..)$/;
$prnt .= qq~$cm.
<input type="checkbox" name="archive_$msg->{'message_id'}"
+ VALUE="yup">
<input type="checkbox" name="deletemsg_$msg->{'message_id'
+}" value="yup">
<input type="radio" name="replyto" value="$msg->{'message_
+id'}">
$2/$3 at $4:$5:$6
<i><a href="$pmurl?node_id=$msg->{'user_id'}"$mnt>$msg->{'
+author'}</a> says</i> $content<br>~;
$cm--
}
}
if($cn < 1){ $prnt .= '<p><i>no private messages...</i>'}
if($ca > 0){ # archived messages
$prnt .= qq~<hr>
<font size="-2"> active - del - reply</font><br> $font_op
+en~;
for my $msg(@{$data->{'message'}}){
if($msg->{'status'} eq 'archived'){
$cma++;
my$content = makelinks($msg->{'content'});
$content = encode($content); # UTF8 to latin1
$msg->{'time'} =~ m/^(....)(..)(..)(..)(..)(..)$/;
$prnt .= qq~$cma.
<input type="checkbox" name="unarchive_$msg->{'message
+_id'}" VALUE="yup">
<input type="checkbox" name="deletemsg_$msg->{'message
+_id'}" value="yup">
<input type="radio" name="replyto" value="$msg->{'mess
+age_id'}">
$2/$3 at $4:$5:$6
<i><a href="$pmurl?node_id=$msg->{'user_id'}"$mnt>$msg
+->{'author'}</a> says</i> $content<br>~;
}
}
}
}
$prnt .= '</FORM>';
$prnt .= '<p><i>no private messages...</i>' unless defined $data->{'me
+ssage'}->[0];
$prnt .= $eh;
print $prnt;
exit
}
sub xp
{ # display the xp node
noxp() if $cookie{'logout'};
login();
$req = GET ($xpxml);
request();
my$xpnode = $res->content;
$xpnode = fixxml($xpnode);
my$data = eval{ XMLin($xpnode, keyattr => 'XP', forcearray => 1)};
$@ && xml_parse_failure($refresh_xp,'n=xp','XP',"<p>$@");
my@level = qw(anonymous initiate novice acolyte scribe monk friar abbo
+t bishop pontiff saint);
my$prnt;
if(defined @{$data->{'XP'}}){
my($s,$ss,$xps,$changed) = ('s') x 4;
for my $xpinfo(@{$data->{'XP'}}){
$s = '' if ($xpinfo->{'votesleft'}==1);
$ss = '' if ($xpinfo->{'xp2nextlevel'}==1);
my$nxtlvl = ($xpinfo->{'level'}+1);
# XP progress bar by OeufMayo
my@levelXP = qw(0 0 20 50 100 200 500 1000 1600 2300 3000);
my$percentXP = int( (($xpinfo->{'xp'} - $levelXP[$xpinfo->{'le
+vel'}]) /
($xpinfo->{'xp'} - $levelXP[$xpinfo->{'le
+vel'}] + $xpinfo->{'xp2nextlevel'})) *100);
my@XPcolors = qw(4A2625 71131C 9A0213 BD0606 FF0000 9E3B00 1D8
+700 41AF00 12E800 00FF00);
my$rest = abs(100-$percentXP);
# cool eh?
my$meta = qq~<meta http-equiv="refresh" content="$refresh_xp;
+url=$uri?n=xp&xp=$xpinfo->{'xp'}">~;
$prnt = open_html('xp',$meta,$bodytag);
$prnt .= qq~<table border="0" height="100%" width="100%" cellp
+adding="0" cellspacing="0" align="center">
<tr><td><font size="-1">$xpinfo->{'xp'} experience points.<p><
+/font>~;
if($cookie{'xp'} && !$i{'xp'}){ $i{'xp'} = $cookie{'xp'} }
if($i{'xp'} && ($i{'xp'} != $xpinfo->{'xp'})){
$prnt .= qq~<p align="center"><font size="2"><b>~;
if($xpinfo->{'xp'} > $i{'xp'}){
$xps = ($xpinfo->{'xp'} - $i{'xp'});
$prnt .= qq~You gained~;
$changed = 1
}
if($xpinfo->{'xp'} < $i{'xp'}){
$xps = ($i{'xp'} - $xpinfo->{'xp'});
$prnt .= qq~<b>Ack! Lost~;
$changed = 1
}
$prnt .= qq~ $xps XP!</b></font></p>~
}
$prnt .= qq~<font size="-2">You are a $level[$xpinfo->{'level'
+}] ($xpinfo->{'level'})~;
$prnt .= '!' if $nxtlvl == 11; # ybiC caught the saint bug add
+ressed here
if($nxtlvl < 11){
$prnt .= qq~ with <br>
$xpinfo->{'xp2nextlevel'} point$ss until level $nxtlvl.<br
+></font>
<!-- XP progress bar -->
<table border="0" width="100%" cellpadding="0" cellspacing
+="0" align="center" height="5">
<tr><td><table border="0" cellpadding="0" cellspacing="0"
+width="100%" height="5">
<tr><td bgcolor="#$XPcolors[int($percentXP/10)-1]" width="
+$percentXP%"><font size="-7">$nb</td>
<td width="$rest%" bgcolor="#CCCCCC"><font size="-7">$nb</
+td></tr></table></td></tr></table>~;
}
$prnt .= '<p>' unless $changed eq '1';
$prnt .= qq~<table width="100%" border="0"><tr><td align="righ
+t"><font size="-1">
<a href="$uri?n=xp&xp=$xpinfo->{'xp'}">$xpinfo->{'votesleft'}
+vote$s left today.</a></font>
</td></tr></table></td></tr></table>~;
}
$prnt .= $eh;
print $prnt;
}
exit
}
sub noxp
{
my$meta = qq~<meta http-equiv="refresh" content="15; url=$uri?n=xp">~;
my$prnt = open_html('noxp',$meta,$bodytag);
$prnt .= qq~$bq <p align="center"><br><font size="-1"><a href="$uri?n=
+xp">Logout enabled</a>~;
print $prnt;
exit
}
sub buffer
{ # save new lines to the history file
my%seen = ();
my@save = ();
my@current = @_;
unless(-e $today){
open(X,"> $today") or die "$!";
close X or die "$!";
}
my@buffy = io('read',$today);
foreach my $buff (@buffy){
chomp $buff;
my($btime,$buser,$bauth,$bcont) = split /\t/, $buff, 4;
$seen{$btime}=1
}
foreach my $curr (@current){
chomp $curr;
my($ctime,$cuser,$cauth,$ccont) = split /\t/, $curr, 4;
unless($seen{$ctime}){
push @save, $curr;
}
}
push (@buffy, @save);
open(LOG,"> $today") or die "$!";
for(@buffy){ print LOG $_."\n" }
close LOG or die "$!";
}
sub checkmsg
{ # count private messages
login();
$req = GET ($mesgxml);
request();
my$msgxml = $res->content;
unless($msgxml=~/\S/){ return }
$msgxml = fixxml($msgxml);
my$data = eval{ XMLin($msgxml, forcearray => 1)};
if(defined @{$data->{'message'}}){
for my $msg (@{$data->{'message'}}){
$msgcount++;
$msg_act++ if $msg->{'status'} eq 'active';
$msg_arc++ if $msg->{'status'} eq 'archived';
}
}
}
sub xml_parse_failure
{
my($rate,$param,$desc,$extra) = @_;
my$meta = qq~<meta http-equiv="refresh" content="$rate"; url="$uri?$pa
+ram">~;
my$prnt = open_html('oops',$meta,'');
$prnt .= qq~$desc download failed, <a href='$uri?$param'>try again?</a
+><br> $extra $eh~;
print $prnt;
exit
}
sub chatter
{ # display chatterbox
if($cookie{'logout'}){ login() } else { checkmsg() }
$req = GET ($chatxml);
request();
my$chatter = $res->content;
$chatter = fixxml($chatter);
my$data = eval{ XMLin($chatter, keyattr => 'message', forcearray => 1)
+ };
$@ && xml_parse_failure($refresh_chat,'n=chat','Chat',"<p>$@");
my$meta = qq~<meta http-equiv="refresh" content="$refresh_chat; url=$u
+ri?n=chat"> $tablestyle~;
my$prnt = open_html('chatter',$meta,$bodytag);
my$s = 's';
my@buffer;
$prnt .= qq~<table border="0" width="100%" cellpadding="0" cellspacing
+="0">
<tr><td><font size="-1">$loc ($gmt)</td><td>~;
if($msg_act > 0){ # private message line in chat frame
$s = '' if $msg_act == 1;
$prnt .= qq~<font size="-1"><i>You have <font size="+1"><b>$msg_ac
+t</b></font> private message$s...</i></font>~;
}
if($cookie{'logout'}){
$prnt .= qq~<font size="-1"><i>Logout enabled...</i></font>~;
}
$prnt .= qq~$nb </td><td align="right"><font size="-1"><a href="$uri?n
+=chat">refresh</a></td></tr></table><p>~;
if(defined @{$data->{'message'}}){
$prnt .= $font_open;
for my $message(@{$data->{'message'}}){
if($history eq 'on'){
$message->{'content'} =~ s/[\r\n\t]//g; # the xml ticker i
+s playing tricks on me
my$line = $message->{'time'}."\t".$message->{'user_id'}."\
+t".$message->{'author'}."\t".$message->{'content'};
push @buffer, $line;
}
my$content = makelinks($message->{'content'});
$content = encode($content); # UTF8 to latin1
my$author = $message->{'author'};
$author = encode($author); # UTF8 to latin1
$author = "<b>$author</b>" if $message->{'author'} eq $usernam
+e; # make own name bold
unless(exists $cookie{$author}){
if($content =~ m|^(/me\s)|){ # /me lines
$content =~ s/$1//;
$prnt .= qq~<i>
<a href="$pmurl?node_id=$message->{'user_id'}"$mnt>$au
+thor</a> $content</i><br>\n~;
}
else{ # non /me lines
$prnt .= qq~<<a href="$pmurl?node_id=$message->{'us
+er_id'}"$mnt>$author</a>> $content<br>\n~;
}
}
}
buffer(@buffer) if $history eq 'on';
}
my@chance = map {$_} (1..$nr);
shuffle(\@reaper);
shuffle(\@chance);
if($chance[0] == 1){
$prnt .= $reaper[0]; # reaper may speak when chat not empty
} else {
$prnt .= '<i>and all is quiet...</i>' unless defined $data->{'mess
+age'}->[0];
}
$prnt .= $eh;
print $prnt;
exit
}
sub search_history
{
history() if $i{'n'} eq 'search history' && $i{'find'} !~ /\w+/;
opendir DIR, "$temp" or die "$!";
local (@ARGV) = ();
while(defined ($_ = readdir(DIR))){
next unless $_ =~ /^_?\d{8}\.txt$/;
push @ARGV, $_;
}
closedir DIR;
@ARGV = sort {$a cmp $b} @ARGV;
my$prnt = open_html('history','',$bodytag);
$prnt .= qq~$font_open~;
my($found,$s) = ('0','s');
my($z,%fixed,%count) = 0;
if($i{'n'} && $i{'n'} eq 'count history'){
while(<>){
if(/^\d{14}\t[^\t]+\t([^\t]+)\t.*$/){
my$monk = $1;
$count{$monk}++;
$z++
}
}
if($z > 0){
$prnt .= qq~Lines per user, derived from <a href="$uri?n=tidy"
+>history</a>.<p>~;
for(sort {$count{$b} <=> $count{$a}} keys %count){
my$u = encode($_);
my$v = uri_escape($u);
$prnt .= qq~$count{$_} - <a href="$uri?n=search+history&fi
+nd=$v&histbyauth=aye">$u</a><br>~
}
print $prnt;
exit
}
}
while(<>){
if( ($i{'histbyauth'}) ? /\t\Q$i{'find'}\E\t/io : /\Q$i{'find'}\E/
+io ){
$found++;
last if $found == $search_max;
my$c = 0;
(my$fu = $_) =~ s/^(....)(..)(..)(..)(..)(..)\t([^\t]+)\t([^\t
+]+)\t(.*)$/search_result($2,$3,$4,$5,$6,$7,$8,$9)/e;
# yr mo dy hr mm ss id user
+ text
$fu = makelinks($fu) if $ARGV =~ /^_/;
$fu = encode($fu); # UTF8 to latin1
# WARNING: The next five lines suck but always work for links
+constructed by makelinks()
# and proper user-supplied links, but are otherwise f
+ragile.
$c = $fu =~ s/(\Q$i{'find'}\E)/<b>$1<\/b>/ig; # bold search te
+rm(s) and count matches
if($c > 0){
while($c > 0){ # for each match
$fu =~ s|(<a\s*[^>]+)<b>(\Q$i{'find'}\E)</b>([^>]+>)|$
+1$2$3|ig; # unbold if term found in url (in <a> tag)
$c--
}
} # end of cruft
my($fix,$ed) = split /\|/, $fu, 2;
$fixed{$found} = qq~<li><a href="$uri?filename=$ARGV&n=view+hi
+story&find=$i{'find'}">$fix</a>: $ed~;
}
}
$s = '' if $found == 1;
$prnt .= qq~Found <i>$found</i> occurance$s of <b>$i{'find'}</b>.<br>~
+;
$prnt .= qq~<font size="-1">select the date to view that history file
+with keyword in bold font</font><br><p>~ if $found > 0;
$prnt .= $fixed{$_} for sort {$a <=> $b} keys %fixed;
$prnt .= qq~$bq $pbr Not found, <a href="$uri?n=tidy">try again</a>.~
+unless $found > 0;
print $prnt;
}
sub search_result
{ # print result of a history search
my$fix = qq~$_[0]/$_[1] at $_[2]:$_[3]:$_[4] ~;
my($id,$name,$ed) = ($_[5],$_[6],$_[7]);
if($ed =~ s|^(/me\s)||){ # /me lines
$ed = qq~<i><a href="$uri?node_id=$id"$mnt>$name</a> $ed</i>~;
}
else{ # non /me lines
$ed = qq~<<a href="$uri?node_id=$id"$mnt>$name</a>> $ed~;
}
$fix = $fix.'|'.$ed;
return $fix;
}
sub history
{ # display current history file
my$bit = pop; # viewing past history if defined
$today = $bit if $bit;
my$form = qq~<form><input type="submit" value="view/search/delete">
<input type="hidden" name="n" value="tidy"></form>~;
my$prnt = open_html('history','',$bodytag);
$prnt .= qq~<p>$font_open $form~;
if(-e $today){
my@history = io('read',$today);
$prnt .= qq~<p align="right"><a href="#eof">eof</a> -
<a href="$uri?n=hist">refresh</a></p>~ unless $bit;
$prnt .= qq~Viewing history file <tt>$today</tt><p>~ if $bit;
for(@history){
my($htime,$huser,$hauth,$hcont) = split /\t/, $_, 4;
$htime =~ m/^(....)(..)(..)(..)(..)(..)$/;
my$ts = "<font size='-1'>$2/$3 at $4:$5:$6</font>";
$hauth = "<b>$hauth</b>" if $hauth =~ /$username/; # make own
+name bold
(my$toady = $today) =~ s/$temp//;
$hcont = makelinks($hcont) if $toady =~ /^_/; # parse v1.3 sty
+le history files
$hcont = encode($hcont); # UTF8 to latin1
$hauth = encode($hauth); # UTF8 to latin1
if($hcont =~ m|^(/me\s)|){ # /me lines
$hcont =~ s/$1//;
$prnt .= qq~$ts <i><a href="$uri?node_id=$huser"$mnt>$haut
+h</a> $hcont</i><br>\n~;
}
else{ # non /me lines
$prnt .= qq~$ts <<a href="$uri?node_id=$huser"$mnt>$hau
+th</a>> $hcont<br>\n~;
}
}
$prnt .= $form;
$prnt .= qq~<p align="right"><a href="$uri?n=hist" name="eof">refr
+esh</a>~ unless $bit;
}
if(!-e $today){
$prnt .= qq~No history for today, press the button.~
}
$prnt .= $eh;
print $prnt;
}
sub tidy
{ # list, view and delete history files
my$state = pop;
if($state){
if($state eq 'oops'){
my$prnt = open_html('oops!','',$bodytag);
$prnt .= qq~$bq Please select a file!
<form><input type="submit" value="ok">
<input type="hidden" name="n" value="tidy"></form> $eh~;
print $prnt;
exit
}
if($state eq 'done'){
my$prnt = open_html("$temp$i{'delete'} deleted",'',$bodytag);
$prnt .= qq~$bq $temp$i{'delete'} deleted!
<form><input type="submit" value="ok">
<input type="hidden" name="n" value="tidy"></form> $eh~;
print $prnt;
exit
}
if($state eq 'view'){
if($i{'filename'} =~ /\S/){
history($temp.$i{'filename'});
exit
} else { tidy('oops') }
}
if($state eq 'delete'){
if($i{'delete'} && $i{'delete'} =~ /\S/){
if($i{'delete'} =~ /^([-\@\w.]+)$/){ $i{'delete'} = $1 } #
+ untaint that filename
unlink($temp.$i{'delete'}) or die "Can't unlink $temp$i{'d
+elete'}: $!";
tidy('done');
}
if($i{'filename'} =~ /\S/){
my$prnt = open_html("delete $temp$i{'filename'}",'',$bodyt
+ag);
$prnt .= qq~$bq Delete $temp$i{'filename'}?
<form><input type="submit" value="yes">
<input type="hidden" name="delete" value="$i{'filename'}">
<input type="hidden" name="n" value="delete"></form> $eh~;
print $prnt;
exit
}
else { tidy('oops') }
}
}
my%dir;
opendir DIR, "$temp" or die "Can't readdir $temp: $!";
while(defined ($_ = readdir(DIR))){
next if /^\.\.?$/;
next if -d $_;
if(m|^.?\d{8}\.txt$|){
my$fs = -s $_;
$dir{$_} = $fs;
}
}
closedir DIR;
my$size = %dir;
$size = sprintf "%d", ($size/3); # size of select menu
my$prnt = open_html('view/search/delete history','',$bodytag);
$prnt .= qq~<table border="0" cellpadding="3" cellspacing="0" width="1
+00%">
<tr><td colspan="3" height="50" align="right"><a href="$uri?n=tools">t
+ools</a></td></tr>
<tr><form><td rowspan="2" width="10"> </td>
<td><small><b>Directory: $temp</b></small><p>
<select name="filename" size="$size">~;
for(sort {$b cmp $a} keys %dir){
$prnt .= qq~<option value="$_">$_ - $dir{$_}~
}
$prnt .= qq~</select></td><td>
<input type="submit" name="n" value="view history">
<font size="-1">select one from the list</font> $pbr
<input type="submit" name="n" value="delete history">
<font size="-1">after confirming your selection of course</font> $pbr
<input type="submit" name="n" value="search history">
<input type="text" name="find" size="22">
<input type="checkbox" name="histbyauth" value="aye">author<br>
<font size="-1">searches all history files for word or phrase</font> $
+pbr
<input type="submit" name="n" value="count history">
<font size="-1">reveals the most prolific chatters</font>
</td></form></tr><tr><td>$nb </td><td> $pbr
<font size="-1">Since v1.3 framechat saves history before link parsing
+, instead of after.
This makes viewing history a bit slower with the benefit of always vie
+wing content with
the latest parsing code. The _ prefix denotes files saved with the new
+ method, both can be read.<br></font></td></tr></table> $eh~;
print $prnt;
}
sub entities_menu
{ # print entity menu for input frame
my$prnt = qq~<select name="ent">
<option value="1">chr - entity$nb$nb~;
my$sel = '';
for(224..255,192..223,160..191,91,93){ # chrs and their display order
my$c = pack "c", $_;
if($i{'ent'}){ $sel = ' selected' if $_ == $i{'ent'} }
$prnt .= qq~<option value="$_"$sel>$c - &#$_;\n~;
}
$prnt .= '</select>';
return $prnt
}
sub talk
{ # display the input textarea
my$extra = pop;
if($extra){
if($extra eq 'usr'){ # insert from userlist
$extra = qq~/msg $i{'u'} ~ if $i{'m'} eq 'msg';
$extra = qq~[$i{'u'}] ~ if $i{'m'} eq 'link';
$extra = qq~/ignore $i{'u'}~ if $i{'m'} eq 'ignore';
$extra = qq~/unignore $i{'u'}~ if $i{'m'} eq 'unignore';
}
$i{'message'} = '' unless $i{'message'};
if($extra eq 'tag'){ # insert cb tag
my$c = 1;
for(@tags){
if($i{'tag'} && $i{'tag'} == $c){
$i{'message'} =~ s/&/&/g; # preserve existing enti
+ties
if($_ =~ /^\/me |^\/msg |^\/u?n?ignore /){
$extra = $_.$i{'message'}
}
elsif($_ =~ /\/log(?:in|out)/){ $extra = $_ }
else{ $extra = $i{'message'}.$_ }
last
}
$c++
}
}
if($extra eq 'ent'){ # insert entities
$i{'message'} =~ s/&/&/g;
if($i{'ent'} && $i{'ent'} == 1){
$extra = $i{'message'};
}
elsif($i{'ent'} && $i{'ent'} != 1){
$extra = $i{'message'}.'&#'.$i{'ent'}.';'; # build and
+ append entity
}
else{ $extra = '' }
}
if($extra eq 'enc'){ # insert entities
$extra = encode_entities($i{'message'});
$extra =~ s/&/&/g;
}
}
my$prnt = qq~<html> $bodytag
<table align="center" border="0" cellpadding="0" cellspacing="0"><tr>
<FORM method="post"><td>
<INPUT type=hidden name="op" value="message">
<INPUT TYPE="hidden" NAME="node_id" VALUE="37150">
<INPUT TYPE="hidden" NAME="mode" VALUE="talk">
<textarea name="message" wrap="virtual" cols="50" rows="4">$extra<\/te
+xtarea>$nb </td>
<td><table align="center" border="0" cellpadding="0" cellspacing="3">
<tr><td>
<INPUT TYPE="submit" NAME="message_send" VALUE="talk"></td><td align="
+right">
$nb <font size="-1"><a href="$uri?n=repinit" target="chat">rep</a>
$nb <INPUT TYPE="submit" NAME="n" VALUE="encode">
<input type="reset" value="clear"></font>
</td></tr>
<tr><td>
<INPUT TYPE="submit" NAME="n" VALUE="tag"></td><td>$nb<select name="ta
+g">~;
my$c = 1;
for(@tags){ # cb tag menu
my$sel = '';
$_ =~ s/</</; # fixes the code tag (so i can post the code to p
+erlmonks :-)
encode_entities($_);
if($i{'tag'}){
$sel = ' selected' if $c == $i{'tag'};
}
$prnt .= qq~<option value="$c"$sel>$_\n~;
$c++
}
$prnt .= qq~</select>$nb <br></td></tr>
<tr><td><INPUT TYPE="submit" NAME="n" VALUE="ent"></td><td>$nb~;
$prnt .= entities_menu();
$prnt .= qq~</td></tr></table></td></FORM></tr></table> $eh~;
print $prnt;
exit
}
sub fix_username
{ # encode < and & in usernames
# if vroom fixes the userlist xml this will break :-(
my$fix = pop;
$fix =~ s/\x26/&/g;
$fix =~ s/\x3C/</g;
$fix = qq~<user username="$fix" ~;
return $fix;
}
sub users
{ # display the userlist
my$bit = pop; # if defined we're in msgchat mode
my($horde,$monks) = 0; # declare both and init horde
shuffle(\@verb);
if($use_proxy eq 'on'){
login();
$req = GET ($userxml);
request();
$monks = $res->content;
}
else{$monks = get $userxml}
$monks =~ s/<user username="(.*?)" /fix_username($1)/eg; # ugh, fix us
+ernames that contain < or &
$monks = fixxml($monks);
my$data = eval{ XMLin($monks, keyattr => 'user', forcearray => 1)};
$@ && xml_parse_failure($refresh_user,'n=users','Userlist',"<p>$@");
my$prnt = '<html><head>';
$prnt .= qq~<meta http-equiv="refresh" content="$refresh_user; url=$ur
+i?n=users">~ unless $bit;
$prnt .= qq~<title>msgchat</title>~ if $bit;
$prnt .= qq~</head> $bodytag $font_open~;
unless($bit && $cookie{'logout'}){
if(defined @{$data->{'user'}}){
for my $users(@{$data->{'user'}}){ $horde++ } # count users
$bit ? $prnt .= qq~<form target="_top">~ : $prnt .= qq~<form targe
+t="talk">~;
$prnt .= qq~<font size="-1">~;
$prnt .= qq~<a href="$uri?n=users">$horde</a>~ unless $bit;
$prnt .= qq~$horde~ if $bit;
$prnt .= qq~ others $verb[0] around the monastery:</font>~;
$prnt .= qq~<br><font size="-1">Who would you like to privately ch
+at with?</font>
<p><input type="submit" value="chat">~ if $bit;
$prnt .= qq~<p><font size="-1"><select name="m">
<option value="link">[user]
<option value="msg">/msg
<option value="ignore">/ignore
<option value="unignore">/unignore</select>
<input type="submit" value="go"></font>~ unless $bit;
$prnt .= qq~$font_open~ if $font_open && !$bit;
$prnt .= '<p>';
for my $users(@{$data->{'user'}}){
my$name = $users->{'username'};
my$u = encode_entities(escape($name));
my$v = $u;
$v =~ s/%20/_/g; # perlmonks wants underscore for space in use
+rnames
for(@friends){ # bold usernames
$name = "<b>$name</b>" if $_ eq $name;
}
$prnt .= '<nobr>';
$prnt .= qq~<input type="radio" name="privuser" value="$users-
+>{'username'}">~ if $bit;
$prnt .= qq~<input type="radio" name="u" value="$users->{'user
+name'}">~ if !$bit;
$name = qq~<strike>$name</strike>~ if exists $cookie{$users->{
+'username'}};
$prnt .= qq~$nb
<a href="$pmurl?node_id=$users->{'user_id'}"$mnt>$name</a></no
+br><br>\n~;
}
}
}
$prnt .= qq~<font size="-1">Logout enabled...</font> $bq
$pbr Private chat disabled.~ if $bit && $cookie{'logout'};
$prnt .= qq~<input type="hidden" name="n" value="privchat"></form>
<form target="_top"><input type="hidden" name="n" value="privchat">
<input type="text" name="privuser" size="12"> <input type="submit" val
+ue="chat">
<font size="-1">with someone not currently online</font>~ if $bit && !
+$cookie{'logout'};
$prnt .= qq~<input type="hidden" name="n" value="usr"></form> $eh~;
print $prnt;
exit
}
sub shuffle
{ # Perl Cookbook recipe 4.17
my$array = shift;
for(my$i = @$array; --$i;){
my$j = int rand ($i+1);
next if $i == $j;
@$array[$i,$j] = @$array[$j,$i]
}
}
sub norm
{ # get perlmonks html, parse norm and save to file.
my$normal;
if($use_proxy eq 'on'){
login();
$normal = $normhtml;
$req = GET ($normal);
request();
$normal = $res->content;
}
else{ $normal = get $normhtml }
unless($normal=~/\S/){
print redirect(-uri=>"$uri?n=ctrl")
}
$norm = $1 if $normal =~ m|The current value of <TT>(?:<font[^>]+>)?\$
+NORM(?:</font>)?</TT> is (\d+\.\d+)</TD></TR>|i;
io('write',$normfile,$norm);
print redirect(-uri=>"$uri?n=ctrl");
}
sub ctrl
{ # display links and $NORM
if(-e $normfile){ $norm = io('read',$normfile,$norm)} else {$norm = 'n
+/a'}
$norm = 'n/a' unless $norm =~ /\S/;
my$prnt = qq~<html> $bodytag
<table border="0" height="100%" width="100%" cellpadding="0" cellspaci
+ng="0" align="center">
<tr><td><font size="-1">
<li><nobr><a href="$new"$nodes>new</a> -
<a href="$uri?node=best+nodes"$nodes>best</a> -
<a href="$uri?node=worst+nodes"$nodes>worst</a> -
<a href="$uri?node=nodes+to+consider"$nodes><b>©</b></a></nobr>
<li><nobr><a href="$uri?node=$username"$nodes>home</a> -
<a href="$uri?n=sds" target="search">search</a> -
<a href="$uri?n=help" target="help">help</a></nobr><li><nobr>~;
$prnt .= qq~<a href="$uri?n=hist#eof" target="history">history</a>&nbs
+p;- ~ if $history eq 'on';
$prnt .= qq~<a href="$uri?n=tools"$nodes">tools</a> -
<a href="$uri?the=end" target="_top">exit</a></font></td></tr>
<tr><td valign="bottom" align="right">
<p><font size="-1"><a href="$uri?n=norm">\$NORM = $norm</a></font><br>
</td></tr></table> $eh~;
print $prnt;
exit
}
sub search
{ # display perlmonks super search, perldoc, cpan, google and babelfis
+h forms
my$prnt = open_html('search','','');
$prnt .= qq~<body bgcolor="#000044">
<table border="0" cellpadding="0" cellspacing="0" align="center"><tr><
+form>
<td align=left valign=middle colspan=2 bgcolor="#000066" height="32">
<font size="+1" color="#ffffff"><font size="+2">Perl Monks </font>
<sub><b><i>Super Search</i></b></sub></font></td></form></tr>
<tr>
<FORM METHOD="POST" ACTION="$pmurl" target="searchresults">
<td align=left valign=middle bgcolor="#ffffff">
<INPUT TYPE="hidden" NAME="node_id" VALUE="3989">
$pbr <TABLE border="0" cellpadding="0" cellspacing="0" bgcolor="#fffff
+f">
<TR><TD><INPUT TYPE="text" NAME="wordsintitle" size="27"></TD>
<TD><font size="-1" color="#000000"><b>Title</b></font></TD></TR>
<TR><TD><INPUT TYPE="text" NAME="author" size="27"></TD>
<TD><font size="-1" color="#000000"><b>Author</b></font></TD></TR>
<TR><TD><INPUT TYPE="text" NAME="wordsintext" size="27"></TD>
<TD><font size="-1" color="#000000"> <b>Text</b></font></TD></TR></TAB
+LE>
</td><td bgcolor="#f0f0f0" align="center">
<INPUT TYPE="submit" NAME="sexisgood" VALUE="Super Search">
</td></tr>
<tr><td align=left valign=middle colspan=2 bgcolor="#ffffff">
<font color="black" size=-1>
<b>Search tips:</b> Word search is case insensitive. You can "quo
+te phrases". <br>
Search results are currently limited to 100. Use as many constraints a
+s you can when <br>
making a search, it'll be easier on the database and you'll get higher
+ quality results back.<br></font>
</td></tr>
<tr><td align=left valign=middle colspan=2 bgcolor="#ffffff">
$pbr <INPUT TYPE="checkbox" NAME="constraindates" VALUE="on">
<font color="#000000">Constrain dates between</font> <SELECT NAME="sta
+rt_month">
<OPTION VALUE="01">Jan<OPTION VALUE="02">Feb<OPTION VALUE="03">Mar<OPT
+ION VALUE="04">Apr
<OPTION VALUE="05">May<OPTION VALUE="06">Jun<OPTION VALUE="07">Jul<OPT
+ION VALUE="08">Aug
<OPTION SELECTED VALUE="09">Sep<OPTION VALUE="10">Oct<OPTION VALUE="11
+">Nov<OPTION VALUE="12">Dec</SELECT>
<SELECT NAME="start_day">
<OPTION SELECTED VALUE="01">01<OPTION VALUE="02">02
<OPTION VALUE="03">03<OPTION VALUE="04">04<OPTION VALUE="05">05<OPTION
+ VALUE="06">06
<OPTION VALUE="07">07<OPTION VALUE="08">08<OPTION VALUE="09">09<OPTION
+ VALUE="10">10
<OPTION VALUE="11">11<OPTION VALUE="12">12<OPTION VALUE="13">13<OPTION
+ VALUE="14">14
<OPTION VALUE="15">15<OPTION VALUE="16">16<OPTION VALUE="17">17<OPTION
+ VALUE="18">18
<OPTION VALUE="19">19<OPTION VALUE="20">20<OPTION VALUE="21">21<OPTION
+ VALUE="22">22
<OPTION VALUE="23">23<OPTION VALUE="24">24<OPTION VALUE="25">25<OPTION
+ VALUE="26">26
<OPTION VALUE="27">27<OPTION VALUE="28">28<OPTION VALUE="29">29<OPTION
+ VALUE="30">30
<OPTION VALUE="31">31</SELECT>
<SELECT NAME="start_year">
<OPTION SELECTED VALUE="1999">1999<OPTION VALUE="2000">2000<OPTION V
+ALUE="2001">2001<OPTION VALUE="2002">2002
<OPTION VALUE="2003">2003<OPTION VALUE="2004">2004<OPTION VALUE="2005
+">2005<OPTION VALUE="2006">2006
<OPTION VALUE="2007">2007<OPTION VALUE="2008">2008<OPTION VALUE="2009
+">2009</SELECT>
<font color="#000000">and</font> <SELECT NAME="end_month">
<OPTION VALUE="01">Jan<OPTION VALUE="02">Feb<OPTION VALUE="03">Mar<OP
+TION VALUE="04">Apr
<OPTION VALUE="05">May<OPTION VALUE="06">Jun<OPTION VALUE="07">Jul<OP
+TION VALUE="08">Aug
<OPTION VALUE="09">Sep<OPTION VALUE="10">Oct<OPTION VALUE="11">Nov<OP
+TION SELECTED VALUE="12">Dec
</SELECT>
<SELECT NAME="end_day"><OPTION VALUE="01">01<OPTION VALUE="02">02<OPTI
+ON VALUE="03">03
<OPTION VALUE="04">04<OPTION VALUE="05">05<OPTION VALUE="06">06<OPTIO
+N VALUE="07">07
<OPTION VALUE="08">08<OPTION VALUE="09">09<OPTION VALUE="10">10<OPTIO
+N VALUE="11">11
<OPTION VALUE="12">12<OPTION VALUE="13">13<OPTION VALUE="14">14<OPTIO
+N VALUE="15">15
<OPTION VALUE="16">16<OPTION VALUE="17">17<OPTION VALUE="18">18<OPTIO
+N VALUE="19">19
<OPTION VALUE="20">20<OPTION VALUE="21">21<OPTION VALUE="22">22<OPTIO
+N VALUE="23">23
<OPTION VALUE="24">24<OPTION VALUE="25">25<OPTION VALUE="26">26<OPTIO
+N VALUE="27">27
<OPTION VALUE="28">28<OPTION VALUE="29">29<OPTION VALUE="30">30<OPTIO
+N VALUE="31">31</SELECT>
<SELECT NAME="end_year">
<OPTION VALUE="1999">1999<OPTION SELECTED VALUE="2000">2000
<OPTION VALUE="2001">2001<OPTION VALUE="2002">2002<OPTION VALUE="2003
+">2003<OPTION VALUE="2004">2004
<OPTION VALUE="2005">2005<OPTION VALUE="2006">2006<OPTION VALUE="2007
+">2007<OPTION VALUE="2008">2008
<OPTION VALUE="2009">2009</SELECT>
<p><TABLE border="0" cellpadding="1" cellspacing="0" width="100%" bgco
+lor="#f0f0f0">
<th colspan="5" align="left"><font color="#000000">Limit results to:</
+font></th>
<TR><TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Seekers of Pe
+rl Wisdom">
<font size=-2 color="#000000">Seekers of Perl Wisdom</TD>
<TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Meditation">
<font size=-2 color="#000000">Meditation</TD>
<TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Perl FAQ">
<font size=-2 color="#000000">Perl FAQ</TD>
<TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Cool Uses For Per
+l">
<font size=-2 color="#000000">Cool Uses For Perl</TD>
<TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Users">
<font size=-2 color="#000000">Users</TD></TR>
<TR><TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Craft">
<font size=-2 color="#000000">Craft</TD>
<TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Note">
<font size=-2 color="#000000">Note</TD>
<TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Perl Manpage">
<font size=-2 color="#000000">Perl Manpage</TD>
<TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Perl Monks Discus
+sion">
<font size=-2 color="#000000">Perl Monks Discussion</TD>
<td rowspan="3" valign="top"> </td></TR>
<TR><TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Obfuscation">
<font size=-2 color="#000000">Obfuscation</TD>
<TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Categorized Quest
+ion">
<font size=-2 color="#000000">Categorized Question</TD>
<TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Book Review">
<font size=-2 color="#000000">Book Review</TD>
<TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Perl News">
<font size=-2 color="#000000">Perl News</TD></TR>
<TR><TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Poetry">
<font size=-2 color="#000000">Poetry</TD>
<TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Categorized Answe
+r">
<font size=-2 color="#000000">Categorized Answer</TD>
<TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Module Review">
<font size=-2 color="#000000">Module Review</TD>
<TD><INPUT TYPE="checkbox" NAME="chosentypes" VALUE="Tutorials">
<font size=-2 color="#000000">Tutorials</TD></TR></TABLE>
</td></FORM></TR>
<tr><td colspan=2 bgcolor="#000066" height="10"> </td>
</tr>
<tr><td colspan=2 bgcolor="#000055">$pbr
<form method=POST action="http://www.perldoc.com/cgi-bin/htsearch" tar
+get="searchresults">
<input type="text" size="27" value="" name="words"><input type="Submit
+" value="perldoc">
</form>
<form method=get action="http://search.cpan.org/search" target="search
+results">
<INPUT TYPE="text" NAME="query" SIZE=27><input type="submit" value="cp
+an">
<SELECT NAME="mode">
<OPTION VALUE="module">Module
<OPTION VALUE="dist">Distribution
<OPTION VALUE="author">Author
<OPTION VALUE="doc">Documentation</SELECT>
</form>
<FORM method=GET action="http://www.google.com/search" target="searchr
+esults">
<INPUT TYPE=text name=q size=27 maxlength=255 value="">
<INPUT type=submit name=btnG VALUE="google"></FORM></td>
</tr>
<tr><td colspan=2 bgcolor="#000066">$pbr
<form action="http://babel.altavista.com/raging/translate.dyn?" method
+="post" target="searchresults">
<input type=hidden name=enc value=utf8>
<input type=hidden name=doit value=done>
<input type=hidden name=BabelFishFrontPage value=yes><p>
<font color="#ffffff"><font size="+1">Babelfish</font><br>
Enter URL or text to translate:
<font size="-1">(URLs must begin with http://)</font></font><br>
<textarea cols=52 name=urltext rows=5 wrap=virtual><\/textarea><p>
<font color="#ffffff">Translate From:</font><br>
<select name=lp>
<option value="en_fr" >English to French
<option value="en_de" >English to German
<option value="en_it" >English to Italian
<option value="en_pt" >English to Portuguese
<option value="en_es" >English to Spanish
<option value="fr_en" >French to English
<option value="de_en" >German to English
<option value="it_en" >Italian to English
<option value="pt_en" >Portuguese to English
<option value="ru_en" >Russian to English
<option value="es_en" >Spanish to English
<option value="fr_de" >French to German
<option value="de_fr" >German to French
<option value="en_ja" >English to Japanese
<option value="en_ko" >English to Korean
<option value="en_zh" >English to Chinese
<option value="ja_en" >Japanese to English
<option value="ko_en" >Korean to English
<option value="zh_en" >Chinese to English</select>
<input type=submit value=Translate title="Translate Now!"></form><p>
</td></tr></table> $eh~;
print $prnt;
exit
}
sub open_html
{
my($title,$meta,$html) = @_;
$_ = qq~<html><head><title>$title</title>$meta $stylesheet </head> $ht
+ml~
}
sub help
{ # display help and info
if($i{'n'} eq 'help view prev'){
my$prnt = open_html('previous changes','',$bodytag);
$prnt .= qq~$bq <p>
<a name="new"><b>New in version 1.3:</b></a><ul>
<li> Supports the <tt>[isbn://]</tt> tag
<li> Expands node titles for <tt>[id://]</tt> and <tt>[node_id]</t
+t> links like perlmonks.
<li> New links in the userlist to insert <tt>/msg username</tt> or
+ <tt>[username]</tt> in input area.
<li> New select menus to insert commonly used cb tags and html ent
+ities in input area.
<li> An encode button that encodes any entities in the input area
+without sending.
<li> Launch URLs from the inbox to easily load urls, perlmonks nod
+es, or search engine results.
<li> Improved handling of malformed html and usernames with spaces
+ and/or entities.
<li> Message chunking breaks on word boundaries now.
<li> History search engine with <b>bold</b> keyword(s) in results.
<li> New history file format, but can still view old files.
<li> Added NodeReaper quips!
<li> <b>Tighter code:</b><ul>
<li> should be no more warnings with -w
<li> better scoping (less globals)
<li> optimized link parsing regexes</ul><p>$eh~;
print $prnt;
exit
}
$credits = makelinks($credits);
my@credit = split /\n/, $credits;
$credit[0] =~ s/(.*)/<b>$1<\/b>/;
$info{'date'} =~ s/(....)(..)(..)/$2\/$3\/$1/;
my$ssize = -s $0;
my$prnt = open_html('help','',$bodytag);
$prnt .= qq~$bq
<a href="$uri?node=framechat"><b>framechat</b></a> is a Perl/CGI
<a href="$uri?node_id=40361">chatterbox</a> client modeled on the
<a href="$uri?node_id=3184&displaytype=raw">chatterbox frameset</a> at
+
<a href="$uri"target="$trgt">perlmonks</a>. To use just fill in the
configuration variables and call it from your local web server. Coded
+by
<a href="$uri?node=epoptai">epoptai</a>.
<form method="post">
<p>This is <a href="#new"><b>version $info{'version'}</b></a> released
+ $info{'date'}.
Check for an <input type="submit" name="n" value="update"></form>
<h2>operation:</h2>
<font size="+1"><b>Security</b></font>
<ul>
<li><b>framechat</b> is a specialized XML browser written in Perl. Lik
+e an HTML web browser,
it uses cookies to verify your identity. It gets this information from
+ the username and
password you filled in before using the script. A saved cookie file co
+nstructed using
that info is then used to access perlmonks. This makes it necessary to
+ secure access to the
script installation.
<p>
<b>Client login</b> has been added to make framechat more secure. Your
+ password is required to start the
script, and 'exit' erases the (crypted) password cookie and disables a
+ccess.
<p>
Despite the added security of client login, framechat is intended for
+use on a protected localhost. Other
setups may work, like an ISP account, but this isn't fully tested. The
+ most secure installations will
include measures such as .htaccess or server directives.</ul>
<p>
<font size="+1"><b>Performance</b></font>
<p>
Any given version of the code is optimized to the best of my abilities
+. This version ($info{'version'}) is
$ssize bytes. When first loading the script it loads a frameset, which
+ executes the script six more times.
During normal operation anywhere from one to five instances of the scr
+ipt may run depending how the refresh
rates sync up. If this puts a strain on your system, or if you just wa
+nt to run as fast as possible, use
<a href="$uri?node_id=87842">OeufMayo's mod_perl patch.</a>
<p>
If have any suggestions for improvements or new features please let me
+ know (/msg epoptai).
<p>
<a href="$uri?n=tools"><font size="+1"><b>Tools</b></font></a><br>
<li>Create a config file so you can easily edit script parameters. Thi
+s also eliminates the need to
edit the script when updating the code.
<p>
<a href="$uri?n=chat"><font size="+1"><b>Chat Frame</b></font></a><br>
<li>Unrecognized tags are displayed rather than stripped, and they don
+'t effect rendering.
<li>Private message notification appears at the top of the chatter fra
+me.
<li>User supplied links target the window specified in config variable
+s.
<li>High-bit ascii chrs should work now, but YMMV.
<li>Use the "rawchat" link in <a href="$uri?n=tools">tools</a> to see
+the raw html cb feed from perlmonks.
<p>
<a href="$uri?n=talk"><font size="+1"><b>Input Frame</b></font></a><br
+>
<li>The 255 character limit is about one line larger than the textarea
+.
<li>Any text above 255 bytes is returned to the textarea for resending
+.
<li>Click 'tag' or 'ent' to insert the selected entity, appended to an
+y existing text.
<li>Select 'encode' to turn any high bit chars and <, &, >,
and " in the input area into HTML entities without sending.
<p>
<a href="$uri?n=users"><font size="+1"><b>Userlist</b></font></a><br>
<li>Select the numeral to manually refresh
<li>Usernames defined in \@friends will be displayed in bold
<p>
<a href="$uri?n=inbox"><font size="+1"><b>Message Inbox</b></font></a>
+<br>
<li>New private messages are indicated in the chat frame.
<li>When notification appears or changes press 'talk' to refresh the i
+nbox.
<li>There's no feedback when replying to a private message so check sp
+elling first.
<li><i>cc to self</i> doesn't indicate who you are responding to so tr
+y to remember.
<li>Otherwise functions just like the <a href="$uri?node=message+inbox
+">regular message inbox</a><br>
<p><a href="$uri?n=msgchat"><b>private chat</b></a> opens a private ch
+at channel to a user you select.
<p><ul>
<li>Uses a frameset that functions like the regular chat and talk fram
+es.
<li>All input goes to the currently engaged user, no more /msg typos.
<li>Individual and mass save/delete message management functions inclu
+ded.
<p>Unlike the inbox, msgchat provides feedback in the chat frame by sh
+owing what you say,
and in the text input area where any text larger than 226 bytes is ret
+urned for resending.
226 is a little smaller than the maximum of 255 bytes to account for t
+he username plus 7
bytes used in the specially tagged cc to self messages.
</ul>
<p>
<a href="$uri?n=xp"><font size="+1"><b>XP Nodelet</b></font></a><br>
<li>Select 'votes left today' to manually refresh
<p>
<a href="$uri?n=ctrl"><font size="+1"><b>Link Node</b></font></a><br>
<li>Select \$NORM to update it each day<br>
<li>The <b>©</b> symbol leads to <a href="$uri?node=nodes+to+cons
+ider">
Nodes to Consider</a>.<br>
<li>The "tools" link opens a window to a control panel used to edit co
+nfig params.<br>
<p>
<a href="$uri?n=url"><font size="+1"><b>Launchpad</b></font></a><br>
<a href="$uri?n=nn"><font size="+1"><b>New Nodes</b></font></a><br>
<a href="$uri?n=repframe"><font size="+1"><b>Reputation Change</b></fo
+nt></a><br>
<a href="$uri?n=rephistview"><font size="+1"><b>Reputation History</b>
+</font></a><br>
<li>These pretty much explain themselves.
<p>
<a href="$uri?n=tidy"><font size="+1"><b>History</b></font></a>
<li>Files are saved in \$temp, currently set to <b>$temp</b>
<li>They're named with numbers reflecting the date, YearMoDy.txt (2001
+0305.txt for March 5th).
<li>New file created when the day changes according to your localtime.
<li>Your localtime and perlmonks GMT timestamps won't match unless you
+'re in GMT.
<p> $changes
<p><a href="$uri?n=help+view+prev">view previous changes</a><p>~;
my$c = 0;
for(@credit){ $c++; $prnt .= '<ul>' if ($c==2); $prnt .= '<li>'.$_ }
$prnt .= qq~</ul></ul><p><div align="center">
<FORM method="POST" ENCTYPE="application/x-www-form-urlencoded"><td>
<INPUT type=hidden name="op" value="message">
<INPUT type=hidden name="mode" value="plug">
<INPUT TYPE="hidden" NAME="node_id" VALUE="15834">
<INPUT TYPE="hidden" name="message" VALUE="/me uses [framechat]">
<INPUT TYPE="submit" NAME="message_send" VALUE="plug"> causes you to s
+ay,
"$username uses <a href="$uri?node=framechat">framechat</a>" in the ch
+atterbox</font></td>
</FORM></div></blockquote> $eh~;
print $prnt;
exit
}
sub check_update
{ # looks for <!--INFO:version=n,date=yyyymmdd--> on node 64644
# and compares it with version data from the %info hash
my$upnode = 'http://www.perlmonks.org/index.pl?node_id=64644';
my$check;
if($use_proxy eq 'on'){
login();
$req = GET ($upnode);
request();
$check = $res->content;
}
else{$check = get "$upnode"}
if($check !~ /\S/){
print qq~$pbr $bq
Download failed, <a href="$uri?n=update">try again?</a>~;
exit
}
unless($check =~ /<!--INFO:/){
print qq~$pbr $bq
Version information not detected, try again later or go
to the <a href="$uri?node=framechat">framechat homenode</a>.~;
exit
}
my@check = split /\n/, $check;
my@info = grep /<!--INFO:.*?-->/, @check;
my@note = grep /<!--NOTE:.*?-->/, @check;
$info[0] =~ s/<!--INFO:(.*?)-->/$1/;
$note[0] =~ s/<!--NOTE:(.*?)-->/$1/;
@check = split /,/, $info[0], 2;
my(%check,$pp);
for(@check){
my($k,$v) = split /=/, $_, 2;
$check{$k} = $v;
}
$pp = 'Update Available!' if ($check{'version'} > $info
+{'version'});
$pp = 'This is the current version.' if ($check{'version'} == $info
+{'version'});
$pp = 'This version newer than update?' if ($check{'version'} < $info
+{'version'});
my$prnt = open_html('updates','',$bodytag);
$prnt .= qq~<table border="1" cellpadding="6" cellspacing="0" bgcolor=
+"#111111">
<tr><th colspan="3"><h1>$pp </h1></td></tr><tr><th> </th><th>Vers
+ion</th><th>Date</th>~;
if($check{'version'} < $info{'version'}){
$prnt .= qq~</tr><tr><th align="right"><a href="$uri?node=63816">D
+owngrade</a> </th>~
}
else{
$prnt .= qq~</tr><tr><th align="right"><a href="$uri?node=63816">U
+pdate</a> </th>~
}
$check{'date'} =~ s/(....)(..)(..)/$1-$2-$3/;
$prnt .= qq~
<td align="center">$check{'version'}</td>
<td align="center">$check{'date'}</td></tr>~;
$info{'date'} =~ s/(....)(..)(..)/$1-$2-$3/;
$prnt .= qq~<tr><th align="right">This </th>
<td align="center">$info{'version'}</td>
<td align="center">$info{'date'}</td></tr></table>
<p>$note[0] $eh~;
print $prnt;
}
sub msgchat
{ # private message chat function
my($state,$xs) = @_;
my$link = encode_entities(escape($i{'privuser'}));
my$frm = qq~<input type="hidden" name="op" value="message">
<INPUT TYPE="hidden" NAME="node_id" VALUE="37150">
<INPUT TYPE="hidden" NAME="sexisgood" VALUE="submit">
<input type="hidden" name="privuser" value="$i{'privuser'}">
<input type="hidden" name="n" value="pchat">~;
if($state eq 'init'){ users('fu'); exit } # initialize
if($state eq 'frame'){ # frameset
print qq~<html><title>private chat with $i{'privuser'}</title>
<frameset rows="*,23%" border="$fborder">
<frame name="pchat" src="$uri?n=pchat&privuser=$link" marginwidth=
+"10" marginheight="10" scrolling="auto" frameborder="$fborder">
<frame name="ptalk" src="$uri?n=ptalk&privuser=$link" marginwidth=
+"10" marginheight="10" scrolling="auto" frameborder="$fborder">
</frameset></html>~;
exit
}
if($state eq 'chat'){ # chat frame
my$pl = 0;
login();
$req = GET ($mesgxml);
request();
my$msgxml = $res->content;
$msgxml = fixxml($msgxml);
my$data = eval{ XMLin($msgxml, keyattr => 'message', forcearray =>
+ 1)};
$@ && xml_parse_failure($refresh_pchat,'n=pchat&privuser=$link','D
+ownload',"<p>$@");
my$prnt = '<html><head>';
$prnt .= qq~<meta http-equiv="refresh" content="15; url=$uri?n=pch
+at&privuser=$link">~ unless $i{'paused'};
$prnt .= qq~</head> $bodytag~;
if(defined @{$data->{'message'}}){
$prnt .= qq~<table border="0" cellpadding="0" cellspacing="0"
+width="100%"><tr>
<FORM METHOD="POST" ENCTYPE="application/x-www-form-urlencoded
+"><td>~;
for my $msg(@{$data->{'message'}}){ # save all
if($msg->{'status'} eq 'active'){
if($msg->{'author'} eq $i{'privuser'}
|| ($msg->{'author'} eq $username && $msg->{'content'
+} =~ /To:"$i{'privuser'}"->/)){
$prnt .= qq~<input type="hidden" name="archive_$ms
+g->{'message_id'}" VALUE="yup">~;
$pl++
}
}
}
$prnt .= $frm;
$prnt .= qq~<input type="submit" value="save all">~ if $pl > 0
+;
$prnt .= qq~</td></form>
<FORM METHOD="POST" ENCTYPE="application/x-www-form-urlencoded
+"><td>~;
for my $msg(@{$data->{'message'}}){ # delete all
if($msg->{'status'} eq 'active'){
if( (($msg->{'author'}) eq ($i{'privuser'}))
|| (($msg->{'author'} eq $username) && ($msg->{'conte
+nt'}=~/To:"$i{'privuser'}"->/)) ){
$prnt .= qq~<input type="hidden" name="deletemsg_$
+msg->{'message_id'}" value="yup">~;
}
}
}
$prnt .= $frm;
$prnt .= qq~<input type="submit" value="clear all">~ if $pl >
+0;
$prnt .= qq~</td></form><FORM METHOD="POST" ENCTYPE="applicati
+on/x-www-form-urlencoded"><td>~;
$prnt .= qq~<input type="submit" name="paused" value="pause">~
+ unless $i{'paused'} || $pl < 1; # thank ybiC for this idea
$prnt .= '<b>PAUSED</b>' if $i{'paused'};
$prnt .= qq~</td><td align="right">$nb~.$frm;
$prnt .= qq~<input type="submit" value="Go">~ if $pl > 0;
$prnt .= qq~</td></tr><tr><td colspan="4">~;
$prnt .= qq~$pbr <font size="-2">save - del</font><br>~ if $pl
+ > 0;
$prnt .= $font_open;
if($reverse_pchat eq 'yes'){@{$data->{'message'}} = reverse(@{
+$data->{'message'}})} # reverse order
for my $msg(@{$data->{'message'}}){
if($msg->{'status'} eq 'active'){ # active messages
if( (($msg->{'author'}) eq ($i{'privuser'}))
|| (($msg->{'author'} eq $username) && ($msg->{'conte
+nt'}=~s/To:"$i{'privuser'}"->//)) ){
my$content = makelinks($msg->{'content'});
$msg->{'time'}=~m/^(....)(..)(..)(..)(..)(..)$/;
$prnt .= qq~<input type="checkbox" name="archive_$
+msg->{'message_id'}" VALUE="yup">
<input type="checkbox" name="deletemsg_$msg->{'mes
+sage_id'}" value="yup">
$2/$3 at $4:$5:$6
<<a href="$uri?node_id=$msg->{'user_id'}"$mnt>$
+msg->{'author'}</a>> $content<br>\n~;
}
}
}
$prnt .= '</td></form></tr></table> ';
}
$prnt .= qq~$bq $pbr No private messages from <a href="$uri?node=$
+link">$i{'privuser'}</a>...~ if $pl < 1 && !$cookie{'logout'};
$prnt .= qq~$bq $pbr <i>Logout enabled, private chat disabled...</
+i>~ if $cookie{'logout'};
$prnt .= $eh;
print $prnt;
exit
}
if($state eq 'talk'){ # input frame
print qq~<html> $bodytag
<table border="0" cellpadding="0" cellspacing="0" width="100%"><tr
+>
<FORM METHOD="POST" ENCTYPE="application/x-www-form-urlencoded">
<td valign="bottom" rowspan="2">
<INPUT type=hidden name="op" value="message">
<INPUT TYPE="hidden" NAME="node_id" VALUE="37150">
<input type="hidden" name="privuser" value="$i{'privuser'}">
<input type="hidden" name="n" value="ptalk">
<INPUT TYPE="hidden" NAME="sexisgood" VALUE="submit">
<textarea name="message" wrap="virtual" cols="50" rows="4">$xs<\/t
+extarea></td>
<td colspan="3" align="center"><font size="-1">
private chat with <a href="$uri?node=$link"$mnt>$i{'privuser'}</a>
+</font></td></tr>
<tr><td align="left" valign="bottom"><INPUT TYPE="submit" VALUE="t
+alk"></td>
<td valign="bottom">$nb$nb$nb$nb$nb$nb </td></form>
<FORM METHOD="POST" target="pchat"><td align="right" valign="botto
+m">
<input type="hidden" name="n" value="msgchat">
<input type="submit" value="chat with"></td></form></tr></table> $
+eh~;
exit
}
}
sub reputation
{
use vars qw($then $rephistory %then %now %thenrep %nowrep %thenall %no
+wall %changed %rephist @reps);
my@time = localtime $present;
my$ts = sprintf("%4u%02u%02u%02u%02u%02u", $time[5]+1900, $time[4]+1,
+$time[3], $time[2], $time[1], $time[0]);
if($i{'n'} eq 'repinit'){
print qq~<frameset rows="$repframe_rows" border="$fborder">
<frame name="rep" src="$uri?n=repframe" marginwidth="10" marginhei
+ght="10" scrolling="auto" frameborder="$fborder">
<frame name="chat" src="$uri?n=chat" scrolling="auto" frameborder=
+"$fborder">
</frameset>~;
exit
}
if($i{'n'} eq 'reperaser'){
my@nodes = param('nodes');
my$prnt = open_html('deleted reps','',"$bodytag $bq <form method='
+post'>");
$prnt .= 'No nodes selected!' if @nodes < 1;
if(@nodes > 0){
eval "require '$rephistfile'";
$@ && print qq~$bq <b>Error reading $rephistfile:</b> $@~ && e
+xit;
my%rh = %{$rephistory};
my@nodes = param('nodes');
for(@nodes){
delete $rh{$_} if exists $rh{$_}
}
io('write',$rephistfile,\%rh,'rephistory');
$prnt .= qq~$_ ~ for @nodes;
$prnt .= qq~deleted!<p>~;
}
$prnt .= qq~<input type="hidden" name="n" value="rephistview">
<input type="submit" value="ok"></form> $eh~;
print $prnt
}
if($i{'n'} =~ /rep(\d+)/){ # rep history graph
my$node = $1;
eval "require '$rephistfile'";
$@ && print qq~$bq <b>Error reading $rephistfile:</b> $@~ && exit;
my$prnt = open_html('rep graph',$tablestyle,$bodytag);
$prnt .= qq~<font size=-2>~;
my%rh = %{$rephistory};
for(keys %rh){
if($_ == $node){
for(@{$rh{$node}->{'reps'}}){
$a = $_*3;
$prnt .= qq~$_ <hr align="left" width="$a"> ~
}
last
}
}
print $prnt
}
if($i{'n'} eq 'rephistview'){
my$prnt = open_html('rep history',$tablestyle,$bodytag);
eval "require '$rephistfile'";
$@ && print qq~$bq <b>Error reading $rephistfile:</b> $@~ && exit;
my%rh = %{$rephistory};
$then = 0;
$then++ for keys %rh;
$prnt .= qq~<form method="post"><table border="1" cellpadding="3"
+cellspacing="0" align="right">
<tr><td align="center"><a href="$uri?n=rephistview">refresh</a></t
+d>
<td align="right"><b>reputation change history</td></tr><tr><td al
+ign="right">
<b>Date:</b></td><td> the last time a rep change was detected.<br>
+</td></tr><tr><td align="right">
<b>Checkbox:</b></td><td> select nodes to be erased from rep histo
+ry.<br></td></tr><tr><td align="right">
<b>Reps:</b></td><td> current rep is leftmost and <b>bold,</b> pre
+vious reps trail off to the right.</td></tr>
<tr><td colspan="2">
<input type="submit" value="erase"> the selected nodes from rep hi
+story.
<input type="hidden" name="n" value="reperaser">
</td></tr></table><br clear="right">
<p><h2>$then Node Reps</h2>
Select the node_id to graph that node, and the title to visit the
+node.<hr>~;
for(sort { $rh{$b}->{'lastchange'} <=> $rh{$a}->{'lastchange'} } k
+eys %rh){
$rh{$_}->{'lastchange'} =~ m/^(....)(..)(..)(..)(..)(..)$/;
$prnt .= qq~ $2/$3 at $4:$5:$6<br>
<input type="checkbox" name="nodes" value="$_">
<a href="$uri?n=rep$_"><b>$_</b></a> -
<a href="$uri?node_id=$_">$rh{$_}->{'content'}</a>~;
$prnt .= '<br>';
my$c = 0;
for(reverse @{$rh{$_}->{'reps'}}){
$c++;
if($c == 1){ $prnt .= qq~$nb <b>$_</b>, ~; next }
$prnt .= qq~$_, ~;
}
$prnt =~ s/,\s$//;
$prnt .= '<hr>';
}
$prnt .= '</form>';
print $prnt;
exit
}
if($i{'n'} eq 'repframe'){
login();
$req = GET ($repurl);
request();
my$repxml = $res->content;
$repxml = fixxml($repxml);
my$now = eval{ XMLin($repxml, keyattr => 'NODE', forcearray => 1)}
+; # $now
$req = "<i>Logout enabled...</i> <a href='$uri?n=chat' target='cha
+t'>Disable?</a><br> Rep" if $cookie{'logout'};
$req = 'Rep' if !$cookie{'logout'};
$@ && xml_parse_failure('60','n=repframe',$req,"<p>$@");
eval "require '$repfile'";
if($@){
io('write',$repfile,$now,'then');
eval "require '$repfile'";
$@ && print qq~$bq <b>Error reading $repfile:</b> $@~ && exit;
}
io('write',$repfile,$now,'then'); # save $now as $then
for my $then (@{$then->{'NODE'}}){
$thenall{$then->{'id'}} = $then->{'reputation'};
}
for my $now (@{$now->{'NODE'}}){
for my $then (@{$then->{'NODE'}}){
if($now->{'id'} == $then->{'id'}){
if($now->{'reputation'} > $then->{'reputation'}){ # ga
+in
$changed{$now->{'id'}}->{'reputation'} = $now->{'r
+eputation'};
$changed{$now->{'id'}}->{'content'} = $now->{'c
+ontent'};
$changed{$now->{'id'}}->{'thenrep'} = $then->{'
+reputation'};
$changed{$now->{'id'}}->{'change'} = sprintf "
+%+d", ($now->{'reputation'} - $then->{'reputation'});
$rephist{$now->{'id'}}->{'content'} = $now->{'c
+ontent'};
$rephist{$now->{'id'}}->{'reputation'} = $now->{'r
+eputation'};
push @{$rephist{$now->{'id'}}->{'reps'}}, $now->{'
+reputation'};
}
if($now->{'reputation'} < $then->{'reputation'}){ # lo
+ss
$changed{$then->{'id'}}->{'reputation'} = $now->{'
+reputation'};
$changed{$then->{'id'}}->{'content'} = $then->{
+'content'};
$changed{$then->{'id'}}->{'thenrep'} = $then->{
+'reputation'};
$changed{$then->{'id'}}->{'change'} = sprintf
+"%d", ($now->{'reputation'} - $then->{'reputation'});
$rephist{$then->{'id'}}->{'content'} = $now->{'
+content'};
$rephist{$then->{'id'}}->{'reputation'} = $now->{'
+reputation'};
push @{$rephist{$then->{'id'}}->{'reps'}}, $now->{
+'reputation'};
}
last
}
}
$nowall{$now->{'id'}}->{'reputation'} = $now->{'reputation'};
$nowall{$now->{'id'}}->{'content'} = $now->{'content'};
}
my@newnodes;
for(sort {$b <=> $a} keys %nowall){ # new nodes
unless(exists $thenall{$_}){
$changed{$_}->{'reputation'} = $nowall{$_}->{'reputation'}
+;
$changed{$_}->{'content'} = $nowall{$_}->{'content'};
$changed{$_}->{'thenrep'} = 0;
$changed{$_}->{'change'} = sprintf "%+d", (0 + $nowall
+{$_}->{'reputation'});
$rephist{$_}->{'content'} = $nowall{$_}->{'content'};
$rephist{$_}->{'reputation'} = $nowall{$_}->{'reputation'}
+;
push @{$rephist{$_}->{'reps'}}, $nowall{$_}->{'reputation'
+};
}
}
my$rr = $refresh_rep*60;
my$meta = qq~<meta http-equiv="refresh" content="$rr; url=$uri?n=r
+epframe"> $tablestyle~;
my$prnt = open_html('newnodes',$meta,$bodytag);
io('write',$rephistfile,\%rephist,'rephistory') unless -e $rephist
+file;
eval "require '$rephistfile'";
my%rh = %{$rephistory};
my$c = 0;
for my $old (keys %rh){ # record changed reps
for my $new (keys %rephist){
if($old == $new){
if($rh{$old}->{'reps'}[$#{$rh{$old}->{'reps'}}] != $re
+phist{$new}->{'reputation'}){ # thank you ar0n
push @{$rh{$old}->{'reps'}}, $rephist{$new}->{'rep
+utation'};
$rh{$old}->{'lastchange'} = $ts;
$c++
}
}
}
}
for (keys %rephist){ # add new nodes
next if exists $rh{$_};
$rh{$_}->{'lastchange'} = $ts;
$rh{$_}->{'content'} = $rephist{$_}->{'content'};
push @{$rh{$_}->{'reps'}}, $rephist{$_}->{'reputation'};
$c++
}
io('write',$rephistfile,\%rh,'rephistory') if $c > 0; # save rep h
+istory
if(%changed){
$prnt .= qq~<table border="1" cellpadding="3" cellspacing="0"
+width="100%">
<tr><th align="left"><font size="-1">node
<th align="center"><font size="-1">then
<th align="center"><font size="-1">now
<th align="center"><font size="-1">change</tr>~;
for(sort {$b <=> $a} %changed){
next if $_ =~ /\D/;
my$i = '';
$i = '<i>' if $changed{$_}->{'change'} < 0;
$changed{$_}->{'change'} =~ s/^\+0/0/ if $changed{$_}->{'c
+hange'} eq '+0'; # eek, sprintf can return +0
$prnt .= qq~<tr>
<td>$i <a href="$uri?node_id=$_"$rct>$changed{$_}->{'conte
+nt'}</a> </td>
<td align="center">$i $changed{$_}->{'thenrep'} </td>
<td align="center">$i $changed{$_}->{'reputation'} </td>
<td align="center">$i $changed{$_}->{'change'} $nb</td>
</tr>~
}
$prnt .= qq~</table>~;
}
else{ $prnt .= qq~$bq $pbr <font size=-1><i>No change...</i></font
+>~ }
my$s = 's';
$s = '' if $refresh_rep == 1;
$prnt .= qq~<form>Refresh reputation change every
<input type="text" name="refresh_rep" value="$refresh_rep" size="3
+" maxlength="3">
minute$s. <input type="submit" value="change"></form>~;
$prnt .= qq~</blockquote>
<table border="0" width="100%" cellpadding="0" cellspacing="0"><tr
+><td>$loc ($gmt)</td>
<td align="right"><a href="$uri?n=rephistview" target="_blank">vie
+w rep history</a> -
<a href="$uri?n=chat" target="chat">disable</a></td></tr></table>~
+;
$prnt .= $eh;
print $prnt;
exit
}
}
sub newnodes
{
$i{'pageloadtime'} = $present;
my$crono = ($nnnodes*60); # minutes to seconds
my$sut = ( $i{'pageloadtime'} - $crono );
$nnxml = $nnxml."&sinceunixtime=$sut";
my$nn;
if($use_proxy eq 'on'){
login();
$req = GET ($nnxml);
request();
$nn = $res->content;
}
else{$nn = get "$nnxml"}
$nn = fixxml($nn);
my$data = eval{ XMLin($nn, forcearray => 1)};
if($@){
$nn = qq~Load the <a href='$uri?n=url'>launchpad</a> or <a href='$
+uri?n=inbox'>inbox</a>?<p>$@~;
xml_parse_failure($refresh_nn,'n=nn','New nodes',$nn);
}
my(%whom,%nodes);
if(defined(@{$data->{'AUTHOR'}})){
for my $who(@{$data->{'AUTHOR'}}){
$who->{'content'} = encode($who->{'content'}); # UTF8 to latin
+1
$whom{$who->{'node_id'}} = $who->{'content'}
}
}
if(defined(@{$data->{'NODE'}})){
for my $new(@{$data->{'NODE'}}){
$new->{'content'} = encode($new->{'content'}); # UTF8 to latin
+1
$new->{'author_user'} = encode($new->{'author_user'}); # UTF8
+to latin1
$nodes{$new->{'node_id'}}->{'content'} = $new->{'content'};
$nodes{$new->{'node_id'}}->{'nodetype'} = $new->{'nodetype'};
$nodes{$new->{'node_id'}}->{'author'} = $new->{'author_user'
+};
$nodes{$new->{'node_id'}}->{'created'} = $new->{'createtime'}
+;
if(exists($new->{'parent_node'})){
$nodes{$new->{'node_id'}}->{'parent'} = $new->{'parent_nod
+e'};
}
else{
$nodes{$new->{'node_id'}}->{'parent'} = 0;
}
}
}
my$meta = qq~<meta http-equiv="refresh" content="$refresh_nn; url=$uri
+?n=nn"> $tablestyle~;
my$prnt = open_html('newnodes',$meta,$bodytag);
my$s = 's';
$s = '' if $nnnodes == 1;
if(%nodes){
$prnt .= qq~<table border="1" cellspacing="0" cellpadding="1" widt
+h="100%"><tr align="left">
<td><b>Parent</td><td><b>Title</td><td><b>Author</td><td><b>Catego
+ry</td><td><b>Created</td></tr>
<tr><td colspan="2" align="right" valign="top"><b>Refreshed</b></t
+d>
<td colspan="2" align="right" valign="top">$nb </td>
<td>$gmt</td></tr>~;
my%stypes = (
'categorized answer' => 'answer',
'categorized question' => 'question',
'monkdiscuss' => 'discussion',
'note' => 'reply',
'perlcraft' => 'craft',
'perlmeditation' => 'meditation',
'perlnews' => 'Perl News',
'perlquestion' => 'seekers',
'sourcecode' => 'catacombs',
);
for(sort {$b <=> $a} keys %nodes){
my$f = '';
if($nodes{$_}->{'nodetype'} eq 'user'){$f = 'user'} else {$f =
+ '<b>root</b>'}
$prnt .= qq~<tr>~;
if($nodes{$_}->{'parent'} == 0){
$prnt .= qq~<td> <font size="-2">$f</font> </td>~
}
else{
$prnt .= qq~<td> <a href="$uri?node_id=$nodes{$_}->{'paren
+t'}"$nnt>$nodes{$_}->{'parent'}</a>$nb </td>~
}
$prnt .= qq~<td> <a href="$uri?node_id=$_"$nnt>$nodes{$_}->{'c
+ontent'}</a> </td>
<td> <a href="$uri?node_id=$nodes{$_}->{'author'}"$nnt>$whom{$
+nodes{$_}->{'author'}}</a> </td>
<td> ~;
if($stypes{$nodes{$_}->{'nodetype'}}){ # use short version of
+long nodetypes
$prnt .= qq~$stypes{$nodes{$_}->{'nodetype'}}~
}
else{
$prnt .= qq~$nodes{$_}->{'nodetype'}~;
}
$nodes{$_}->{'created'} =~ s/^(........)(..)(..)(..)$/$2:$3:$4/;
$prnt .= qq~</td><td> $nodes{$_}->{'created'} </td></tr>~;
}
}
else{ $prnt .= qq~<font size=-1><i>No new nodes in the past $nnnodes m
+inute$s.</i></font>~ }
$prnt .= qq~</td></tr></table>
<form>Showing the past
<input type="text" name="nnnodes" value="$nnnodes" size="3" maxlength=
+"3">
minute$s of nodes refreshed every
<input type="text" name="refresh_nn" value="$refresh_nn" size="3" maxl
+ength="3">
seconds.
<input type="submit" value="change"></form>
<table border="0" width="100%" cellpadding="0" cellspacing="0"><tr><td
+>
<font size="-1">Make sure your system clock is correct to ensure an ac
+curate count.</font>
</td><td align="right"><font size="-1">
<a href="$uri?n=inbox">inbox</a> -
<a href="$uri?n=url">launchpad</a> -
<a href="$uri?n=nn" target="_blank">float</a></font></td></tr>
<tr><td colspan="2">$pbr $loc ($gmt)</td></tr>
</table> $eh~;
print $prnt;
exit
}
sub get_info
{
%info = ( version => '2.04', date => '20020516' ); # version and relea
+se date
$changes = qq~<p><font size="+3">New in 2.0</font><br><ul>
<li>New nodes ticker!
<li>Rep change ticker with history!
<li>Client login & quit for better security.
<li>Create & edit optional external config file.
<li>Tools control panel to see & set parameters.
<li>/ignore and /unignore and see who's being ignored.
<li>/logout and /login implemented.
<ul>
<li>Not in the userlist but still see chat.
<li>All links to perlmonks become logged out.
<li>History still functions if enabled.
<li>Logout disables node title lookup.</ul>
<p>
<b>Improved:</b><br>
<li>Faster thanks to less print statements.
<li>More robust error handling (esp. xml parsing).
<li>XP nodelet now shows xp gain and loss messages (Ack!)
<li>inbox/launchpad/newnode frame can remember state.
<li>Notes added to update notification.
<p>
<b>Fixed in 2.0:</b><br>
<li>Bug in link parser that caused italic history after an unclosed i
+tag.
<li>Last \$norm should now appear when code updated.
<li>Code is less redundant and more readable.
<p>
<b>Fixed in 2.01:</b><br>
<li>A new node with 0 rep showed +0 change (a printf feature).
<li>New nodes and check update didn't work if proxy in use.
<li>New nodes loadtime was 1 second off.
<p>
<b>Fixed in 2.02:</b><br>
<li>Empty document error if history file for present day didn't exist.
<li>IIS breakage addressed with a new config var: \$broken.
<li>Change to talk frame enables submit with Tab+Enter sequence (thank
+s grinder).
<li><i> tags would italicize cb text, oops.
<li>Rep related data files now 50% smaller.
<li>Added config file syntax status feedback and warnings.
<li>Improved the help and tools sections.
<li><b>NEW:</b> Node rep history graph!
<p>
<b>Fixed in 2.03:</b><br>
<li>Control chrs in chat xml not being stripped due to missing /d modi
+fier on tr in sub fixxml.
<li>Client authentication erroneously succeeded if username and passwo
+rd not defined.
<p>
<b>Fixed in 2.04:</b><br>
<li>Repaired the chat frame and norm parser to conform with changes at
+ perlmonks.
<li>Added support for the latest shortcut tags: pad, kobe, jargon, per
+ldoc. If you use an external
config file these need to be added to the \@tags array so they appear
+in the pulldown menu in the
input frame, as well as a few items added to the \%launch_urls hash.
</ul>~;
$credits = qq~special thanks to:
[chromatic] for help with valid domains in LWP cookies.
[dkubb] for a potent lesson in references and nested lists.
[tye], [chipmunk], [MrNobo1024] and [OeufMayo] for regular expression
+tips.
[mirod] for lots and lots of help with XML encoding issues.
[jcwren] for the secret to dealing with high bits and control characte
+rs.
[merlyn] for a short but sweet lesson on the cookie_jar.
[a] for help resolving warnings and attending expat version problems.
[OeufMayo] for the XP progress bar and mod_perl patches! and for testi
+ng.
[ybiC] for proxy support, catching the saint 'xp to next level' bug, a
+nd testing.
[vroom] for perlmonks and everyone else for putting up with testing :-
+)~;
}
|
