#!/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 (<EXECMAPFILE>) {
    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>) {
        $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
    # <?misql sql="query;">$1<?/misql> 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 
    # <?MISQL SQL="update foobar.."><?/MISQL>
    # <?MISQL SQL="insert foobar.."><?/MISQL>
    s/<\?misql\s* sql\s*=\s*"((?:insert|update)[^;]*);"\s*>\s*<\?\/misql>/ns_db dml \$db replacemewithaquote\1replacemewithaquote/gi;

    # <?MISQL SQL="select foobar.."><?/MISQL>
    # 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;

    # <?MISQL SQL="select foobar..">  *** stuff *** <?/MISQL>
    # 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
    # <A HREF="$WEB_HOME?MIval=resume_work&uoid=$uoid"> needs to be
    # <A HREF="resume_work.tcl?uoid=$uoid">
    # do the ones without more args first (no ampersand)
    s/<A\s* HREF\s*=\s*"(?:\$WEB_HOME)*\?MIval=([^&"]+?)"\s*>/<A HREF="\1.tcl">/gi;
    # now with args
    s/<A\s* HREF\s*=\s*"*(?:\$WEB_HOME)*\?MIval=([^&"]+?)&([^"]+?)"*\s*>/<A HREF="\1.tcl\?\2">/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 <form method=post action=$WEB_HOME>
    # then somewhere there is a <input type=hidden name=MIval value=chk_studLogin>
    # then somewhere there is a </form>
    # we want <form method=post action=chk_studLogin.tcl>...</form>
    # we use single-line mode (/s) so that . will match newlines
    # we use /x so that we can have comments; whitespace is ignored
    s/<form(.*?)action\s*=\s*"*\$WEB_HOME"*(.*?)>               # opening of the form, \1 and \2
      (.*?)                                           # random stuff, \3
      <input[^>]*?name\s*=\s*"*mival"*.*?value\s*=\s*"*(.*?)"*>      # get the real target, \4
      (.*?)                                           # more stuff, \5
      <\/form>
     /<form\1action=\4.tcl\2>\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/<img(.*?)src\s*=\s*"images(.*?)"([^>]*?)>/<img\1src="\/images\2"\3>/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 $_;

}