http://www.perlmonks.org?node_id=598676

#!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>&lt;/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 = '&nbsp;'; 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/\[/&#91;/g; $code =~ s/\]/&#93;/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">&nbsp;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~&lt;<a href="$pmurl?node_id=$message->{'us +er_id'}"$mnt>$author</a>&gt; $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~&lt;<a href="$uri?node_id=$id"$mnt>$name</a>&gt; $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 &lt;<a href="$uri?node_id=$huser"$mnt>$hau +th</a>&gt; $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">&nbsp;</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 - &amp;#$_;\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/&/&amp;/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/&/&amp;/g; if($i{'ent'} && $i{'ent'} == 1){ $extra = $i{'message'}; } elsif($i{'ent'} && $i{'ent'} != 1){ $extra = $i{'message'}.'&amp;#'.$i{'ent'}.';'; # build and + append entity } else{ $extra = '' } } if($extra eq 'enc'){ # insert entities $extra = encode_entities($i{'message'}); $extra =~ s/&/&amp;/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/&lt;/</; # 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/&amp;/g; $fix =~ s/\x3C/&lt;/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>&nbsp;-&nbsp; <a href="$uri?node=best+nodes"$nodes>best</a>&nbsp;-&nbsp; <a href="$uri?node=worst+nodes"$nodes>worst</a>&nbsp;-&nbsp; <a href="$uri?node=nodes+to+consider"$nodes><b>&copy;</b></a></nobr> <li><nobr><a href="$uri?node=$username"$nodes>home</a>&nbsp;-&nbsp; <a href="$uri?n=sds" target="search">search</a>&nbsp;-&nbsp; <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;-&nbsp;~ if $history eq 'on'; $prnt .= qq~<a href="$uri?n=tools"$nodes">tools</a>&nbsp;-&nbsp; <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 &quot;quo +te phrases&quot;. <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">&nbsp;</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">&nbsp;</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:&nbsp; <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>&nbsp; <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 &lt;, &amp;, &gt;, and &quot; 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>&copy;</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>&nbsp;</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 &lt;<a href="$uri?node_id=$msg->{'user_id'}"$mnt>$ +msg->{'author'}</a>&gt; $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>&lt;i&gt; 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 :- +)~; }