#!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 browser. # On first run you'll be prompted for the password you set in config vars. # 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_titles $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 $refresh_rep $refresh_user $refresh_xp $repframe_rows $repurl $reverse_inbox $reverse_pchat $search_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 settings! # begin config variables, must set first 5 (don't edit this line) $perlmonks = 'www.perlmonks.org'; # the domain you usually use for perlmonks, should have a www. prefix $perlmonks_off = ''; # a domain for which you have no browser cookie for perlmonks $username = ''; # perlmonks username $password = ''; # perlmonks password $temp = './'; # dir where files are saved, must be able to create, write 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 76003) # display options @friends = qw(); # put usernames you want bold in the userlist $bodytag = ''; # used everywhere $stylesheet = ''; # global stylesheet $tablestyle = ''; # small fonts in td tags $font_open = ''; # chat and userlist font, use or 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 first $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 userlist $newestnodes = ''; # url to newest nodes client, blank = perlmonks link $nnnodes = 60; # default minutes worth of new nodes, redefined later 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 rows: 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 cookie 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 cookie $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?from=MDZ411&theisbn=', merlyn => 'http://www.stonehenge.com/perl/googlecolumnsearch?search_for=', perldoc => 'http://www.perldoc.com/cgi-bin/htsearch?words=', define => 'http://www.dict.org/bin/Dict?Form=Dict1&Strategy=*&Database=*&Query=', jargon => 'http://www.science.uva.nl/cng/search/htsearch.CGI?restrict=%2F%7Emes%2Fjargon%2F&words=', kobe => 'http://theoryx5.uwinnipeg.ca/mod_perl/cpan-search?filetype=+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 data @tags = ( '/me ', '/msg ', '[id://] ', '[pad://] ', '[cpan://] ', '[kobe://] ', '[perldoc://] ', '[jargon://] ', '[google://] ', '[lucky://] ', '[isbn://] ', '[http://] ', '[ftp://] ', '</code> ', ' ', ' ', '/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 v1.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|logout|config'; my$userpass = crypt($password,$username); my$state = $present; # used in authentication # html my$nb = ' '; my$pbr = '


'; my$bq = '

'; my$eh = ''; # 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 url? 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 = 'NodeReaper'; my@reaper = ( "$nrl preheats the oven before tossing in a cherry pie", "$nrl tiptoes up behind an unsuspecting visitor", "$nrl sharpens his scythe", ); 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 from 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'}.'&displaytype='.$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{'passwd'}",-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=>'',-expires=>'-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$/)){ # inbox 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 refresh rate $c = CGI::Cookie->new(-name=>"refresh_rep",-value=>"$i{'refresh_rep'}",-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'}",-expires=>'+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=>'+10y'); 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{'privchat'}); msgchat('talk') if $i{'n'} eq 'ptalk' && ($i{'privuser'} || $i{'privchat'}); } elsif($i{'find'}){ search_history()} elsif($state eq $userpass){ # frameset print qq~framechat <blockquote><h1>Error</h1>Something went wrong with the header or this browser doesn't support frames.<hr><a href="$uri">framechat</a>/$info{'version'}~; 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~

Error

Login is not possible unless both username and password are set either in the script or a valid config file! Please fix this problem and reload.~ unless $username && $password && $userpass; $prnt .= qq~$pbr
password :
logged in or out
~ 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 = ; 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~Warning: If this file doesn't have valid perl syntax it will fail to be included.
  1. If username and password are set in the script then a bad config file will silently fail to be included and the variables defined in the script body will be used instead. See tools for config status.

  2. If username and password are not set in the script then a bad config file will prevent client login 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.
~; if($i{'n'} eq 'config edit'){ my@config = io('read',$config); $temp = 'valid' if $erc eq '1'; $temp = 'invalid' if $erc ne '1'; my$prnt = open_html($i{'n'},'',$bodytag); $prnt .= qq~
$wrn

This config file had $temp syntax when it was loaded.