Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

framechat.pl

by epoptai (Curate)
on Feb 07, 2007 at 03:25 UTC ( #598676=largedoc: print w/ replies, xml ) Need Help??

#!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 :- +)~; }


Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others meditating upon the Monastery: (6)
As of 2014-10-22 10:26 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    For retirement, I am banking on:










    Results (114 votes), past polls