#!/usr/local/bin/perl5 # rename me to ill-to-aol.pl # script for grinding Illustra WebBlade templates into AOLserver # *.tcl URLs $input_dir = '/local/home/philg/preperl/'; $output_dir = '/web/raw/'; # preload the runt database of "what to do with those MIEXECs?" open(EXECMAPFILE,"<$input_dir"."exec_map.text"); while () { chop; ($key,$full_unix_path,$replace_with_function_call_instead_p)=split(/UNIXSUCKSROCKS/); $exec_map_full_unix_path{$key} = $full_unix_path; $exec_map_replace_with_function_call_instead_p{$key} = $replace_with_function_call_instead_p; } close(EXECMAPFILE); opendir(DIRHANDLE,$input_dir) || die "Error opening $input_dir"; # we only want the *.tcl files @infiles = grep /^.*\.tcl/, readdir(DIRHANDLE); closedir(DIRHANDLE); # || die "Error closing $input_dir"; foreach $filename (@infiles) { $input_filename = $input_dir.$filename; $original = ""; if( !open(ORIGINAL, "<$input_filename") ){ print "Couldn't open $input_filename\n"; return; } while () { $original .= $_; } close (ORIGINAL); # the entire file is now in $original # let's stuff $original into $_ so that we can use shorthand $_ = $original; # now we apply the knowledge base! # tricks used: # 1) *? for minimal rather than maximal matching # 2) [\000-\377]* to match across newlines # 3) all the string quotes that we generate, we actually write as # replacemewithaquote then at the very end we replace all the string # string quotes that are left with \" and then finally we replace # /replacemewithaquote/"/g # just kill the simple mivars s/<\?mivar>(.*?)<\?\/mivar>/$1/sgi; # kill the transaction crud; AOLserver doesn't shove a whole # page into a transaction block s/<\?misql sql\s*=\s*"set transaction isolation level read uncommitted;"><\?\/misql>//gi; # we want to replace # $1 with # [database_to_tcl_string $db "query"] (note lack of semicolon) s/<\?misql sql="([^;]*);">\s*\$1\s*<\?\/misql>/[database_to_tcl_string \$db replacemewithaquote\1replacemewithaquote]/gi; # look first for DML statements # # s/<\?misql\s* sql\s*=\s*"((?:insert|update)[^;]*);"\s*>\s*<\?\/misql>/ns_db dml \$db replacemewithaquote\1replacemewithaquote/gi; # # must necessarily be called for effect, i.e., binding $1, $2 s/<\?misql\s+sql\s*=\s*"([^;]*);"\s*>\s*<\?\/misql>/set selection [ns_db 1row \$db replacemewithaquote\1replacemewithaquote]/gi; # *** stuff *** # we probably also want to convert to a getrow loop s/<\?misql sql="([^;]*);">(.*?)<\?\/misql>/set selection [ns_db select \$db replacemewithaquote\1replacemewithaquote]\nwhile {[ns_db getrow \$selection]} {\n set_variables_after_query \n\n \2\n }/gsi; s/\$\(SETVAR,\$(.*?),\$([0-9])\)/set \1 [jd_ns_set_value \$selection \2]/gi; s/\$\(SETVAR,\$(.*?),(.*?)\)/set \1 \2/gi; # our REGEXPs for conditionals can't handle ">" so we replace them s/\$\(>=/\$\(GE/g; s/\$\(>/\$\(GT/g; # simple conditional MIVARs $_ = &fixup_conditional_mivars($_); # simple SETQs of stuff from the DB, we have to use jd_ns_set_value instead of # ns_set value because ns_set value is 0-based s/<\?mivar name=([^>]*)>\s*\$([0-9]+)\s*<\?\/mivar>/set \1 [jd_ns_set_value \$selection \2]/gi; # simpler SETQs s/<\?mivar\s+name\s*=\s*"*([^">]*)"*>(.*?)<\?\/mivar>/set \1 replacemewithaquote\2replacemewithaquote/gi; # stuff that is conditional on variable existence s/<\?mivar\s* cond=\$\(NXST,\s*\$([^\)]*)\)>([\000-\377]*?)<\?\/mivar>/replacemewithaquote\n\nif { \$\1 == replacemewithaquotereplacemewithaquote } {\n ns_write \$conn replacemewithaquote\2replacemewithaquote\n}\nns_write \$conn replacemewithaquote/gi; # these pages point to each each using MIval ... but we need them to point to foobar.tcl # needs to be # # do the ones without more args first (no ampersand) s///gi; # now with args s///gi; # webExplode is a special tag; it is basically because the WebBlade # is too feeble to issue a redirect s/<\?webExplode_tag\s* ID="*(.*?)"*\s* varName="*(.*?)"*\s* varVal="*(.*?)"*>/ns_returnredirect \$conn replacemewithaquote\1.tcl?[ns_urlencode replacemewithaquote\2replacemewithaquote]=[ns_urlencode replacemewithaquote\3replacemewithaquote]replacemewithaquote\nreturn 1/gi; # let's work on FORMs that have their target in a hidden variable # top looks like
# then somewhere there is a # then somewhere there is a
# we want
...
# we use single-line mode (/s) so that . will match newlines # we use /x so that we can have comments; whitespace is ignored s/ # opening of the form, \1 and \2 (.*?) # random stuff, \3 ]*?name\s*=\s*"*mival"*.*?value\s*=\s*"*(.*?)"*> # get the real target, \4 (.*?) # more stuff, \5 <\/form> /\3\5<\/form>/isgx; # let's work on those MIEXECs, most of which are required because the Web Blade # can't do procedural stuff, a lot of them will be replaced by regular Tcl # function calls, ones that are too hard to convert (as spec'd in the exec_map.text # file, third parameter) will be turned into Tcl EXECs $_ = &fixup_miexecs($_); $_ = &fixup_miblocks($_); # stuff that is extremely JobDirect-specific s/]*?)>//gi; # chk_xstVar_tag sets a default value and double apostrophes for already set vars s/<\?chk_xstVar_tag\s+vName="*(.*?)"*\s+val="*(.*?)"*>/if { ![info exists \1] } { set \1 replacemewithaquote\2replacemewithaquote } \n set \1 [DoubleApos \$\1] /gi; # let's go to work on all those little tags s/<\?sel_stud_addr_tag uoid="\$uoid">/[sel_stud_addr_tag \$uoid]/gi; s/<\?bookctr_bgcolor_tag type=\$type>/[bookctr_bgcolor_tag \$type]/gi; # tags with no args for direct translation s/<\?jdir_bgcolor_tag>/[jdir_bgcolor_tag]/gi; s/<\?copyright_tag>/[copyright_tag]/gi; # tags we're just going to kill s/<\?cache_status>//gi; # we don't need to worry about sync because AOLserver won't deadlock s/<\?sync_lock>//gi; s/<\?db_clean_tag>//gi; s/"/\\"/g; # all the quotes that we put in, we didn't want backslashed s/replacemewithaquote/"/g; # kill off null ns_writes that can get generated s/ns_write \$conn "\s*"//g; $output_filename = $output_dir.$filename; open(MODIFIED, ">$output_filename"); print MODIFIED "set_form_variables\n"; print MODIFIED "set_form_variables_string_trim_DoubleAposQQ\n\n"; print MODIFIED "ReturnHeaders \$conn\n\n"; print MODIFIED "set db [ns_db gethandle]\n\n"; print MODIFIED $_; close (MODIFIED); } ##### helpers # helper stuff to parse conditionals (prefix -> infix) this # conditional parsing stuff doesn't work very well; you may want to # redefine it to just return the test clause and do the conditionals # manually sub parse_cond_str{ # this sub recursively parses a web blade conditional expression and # constructs a Tcl if statement as its return value local($cond_str) = @_; local($ret_str, %tcl_ops, $tcl_op, $tcl_arg_1, $tcl_arg_2, $arg_1, $arg_2, $op); #define the assoc array between tcl ops and illustra ops %tcl_ops = ("XST", '!= replacemewithaquotereplacemewithaquote', "NXST", '== replacemewithaquotereplacemewithaquote', "AND", '&&', "OR", '||', "NOT", '!', # both of the case-insensitive ops "EQ", "==", # have string-to-uppers placed around "NE", '!=', # their args within this sub "EC", '==', # case-insensitive string equal "NC", '!=', # case-insensitive string not equal "GE", '>=', "LE", '<=', "GT", '>', "LT", '<', "=", '=='); #there's really no need for any whitespace-- trash all of it $cond_str =~ s/\s//g; #turn all "'s into replacemewithaquote $cond_str =~ s/\"/replacemewithaquote/g; # is it a compound clause? if so, parse the args recursively # all compound clauses are of the form $(op, arg1{, arg2}) if ($cond_str =~ /^\$\((.*?),(.*)/s) { #get the op $op = $1; $op =~ tr/a-z/A-Z/; # uppercase it # look up the operation in the array; # if not found, pass it through $tcl_op = $tcl_ops{$op} || $op; # print "Parsing $cond_str, found op: \"$op\"\n"; unless ( $tcl_ops{$op} ) { print "using operator $op\n"; } # deal with the args # remove the $(, $op and the closing right paren $cond_str =~ s/^\$\($op,//i; # get rid of $(op $cond_str =~ s/\)$//; # get rid of closing right paren # how many & what type of args do we have? # we distinguish three patterns for a compound expr: # 1: two args, with the first being a parenthesized expr # [either $( or just (] # 2: two args, and the first is not a paren'd expr # 3: one arg # the distinction between 1 & 2 is not strictly necessary, # but it does make the regexps cleaner to read if ($cond_str =~ /^(\$*\(.*\)),(.*)/s){ # then two args, first is paren'd $arg_1 = $1; $arg_2 = $2; $tcl_arg_1 = &parse_cond_str($arg_1); # recurse $tcl_arg_2 = &parse_cond_str($arg_2); if ($op eq "EC" || $op eq "NC") { $tcl_arg_1 = "[string toupper ".$tcl_arg_1."]"; $tcl_arg_2 = "[string toupper ".$tcl_arg_2."]"; } $ret_str = "($tcl_arg_1 $tcl_op $tcl_arg_2)"; } elsif ($cond_str =~ /^([^\(][^\(].*),(.*)/s){ # then two args, first not paren'd $arg_1 = $1; $arg_2 = $2; $tcl_arg_1 = &parse_cond_str($arg_1); #recurse $tcl_arg_2 = &parse_cond_str($arg_2); if ($op eq "EC" || $op eq "NC") { $tcl_arg_1 = "[string toupper ".$tcl_arg_1."]"; $tcl_arg_2 = "[string toupper ".$tcl_arg_2."]"; } $ret_str = "($tcl_arg_1 $tcl_op $tcl_arg_2)"; } else { # it must be one arg $arg_1 = $cond_str; $tcl_arg_1 = &parse_cond_str($arg_1); # recurse # the only case we want a prefix'd op is ! if ($tcl_op eq "!") { $ret_str = "($tcl_op$tcl_arg_1)"; } else { $ret_str = "($tcl_arg_1 $tcl_op)"; } } } # if it's not compound, it must be an atomic expression. return it else { $ret_str = &make_tcl_arg($cond_str); } #return whatever $ret_str was constructed #print "Returning \"$ret_str\" from parse_cond\n"; return $ret_str; } sub make_tcl_arg{ # strictly speaking, this sub isn't necessary, but it does prevent # unsightly paren buildup if the original file used them when not vital local($arg) = @_; local($retval); # if it's enclosed in just parens, return the inside part if($arg =~ /^\(.*\)$/s){ $retval = $1; } else{ $retval = $arg; } return $retval; } sub fixup_miexecs { local($_) = @_; # we take a big string in and output a big string local($stuff_before, $stuff, $args, $stuff_after, $function_key, $cond, $name, $tcl_test_clause, $replacement_tcl, $full_unix_path); while ( m/<\?miexec(.*?)>(.*?)<\?\/miexec>/six ) { # reset all the loop vars so ( $cond ne "" ) doesn't hit from last iteration ($stuff_before, $stuff, $args, $stuff_after, $function_key, $cond, $name, $tcl_test_clause, $replacement_tcl, $full_unix_path) = (); # there is an MIEXEC # preserve magic values from first REGEXP $stuff_before = $`; $stuff = $&; $args = $2; $stuff_after = $'; # reset local variables for each loop # let's look for the key (function name) if ( $stuff =~ m/execute\s*=\s*"*([^"\s>]*)/si ) { $function_key = $1; } else { print "Warning: could not find execute key for MIEXEC in $filename, using DEFAULT\n"; $function_key = "DEFAULT"; } # let's look for a conditional if ( $stuff =~ m/cond\s*=\s*"*(\$\(.*\))/si ) { print "Found conditional in MIEXEC in $filename: \"$1\"\n"; $cond = $1; } # let's look for a name (variable to set, chop the dollar sign off) # Note: dollar sign is apparently optional if ( $stuff =~ m/name\s*=\s*"*\$*([^"\s>]*)/si ) { $name = $1; } $replacement_tcl = ""; if ( $cond ne "" ) { # parse prefix to Tcl infix $tcl_test_clause = &parse_cond_str($cond); $replacement_tcl = "if { $tcl_test_clause } { \n"; } if ( $name ne "" ) { # we're setting a var $replacement_tcl .= "set $name "; } # this is the meat where we decide to do a Tcl function call or what if ( $exec_map_replace_with_function_call_instead_p{$function_key} == 1 ) { $replacement_tcl .= "[$function_key $args]"; } else { # we really are doing an exec (bleah!) $full_unix_path = $exec_map_full_unix_path{$function_key}; $replacement_tcl .= "[exec --keepnewline $full_unix_path $args]"; } if ( $cond ne "" ) { # match the brace that we opened $replacement_tcl .= "\n}" } $_ = $stuff_before.$replacement_tcl.$stuff_after; } return $_; } sub fixup_conditional_mivars { local($_) = @_; # we take a big string in and output a big string local($stuff_before, $stuff, $then_clause, $stuff_after, $cond, $name, $tcl_test_clause,$other_tags, $replacement_tcl); while ( m/<\?mivar[^>]*?cond\s*=\s*"*(\$\([^>]*\)).*?>(.*?)<\?\/mivar>/si ) { ($stuff_before, $stuff, $then_clause, $stuff_after, $cond, $name, $comment, $other_tags, $tcl_test_clause, $replacement_tcl) = (); $cond = $1; $tcl_test_clause = &parse_cond_str($cond); $stuff_before = $`; $stuff = $&; $then_clause = $2; $stuff_after = $'; # print "cond_mivars working on $stuff: # cond = $cond # other_tags = $other_tags # then_clause = $then_clause # "; # let's look for a name (variable to set, chop the dollar sign off) # Note: dollar sign is apparently optional if ( $stuff =~ m/name\s*=\s*"*\$*([^"\s>]*)/si ) { $name = $1; } $stuff =~ s/\n/ /g; # kill the newlines because it will be a Tcl comment $stuff =~ s/mivar/iwasanmivar/gi; # replace "mivar" with "iwasanmivar" so we don't infinitely recurse $comment = "\# replacement for $stuff \n"; if ( $name eq "" ) { $replacement_tcl = "if { $tcl_test_clause } { \n ns_write \$conn replacemewithaquote${then_clause}replacemewithaquote \n}"; } else { $replacement_tcl = "if { $tcl_test_clause } { \n set $name replacemewithaquote${then_clause}replacemewithaquote \n}"; } if ( $stuff =~ m/(default|delimit|replace|separate|err)/ ) { $_ = $stuff_before.$comment.$replacement_tcl.$stuff_after; } else { # nothing fancy; no comment $_ = $stuff_before.$replacement_tcl.$stuff_after; } } return $_; } sub fixup_miblocks { local($_) = @_; # we take a big string in and output a big string local($stuff_before, $stuff, $then_clause, $stuff_after, $cond, $tcl_test_clause, $replacement_tcl); while ( m/<\?miblock\s+cond\s*=\s*"*(\$\([^>]*\)).*?>(.*?)<\?\/miblock>/si ) { ($stuff_before, $stuff, $then_clause, $stuff_after, $cond, $name, $comment, $other_tags, $tcl_test_clause, $replacement_tcl) = (); $cond = $1; $tcl_test_clause = &parse_cond_str($cond); $stuff_before = $`; $stuff = $&; $then_clause = $2; $stuff_after = $'; $replacement_tcl = "\nif { $tcl_test_clause } { \n $then_clause \n}"; $_ = $stuff_before.$replacement_tcl.$stuff_after; } return $_; }