#!/usr/bin/perl # program to compile WOB files. See http://wob.sourceforge.com # Copyright (c) 2000, John Hanna, # This program may be distributed under the terms of this General Public # License. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED # BY APPLICABLE LAW. # http://www.opensource.org/licenses/gpl-license.html # ## set the following to enable these features $CompiledOutput='/usr/users/www/pma/debug'; ## file name for compiled output $sqllog='/usr/users/www/pma/sqllog'; ## file for logging SQL info ## this is the location of the directory to keep session data $_sid_base='/home/groups/wob/sid/'; $_sid_base='/usr/users/www/pma/sid/'; $_SID_TIMEOUT=60*60*2; ## sessions time out after 2 hours without use use DBI; ########################################## ## this part compiles the wob file undef $/; $_=<>; ## read wob file ### looking for # ###name and ##name defs # -> links # $var substitutions -> hash of session # &func calls # `` perl `` blocks # handle buttons # put existing values into form info # #insert filename s/\r//g; ($_head)=split(/

##/i,$_,2); $_="\n".substr($_,length($_head)); $_head=~s/\s*$//; $_head=~s/\r//g; $_head="" unless $_head; #($tail)=/###end\b.*([^\000]*)$/i; #$tail="\n" unless $tail; # do inserts #print join("\n",/([^#])#(insert|include)\s+(\S+)/g),"\n"; while(s/([^#])#(insert|include)\s+([^\s<]+)/$1.&_insert($3)/ge) {} #&wf("/usr/users/www/pma/d3",$_); ($_base)=/###(\w+)/i; ($defaultDB)=/\$(\w+) *= *DBI.*connect/; s/;\]/\002/gi; $sqlcmds='select|create|alter|optimize|check|repair|delete|join|insert|replace|load|update|use|flush|kill|show|explain|describe|lock|set|grant'; s/\[ *(($sqlcmds)\s[^\002]+)\002/"&sql(\$$defaultDB,qq[".&_autoquote($1).";])"/gie; s/\002/;]/g; sub _autoquote { local($_)=@_; s/'\$(\w+)'/\\000\$$1\\000/g; $_; } #while(/``([^\000]*?)``/g) {local($_)=$1; # print STDERR "Runaway `` script includes $1\n" if /[^#](###?\w+)/; #} ## Private s/\bprivate\s+\$(\w+);/$_privates{$1}=''/ge; s/\bprivate\s+\$(\w+)/$_privates{$1}="\$$1"/ge; $_privates=join('|',keys %_privates); ## Var: $SQL s/\$SQL(\w+)/\$SQL{$1}/g; ## Var: session s/\$(?!SQL)([a-zA-Z]\w*)/\$_session{$1}/g; ## code s/([^\000]*?)<\/script>/&_code2/gie; #s/;[<>\r\n \tpbr\/]*\]/\002/gi; s/

