: # -*- perl -*- eval 'exec $PERL_CMD -S $0 ${1+"$@"}' if 0; use FindBin; use File::Spec; # # PAL: Perl Augmented Language. # $VERSION= '1.13'; $COMBINE_CONTINUATION= 0; #lines ended with \ printed as it is $prog= &basename($0); ($PROG= $prog)=~ tr/a-z/A-Z/; $PERL = $ENV{PERL_CMD}; if(not defined $PERL) { $PERL= "/usr/perl5/bin/perl"; #path for perl5; site dependent # warn "WARNING: BW_PERL not defined, using $PERL.\n"; } $BASE= "$FindBin::Bin/.."; #released path $RUNTIME= "${PROG}_runtime.pl"; if ($^O eq 'solaris') { $INCLUDE_CMD= "$FindBin::Bin/include"; } if ($^O eq 'linux') { $INCLUDE_CMD= "$FindBin::Bin/include.linux"; } $OUTPUT_DIR= "."; # default output directory $,= ' '; $USER= $ENV{'USER'} || getlogin() || (getpwuid($<))[0] ; @ARGV_save= @ARGV; & initialize(); #may change BASE if(! $QUIET) { # $cmd= "echo \"`date +%m/%d/%y:%H`: $prog @ARGV\" >> $BASE/Log/$USER"; # $cmd.= "; chmod 660 $BASE/Log/$USER" ; # system( $cmd ); } #Run cpp on the input file to expand #includes and __LINE__. #The reason we can't use the perl option that runs cpp before running perl #is because after running cpp, we have to do some massaging on output file. ### process only '#inc' as include directive : if(1) { #direct pipe. $cmd= "$INCLUDE_CMD -i '#inc' -pal $include_string $infile "; open(PP_FILE, " $cmd |") or die "Can't open pipe from '$cmd' $!\n"; #preprocessed file as input }else{ #write to a file first. $cmd= "$INCLUDE_CMD -i '#inc' -pal $include_string $infile > $infile_pp"; & EXIT2(1, $cmd) if( system("$cmd") ) ; open(PP_FILE, "< $infile_pp") or die "Can't open '$infile_pp' $!\n"; #preprocessed file as input } open(PL_FILE, "> $infile_pl") or die "Can't write '$infile_pl' $!\n"; #translated (perl) output print PL_FILE "#! $PERL \n"; #make perl code executable print PL_FILE "# Translated Perl code from '$0 @ARGV_save'\n\n"; for($i= 0; $i< @INCLUDE; $i++) { print PL_FILE "unshift(\@INC, '$INCLUDE[$i]');\n"; } print PL_FILE "srand($SEED);\n" if($SEED); print PL_FILE "\$BASE= '$BASE';\n"; print PL_FILE "use lib '$FindBin::Bin/../lib';\n"; print PL_FILE "require \'$RUNTIME';\n"; & LINES_TO_PERL (); close(PP_FILE); close(PL_FILE); chmod(0750, $infile_pl); if($keep_tmpFile != 2) { if ( $outputFile ) { $attach= " > $outputFile" if($outputFile); # Make sure current dir is writable, since we'll be generating temp files. & EXIT2(1, "Output directory '$OUTPUT_DIR' must be writable") if(! -w $OUTPUT_DIR); } # print STDERR "execute: $infile_pl @ARGV $attach \n"; if( system("$PERL $infile_pl @ARGV $attach") ) { &EXIT2(1, "Can't execute $infile_pl @ARGV $attach"); } } &cleanup(); ################################################################################ # initialize & process cmd-line arguments ################################################################################ sub process_cmdline { my($PERLOPTIONS) = ''; my $ofile; while(substr($ARGV[0],0,1) eq '-' || $ARGV[0]=~ /^([A-Za-z_]\w*=)(.*)/) { my($arg)= shift(@ARGV); # [Viranjit 11/21/03] if ( $arg =~ /^(-\S+)=(.+)/ ) { # handle -= $arg = $1; # convert to - unshift @ARGV, $2; } if( substr($arg,0,1) ne '-') { #set var from cmd-line $EVAL_STR .= "\$$1$2;\n"; # process "foo= bar" }elsif($arg eq '-base') { #change base to non-default place $BASE= shift(@ARGV); # for experimenting new version. }elsif($arg eq '-h' || $arg eq '-help') { & EXIT(0); }elsif($arg eq '-H' || $arg eq '-HELP') { & EXIT(0); # & INFO(); exit(0); }elsif($arg eq '-I') { @INCLUDE= (@INCLUDE, shift(@ARGV)); }elsif($arg eq '-k' || $arg eq '-keep') { $keep_tmpFile= 1; }elsif($arg eq '-ko' || $arg eq '-keeponly') { $keep_tmpFile= 2; }elsif($arg eq '-o') { $outputFile= shift(@ARGV); #user-given output file (undef, $OUTPUT_DIR, $ofile) = File::Spec->splitpath( $outputFile ); $OUTPUT_DIR = "." if $OUTPUT_DIR eq ""; }elsif($arg eq '-q' || $arg eq '-quiet') { $QUIET= 1; }elsif($arg eq '-R' || $arg eq '-REVERSE') { $REVERSE= shift(@ARGV); #user-def reverse char }elsif($arg eq '-r' || $arg eq '-reverse') { $REVERSE= "\\\."; #default reverse char: '.' }elsif($arg eq '-s' || $arg eq '-seed') { $SEED= shift(@ARGV); #set random seed }elsif($arg eq '-w') { $PERLOPTIONS .= ' -w'; }elsif($arg eq '-perl') { my($newperl)= shift(@ARGV); if (-x $newperl) { $PERL = $newperl; } } } $PERL .= $PERLOPTIONS if ($PERLOPTIONS ne ''); } sub EXIT2 { & EXIT(@_, 'NoUsage'); } sub EXIT { my($errCode, $errStr, $NoUsage)= @_; print STDERR "$PROG ERR (line $.): $errStr\n" if($errStr); & usage() if(! $NoUsage); & cleanup(); exit($errCode); } sub initialize { #reset all control variables : @INCLUDE= (); $REVERSE= ''; #default: no reverse mode & EXIT(1) if($#ARGV == -1); & process_cmdline(); #process argv before input file & EXIT(0, "Missing input file") if($#ARGV < 0); $infile= shift(@ARGV); my($name)= &basename($infile); $infile_pp= "/usr/tmp/$name.$$.pp"; #after preprocess $infile_pl= "/usr/tmp/$name.$$.pl"; #after xlating to perl ## & process_cmdline() if($#ARGV >= 0); #after input file # & EXIT(1, "Cmd-Line error") if($#ARGV >= 0) ; # Check suffix of input file and make sure it exists. if($infile !~ /\.[^\.]*(pal|pm|tg)$/i && #no .pal|.pm|.tg suffix, and ! $REVERSE) { # not start w/ reverse mode & EXIT2(1, "$infile must be ended with '.*(pal|pm|tg)'"); } & EXIT2(1, "$infile does not exist") if(! -r $infile); # Make sure include directories exist. for($i= 0; $i < @INCLUDE; $i++) { if(! -d $INCLUDE[$i]) { & EXIT2(1, "Directory $INCLUDE[$i] does not exist"); }else{ $include_string = $include_string . " -I $INCLUDE[$i]"; } } } sub LINES_TO_PERL { #translate all lines to perl my($REVERSE_save); $curr_linenum= 0; $REVERSE_save= $REVERSE; $INIT= 1; $line= ''; $currLineType= ''; while() { #read input file, and do some filtering if(/^# line (\d+) (.*)/) { $curr_linenum= $1 - 1; # -1 because the line itself is following $curr_file= $2; print PL_FILE $_; next; }else{ ++ $curr_linenum; } if(/^$REVERSE#+\s*(END_INIT|ENDINIT)/ && $INIT) { # put "foo=bar" after #END_INIT s/^$REVERSE//; print PL_FILE "$_"; print PL_FILE $EVAL_STR; $INIT= 0; next; } if($line ne '') { #this is a continued line: strip its prefix if( $currLineType ne &lineType($_) ) { &EXIT2(1, "prefix of continued line doesn't match previous line"); } s/^://; s/^$REVERSE// if($REVERSE ne ''); } if($COMBINE_CONTINUATION==1 && s/\\\s*$// ) { #line ended w/ \, cat to previous line $currLineType= &lineType($_) if(! $currLineType); $line.= $_; next; }elsif($COMBINE_CONTINUATION==2 && ((! /#define/) && s/\\\s*$/\n/) ) { #ended w/ \, and not #define $currLineType= &lineType($_) if(! $currLineType); $line.= $_; next; } $line.= $_; #concate w/ potential previous lines $line_save= $line; & line_to_perl(*line); #change :-lines to perl print stmt if($line_save ne $line) { $line=~ s/\n(.)/\n# line $curr_linenum $curr_file\n$1/g; # print PL_FILE "# line $curr_linenum $curr_file\n" if($line =~ /\n./); } print PL_FILE "$line"; $line= ''; #reset only after a 'line' is complete $currLineType= ''; } } sub lineType { my($line)= @_; my($prefix)= substr($line,0,1); my($typ)= ($prefix eq ':') && ($MODE eq 'PLAIN' || $REVERSE eq '') ? ':' : ($prefix eq $REVERSE) && ($REVERSE ne '') ? $REVERSE : 'x' ; $typ; } # # Massage the cpp output file to # replace lines beginning with ":" with print statements # replace single quote with backslash quote # replace '\n' with '\\n' # massage some of the spacing. sub line_to_perl { #translate 1 line to perl stmt local(*line) = @_; my($print_linenum)= 1; my($i); if($MODE eq 'PLAIN') { #===> complete_as_is (plain) TEXT mode: # if($line =~ s/^[ \t]*://) { #text stuff if($line =~ s/^://) { #text stuff $line= & PASS_AS_IS( $line ); }elsif($REVERSE ne '' && $line =~ s/^$REVERSE//) { #perl stmt & check_mode_switch(*line); # }elsif($line =~ /^#/) { #cpp-generated stuff: pass # ; # unchanged as perl comment }elsif($line =~ s/^\\#/#/) { #text escaped comment: put back $line= & pass_as_is( $line ) ; #plain text }else{ $line= & pass_as_is( $line ) ; } #plain text }elsif($REVESE ne ';' && $line =~ s/^;//) { #===> complete_as_is TEXT mode: ## ';' in first column: NOT even perl variable will be evaluated ## Note that: perl variables still evaluated in ordinary TEXT mode $line= & pass_as_is( $line ) ; }elsif($REVERSE eq '') { #==> PERL mode: text needs prefix w/ ':' if($line =~ s/^://) { #rm text-prefix up to ':' $line= & PASS_AS_IS( $line ); #text }else{ & check_mode_switch(*line); #perl stmt } }else { #==> TEXT mode: perl code prefixed w/ $REVERSE if($line =~ s/^$REVERSE//) { #perl stmt: remove prefix & check_mode_switch(*line); # }elsif($line =~ /^\s*#/) { #cpp-generated stuff: pass # ; # unchanged as perl comment }elsif($line =~ s/^\\#/#/) { #text escaped comment: put back $line= & PASS_AS_IS( $line ) ; #AS_IS line }else{ $line= & PASS_AS_IS( $line ) ; #AS_IS line } } } sub check_mode_switch { #mode-switch command: start_perl, and local(*line)= @_; # start_text[(reverse_string)] if($line=~ /^\s*#/) { #comment at the begin: ; }elsif($line=~ /^\s*start_plain/) { #switch to pure text mode $MODE= 'PLAIN'; $line= ''; #nullify the line }elsif($line=~ /^\s*start_perl/) { #switch to perl mode $REVERSE_save= $REVERSE; #save prev REVERSE char $REVERSE= ''; #clear REVERSE $MODE= ''; $line= ''; #nullify the line }elsif($line=~ s/^\s*start_text//) { if($line=~ s/\s*\((.*)\)//) { #switch to text mode $REVERSE= "$1"; #use specified $REVERSE }elsif($REVERSE_save ne '') { $REVERSE= $REVERSE_save; #use prev $REVERSE }else{ $REVERSE= "\\\."; #use default $REVERSE } $line= ''; #nullify the line $MODE= ''; }else{ my($prefix_stmt)= & proc_SELECTION(*line); $line= $prefix_stmt . $line; } $line; } sub pass_as_is { #COMPLETELY as is: nothing will be evaluated my($line)= @_ ; $line =~ s/\n$//; # get rid of \n, if any. $line =~ s/\\/\\\\/g; # change \ to \\; to print as \ $line =~ s/'/\\'/g; # replace quote w/ 'backslash quote' #$line = "print \"\\n\", \'$line\';\n"; #enclose $line w/ ': no escaped needed $line = "print \'$line\', \"\\n\";\n"; #enclose $line w/ ', so no escaped needed } sub PASS_AS_IS { #everything EXCEPT PERL $ variables appear as is local($line)= @_; #perl variable is evaluated to its value; #so only $ need be escaped by programmer. $line=~ s/\n$//; # get rid of \n my($prefix_stmt)= & proc_SELECTION(*line, 1); ### only '\' and " need be escaped !! $line =~ s/\\/\\\\/g; # change \ to \\ for printing as \ $line =~ s/"/\\"/g; # change " to \" for printing as " ### preseve $ as $; so when printed, it is perl variable. ### preseve \$ as \$; so when printed, it is '$' . {...}. ### preseve $$ as $$; so when printed, it is process id. $line =~ s/\\\\([\[\$\@\]])/\\$1/g; # put \\$ back to \$; to print as $ #$line = $prefix_stmt . "print \"\\n$line\";\n"; $line = $prefix_stmt . "print \"$line\\n\";\n"; } #------------------- [[....]] is selection list which randomly choose element #------------------- [e[...]] is enumeration list which choose elements in order #------------------- [l[...]] return the number of elements in the list sub proc_SELECTION { #process selection list [e?[...]] local(*string, $func_sub)= @_; #string is either text or perl stmt. my($list, $cmd); #list is stuff within [e?[ and ]] my($sel_stmt, $fun_stmt); my($acc); $acc= ''; ########## selection list replacement: while( 1 ) { ###--replace next [..[..]] to a $variable last if($string !~ /\[([\w ,:]*)\[([^\]]*)\]\]/) ; ########### [ cmd [ .list. ] ] ++ $list_idx; #GLOBAL: increment after done with it $acc .= $` . "\$\{_PARAM$list_idx\}"; #become a variable $string = $'; #process rest later $cmd= $1; $list= "$2"; $list=~ s/([^\\])"/$1\\"/g; # escape non-escaped " $list=~ s/^"/\\"/; $list=~ s/\n//g; # remove all new-line char my($ln)= $curr_linenum - 1; ##--- $_PARAMn is delay-evaluated until the last run, where all ##----- $perl variables in [[..]] list are evaluated else where. $sel_stmt .= "\$_PARAM$list_idx= &proc_SEL($list_idx, \"[$list]\", \"$cmd\", \"$curr_file:$ln\");\n"; } $string= $acc . $string; $acc= ''; ########## function call replacement in 'text string': if( $func_sub ) { while(1) { last if($string !~ /(.)?\&\s*([a-zA-Z_]\w*\s*\([^\)]*\))/ ); ### & ---funcName-- ( ..... ) $match= $&; if($1 eq '\\') { $string= $'; #set before another substitute. $acc .= $`; $match =~ s/^.//; #un-escape \& to &. $acc .= $match; next; } ++ $func_idx; $acc .= $` . "$1\$\{_RETURN$func_idx\}"; $string = $'; #remaining part $fun_stmt .= "\$_RETURN$func_idx= & $2;\n"; } } # $fun_stmt=~ s/\\"/"/g; #un-escape \" # $fun_stmt=~ s/\\\\/\\/g; #un-escape \\ $string= "$acc" . "$string"; # substitute orignal stmt $sel_stmt . $fun_stmt; #### return prefix stmt: proc_SEL() + func-call } ################################################################################ # cleanup ################################################################################ sub cleanup { # remove .pp and .pl files when no -k option if($keep_tmpFile) { my($targ)= &basename($infile_pl); $targ=~ s/$$\.//; $targ= File::Spec->catfile( $OUTPUT_DIR, $targ) if $OUTPUT_DIR ne "."; system("mv $infile_pl $targ"); }else{ unlink($infile_pp) if(-f $infile_pp); unlink($infile_pl) if(-f $infile_pl); } } ################################################################################ # usage and INFO ################################################################################ sub usage { my(@version)= split(' ', $VERSION); print < add to search path for #includes. -k(eep) keep temporary files after run. -ko|-keeponly generate temporary files and exit. -o output assembly language to . -perl Change the default perl version use to . -r(everse) reverse to TEXT mode by treating lines prefixed w/ '.' as perl stmt, the rest are output unchanged. -R '{prefix}' same as -r except perl-prefix set to {prefix}; char special to regular expression need be escaped. -s(eed) {number} set random number seed by calling 'srand({number})'. '$PROG', Perl extended Language, is a macro language based on Perl. Version: 1.00. EOF # -H(ELP) more info about $PROG extension: reverse mode, # string/number selection/enumeration, etc. #end of print <