``/``/gi; s/``<\/p>/``/gi; s/``/\002/g; s/\002([^\002]*)\002/&_code/ge; ## "function" calls s/([\s>])&(\w+)/$1\002!!$2;\002/g; ## ]*name *= *"?)(\w+)([^>]*)>/$1$2$3>\$_session{$2}/gi; ## <select, radio, checkboxes s/<\/select>/\004/gi; s/(<select[^\004]*)\004/\002 &_selops(qq{$1});\002<\/select>/gi; ## <input s/(<input\s+[^>]*>)/&_input($1)/gie; sub _input {local($_,$t,$name,$v)=@_; ($t)=/type *= *"?(\w+)/i; $t="\L$t"; ($name)=/name *= *"?(\w+)/i; if($t eq 'text' || $t eq 'password') { ($v)=/value *= *"([^"]*)"/i; ($v)=/value *= *(\w+)/i unless $v; s/ value *= *"[^"]*"//i; s/ value *= *(\w+)//i; if($v) { s/>/value="\002 print \$_session{$name}?\$_session{$name}:"$v";\002">/; } else { s/>/ value="\$_session{$name}">/; } # s/(<input[^>]*name *= *"?)(\w+)([^>]*)>/$1$2$3 value="\$$2">/gi; } elsif($t eq 'checkbox') { #<input type="checkbox" checked name="C1" value="ON"> s/(<input\s+[^>]*>)/\002 &_checkbox(qq{$1},'$name');\002/gi; } elsif($t eq 'radio') { #<input type="radio" checked name="R1" value="V1"> s/(<input\s+[^>]*>)/\002 &_radio(qq{$1},'$name');\002/gi; } #"[$t]$_"; $_; } s/\002([^\002]*)\002/&_code/ge; ## make code what's just been inserted #wf('/usr/users/www/pma/debug2',$_); ## -> links s/->(\w+)/<a href="\$_myname?go=$1">$1<\/a>/g; s/<a href="\?/<a href="\$_myname?/gi; ## quote special string chars: quotes, @, $ s/(\$[^a-zA-Z_])/\\$1/g; ## quote $12.12 s/(["@])/\\$1/g; ## split objects s/\n\s*(<[^>]*>)*###(\w+).*/\n\000$2/gi; s/\000(\w+)\s*([^\000]*)/&_parse($1,$2)/ge; sub _fixup { local($_)=shift; # change code references appropriately # strip HTML from code s/<\/?p>//ig; s/<br>//gi; # html -> text s/&/&/g; s/>/>/g; s/</</g; s/"/"/gi; s/ / /gi; &_fixup2($_); } sub _fixup2 { local($_)=shift; # change code references appropriately # code is html free -- fix other code substitutions s/!!(\w+)/&_do('$1')/g; $_; } sub _code { $code[++$code]=&_fixup($1); "\001$code ";} sub _code2 { $code[++$code]=&_fixup2($1); "\001$code ";} sub _parse { local($name,$_,$kid) =@_; ## prep for redefines s/(<[^>]*>)*##(\w+)( |<[^>]*>)*/\006$2/g; s/\006(\w+)\s*([^\006]*)/ "\";\n \$_redef{${name}_$1}=(\$_redef{$1} || '$1'); \$_redef{$1}='${name}_$1';\n".&_parse($name."_$1",$2,$1)."\n print \""/ge; ## wrap sub around $_ $_=qq/\nsub $name {\n print "$_";\n}\n/; ## put code back in s/\001(\d+) /";\n$code[$1]\n print "/g; ## fix "recursive" calls #s/&_do$'$kid'$/&_do('${name}_$kid')/g; s/&_do$'$kid'$/&_do('${name}')/g; ## remove extranious prints s/\s+";/ ";/g; s/ *print " *";\n//g; eval($_); print "\n\nerror: $@\n<p><pre>\&$_session{'go'}; &$_base;\n".&beautify($_),"\n</pre>" if $@; $_; } ## build list of public access objects while(/[&\?;]go=(\w+)[">\s\&\\]/g) {$_pao{$1}='';} while(/name\s*=\s*\\?"?go\\?"?[^>]+value\s*=\s*\\?"?(\w+)["\s\\]/ig) {$_pao{$1}='';} while(/value\s*=\s*\\?"?(\w+)["\s\\][^>]+name\s*=\s*\\?"?go\W/ig) {$_pao{$1}='';} $_pao{$_base}=''; $_paochk=join('|',keys %_pao); ## prepare compiled file if($CompiledOutput) { $_f=&rf($0); ## read this script $_f=~s/\r//g; ## strip dos junk ## chop off up through the comment below $_f=~s/\$CompiledOutput='.*?'/\$CompiledOutput=''/g; $_f=~s"\$sqllog='.*?'"\$sqllog=''"g; #$_f=~s/(.*_session\{debug\}.*\n)/# $1/g; ## comment out debug lines for compiled output $__=<<EOT; \$_head=<<EOHEAD; $_head EOHEAD \$_paochk='$_paochk'; \$_privates='$_privates'; \$_base='$_base'; &_main; EOT $_sep='#' x 40; $_f=~s/$_sep[^\000]+$_sep/$__/; $_="$_f\n$_"; wf($CompiledOutput,$_); } while(/&_do$'([a-zA-Z]\w*)'/g) { print "\n\nwarning: $1 called but not defined<br>\n" unless defined &$1;} for(sort keys %_pao) { print "\n\nwarning: $_ referenced but not defined<br>\n" unless defined &$_;} #while(/sub (\w+) {/g) {print "\n\nwarning: $1 defined but not used<br>\n" unless /&_do\('$1'/;} sub beautify { # return $_[0]; local($rv,$q,$a,$delta,$tabtotal,$i,$tabstring,$ln); $tabstring=" "; $ln='001'; #s/\n+/\n/g; for (split(/\n/,$_[0])) { s/&/&/g; s/>/>/g; s/</</g; s/^\s*(.*)\s*$/$1/; # strip leading and trailing spaces $a = $_; # copy original string $q = $a; # i plan to modify this copy for testing $q =~ s/\\\#//g; # remove escaped comment tokens $q =~ s/\#.*$//g; # remove Perl-style comments $q =~ s/\/\*.*\*\///g; # remove C-style comments $q =~ s/\\.//g; # remove escaped chars #$q =~ s/\'.*\'//g; # remove single-quoted lines # now the remaining braces/parentheses should be structural $delta = -($q =~ s/([\}\]$])/$1/g); # subtract closing braces $delta += ($q =~ s/([\{\[\(])/$1/g); # subtract closing braces $tabtotal += $delta; # subtract closing braces/parentheses $i = ($tabtotal > 0)?$tabtotal:0; # create tab index $tabtotal += $delta; # add opening braces/parentheses for next print $rv.="$ln: "; $ln++; if(substr($a,0,1) ne "#") { # don't tab comments $rv.= $tabstring x $i; # "tab" out to position } $rv.= "$a\n"; # print original line } if($tabtotal != 0) { $rv.= " Indentation error: $tabtotal\n"; } "$rv\n"; } sub _insert {local($_)=@_; #s/<.*//; s/^"(.*)"$/$1/; ## remove quotes around file name if quoted print "\n\ninserting $_\n" if $_session{debug}>1; $_=&rf($_); # read the file # strip off html head and tail s/^[^\000]*<body[^>]*>\s+//i; s/<\/body[^\000]*$//i; $_; } eval("&_main"); # do main processing print "\n\nerror: $@\n<p><pre>\go=$_session{'go'}; base=$_base;<br>\n".&beautify(&rf($0)),"\n<hr>\n".&beautify($_)."\n</pre>" if $@; ## the rest of this file is required in the output file as well. ########################################## sub _main { ## Main routine &_init; # recover session or set cookie; read cgi &Init if defined &Init; ## this is their init routine ## put in the title in the head $_head=~s/\$title/$_session{'go'} || $_base/ie; ## output the html header print $_head; #for (keys %ENV) {print "$_:$ENV{$_}<br>";} ## do the go item if it's defined and not base ## need to add security check here &_do($_session{'go'}) if $_session{'go'} && $_session{'go'} ne $_base && $_session{'go'}=~/^($_paochk)$/o; ## now do the base &_do($_base); ## debug redefs if($_session{debug}) {print "Redefs:<br>";for(sort keys %_redef) {print "$_: $_redef{$_}<br>";}} if($_session{debug}) {print "<br>Session: (id=$_sid)<br>";for(sort keys %_session) {print "$_: $_session{$_}<br>";}} &_do('end'); ## print html tail &_savestate; ## save session data ## delete expired session information sometimes &_sessioncleanup unless int(rand(100)); } sub _do { local($a,$b)=@_; $b=$_redef{$a}; print "($a/$b) " if $_session{debug}>1; if($b) {do $b();} else {do $a()}; } sub _selops { local($_,$name)=@_; ## need to support valued options... ($name)=/name *= *"([^"]+)"/i; ($name)=/name *= *(\w+)/i unless $name; #print "db: $name/$_session{$name}:$_\n"; if($_session{$name}) { s/<option selected>/<option>/gi; ## clear default selection if any s/(<option)(>$_session{"$name"}<)/$1 selected$2/i; } #print "db: $name/$_session{$name}:$_\n"; print $_; } sub _checkbox { local($_,$name,$v)=@_; #<input type="checkbox" checked name="C1" value="ON"> #($name)=/name *= *"([^"]+)"/i || /name *= *(\w+)/i; if($v=$_session{$name}) { #print "$name=$v "; s/(<[^>]*) checked([^>]*)>/$1$2>/gi; # clear default checks for $sv (split(';',$v)) { s/(name *= *"?$name"?\s*value *= *"?$sv"?)/checked $1/gi; } } print $_; } #<input type="radio" checked name="R1" value="V1"> sub _radio { local($_,$name,$v)=@_; #($name)=/name *= *"([^"]+)"/i || /name *= *(\w+)/i; if($v=$_session{$name}) { s/(<[^>]*) checked([^>]*)>/$1$2>/gi; # clear default checks s/(name *= *"?$name"?\s*value *= *"?$v"?)/checked $1/gi; } print $_; } sub _init { local($_); # read cookie or set cookie ($_sid)=$ENV{'HTTP_COOKIE'}=~/SID *= *(\w+)/; #$_sid='COOK'; srand(time + $$); unless ($_sid) { @l=('a'..'z','A'..'Z','0'..'9','_'); for $n (1..10) { $_sid.=$l[int(rand($#l+1))]; } print "Set-Cookie: SID=$_sid;\n"; # print "Set-Cookie: name, value, expires # nam=value; expies=date; path=path; domain=don; secure # date: wdy, dd-mon-yyyy hh:mm:ss gmt # env{'cookie'} -> split(/[=;] */) } # read state info (%_session)=split(/\001/,&rf($_sid_base.$_sid.$ENV{REMOTE_ADDR})); #(%_session)=split(/\001/,$_sessions{$_sid.$ENV{REMOTE_ADDR}}); # verify source ip, state timeout if( $_session{'_time'} && $_session{'_time'}<time-$_SID_TIMEOUT) { undef %_session; } # read cgi { local(%c,$i,$v); read(STDIN,$_,$ENV{'CONTENT_LENGTH'}) || ($_=$ENV{'QUERY_STRING'}); #print "\n\n$ENV{'QUERY_STRING'}//$_ -- "; y/+&=/ \001\002/; s/%(..)/pack("c",hex($1))/ge; s/\r\n/\n/g; for (split(/\001/)) { ($i,$v)=split(/\002/); $c{$i}.=';' if $c{$i}; $c{$i}.=$v; } #print "\n\n",join("|",%c)," "; for(keys %c) { next if/^($_privates)$/; ## skip variables marked as private $_session{$_}=$c{$_}; } } $_myname=$ENV{'SCRIPT_NAME'}; $_mypath=$ENV{'SCRIPT_FILENAME'}; $_mypath=~s/\/[^\/]*$//; $_url=$ENV{'SERVER_URL'}; chop($_url); $_url.=$_myname; $_session{'_time'}=time; print "Expires: " . &_now . "\n"; print "Content-type: text/html;\n\n"; } sub _now { local($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time); return ('Sun','Mon','Tue','Wed','Thu','Fri','Sat')[$wday] . ", $mday " . ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec')[$mon] . ' ' . ($year + 1900) . sprintf(" %d:%02d:%02d GMT", $hour,$min,$sec); } sub _savestate { # save state #$_sessions{$_sid.$ENV{REMOTE_ADDR}}=join("\001",%_session); &wf($_sid_base.$_sid.$ENV{REMOTE_ADDR},join("\001",%_session)); } sub _sessioncleanup { opendir(D,$_sid_base); for (readdir(D)) { next if -d $_sid_base.$_; #print "unlink $_sid_base.$_ if ",time-(stat $_sid_base.$_)[8]," > $_SID_TIMEOUT\n"; unlink $_sid_base.$_ if time-(stat $_sid_base.$_)[8] > $_SID_TIMEOUT; } } sub rf {local($_, $/); open(F,'<'.shift) && <F>;} sub wf {open(F,'>'.shift) && print F shift; close F;} sub clearsession { undef %_session; $_session{'_time'}=time; } sub _doautoquote { local($_)=@_; #s/\\/\\\\/g; s/([\\'\[\]])/\\$1/g; s/\r/\\r/g; s/\n/\\n/g; "'$_'"; } sub sql { local($db,$s,$fr)=@_; &_sqllog(($_sql_save ne $s?'new':'cont')." $s"); if($_sql_save ne $s) { $_sql_save=$s; # do the autoquoting... $s=~s/\000([^\000]*)\000/&_doautoquote($1)/ge; unless ($_sql_sth=$db->prepare($s)) { print "<pre>\nSQL Prepare Error: ",$db->errstr,"\n$_sql_save\n</pre>\n"; &_sqllog("SQL Prepare Error: ".$db->errstr); return 0; } unless ($_sqlresult=$_sql_sth->execute()) { print "<pre>\nSQL Execute Error: ",$db->errstr,"\n$_sql_save\n</pre>\n"; &_sqllog("SQL Prepare Error: ".$db->errstr); return 0; } $_insertid=$_sql_sth->{mysql_insertid}; } if($s=~/^ *select/i) { $fr=$_sql_sth->fetchrow_hashref; &_sqllog(" rv=$_sqlresult: ",join('|',%$fr)); $_sql_save='' unless %$fr; # clear cache if end of results return %SQL=%$fr; } else { $_sql_save=''; &_sqllog(" rv=$_sqlresult"); return $_sqlresult eq '0E0'? 0:1; } } sub _sqllog { return unless $sqllog; open(SQLLOG,">>$sqllog"); print SQLLOG join("\n",@_),"\n"; close SQLLOG; } sub quote4url { local($_)=@_; s/([^._\~\-\/ a-zA-Z0-9])/'%'.unpack('H*',$1)/eg; s/ /+/g; $_; } sub quote4sql { local($_)=@_; s/\\/\\\\/g; s/\n/\\n/g; s/\r//g; s/'/\\'/; s/\]/\\]/g; $_; } sub badlanguage { local($_,$profanity)=@_; $profanity = 'fuck|bitch|\banus|butt\b|\bass\b|\bpenis|\bvulva|\bpussy|' . '\btitt\b|\btitts|\bmutha|\bshit|\bturd|\bpiss\b|dickhead|dickface|' . 'dickless|dumbass|dammit|\bfuct\b|cocksuc|cock-suc|dicksuc|dick-suc|' . 'dildo|whore|twat|nigger|\bcunt|asshole|rot\s*in\s*hell|\bslut\b|jerk\s*off|' . 'masturbat|idiotic|freaking|\btwit\b|moronic|suck\s*m.\b|suck\s*you|' . 'go\s*to\s*hell|really suck|my\s+dick\b|\beat\s+m[ey]\b'; /$profanity/io && $&; } sub autoformat{ local($_)=@_; s/[ \t]+\n/\n/g; s/\n([A-Z][^a-z\n]{4,})\n/\n<h3>$1<\/h3>\n/g; s/(\n\n)/<p>$1/g; s/(\n )/<br>$1/g; s/<p>\n<br>/<p>\n/g; # do mailtos and web links s/(\W)<?([\w.\-]+\@[\w.\-]+\.[a-z]{2,3})\b>?/$1<a href="mailto:$2">$2<\/a>/gi; s/(\s)(((http:\/\/|www\.)[\w\.\-\?\&\+\%\/]+)|([\w\.\-\?\&\+\%\/]{6,}\.)(com|net|org))/$1<a href="http:\/\/$2">$2<\/a>/gi; #s/\b([\w\.\-\?\&\+\%\/]{6,}\.)(com|net|org)/<a href="http:\/\/$1$2">$1$2<\/a>/gi; s$http://http://$http://$gi; $_; }