#!/usr/bin/perl # # obfuscada.pl - Ada source code obfuscator # # Usage: # perl obfuscada.pl [srcdir] # Reads all Ada files from srcdir and writes obfuscated copies to the # current working dir. # # Additionally, a file "map.txt" is created which contains the map of # source file names to obfuscated file names and of the identifiers in # all files processed to their obfuscated names: # * A source file map entry begins with "CU" followed by the original # filename and then the obfuscated filename. # * An identifier map entry begins with "ID" followed by the original # identifier and then the obfuscated identifier. # This file is only for reference by humans, it is not used as an input # to the obfuscation process. # # $Log: obfuscada.pl,v $ # Revision 1.4 2018/06/11 11:42:50 okellogg # In sub parse_block add handling of 'exit when'. # # Revision 1.3 2018/06/09 11:01:20 okellogg # In sub parse_block, # - avoid incrementing $indentlevel on printing "null record"; # - in code handling 'package'/'procedure'/'function', # - rename variable $after_end_of_name to $after_end_of_sig; # - change code to skip only the subprogram signature; # - add skipping of function 'return' declaration; # - add handling of subprogram spec ending with "is new", "is null", # or "is abstract". # # Revision 1.2 2018/06/07 04:30:13 okellogg # - New sub mask replaces a string by a run of digits of same length. # - In sub prettytoken, if $lx contains a string then reassign $lx from # call to sub mask to obfuscate it. # We require the string to be longer than 3 characters to simplify # handling operator redefinitions for e.g. "**", "abs", "mod" etc. # which may not be obfuscated. # - In sub parse_block handle procedure/function spec ending with # "is null". # # Revision 1.1 2018/03/10 14:35:54 okellogg # - At @reswd add reserved word 'aliased'. # - New auxiliary global $last_thing_printed helps reduce insertion of # synthetic space in sub emit to the cases when it is indispensible to # separate adjacent tokens. # - In sub prettytoken limit lowercasing of a token to the lookup in %id, # i.e. preserve token case on printing. # # Revision 1.0 2012/08/12 22:34:55 kellogg # - Handle comma separated list of object declarations. # - Recognize protected declaration (not properly indented yet) # # Revision 0.9 2012/08/12 14:53:14 kellogg # Improve fidelity of line numbers in obfuscated code # # Revision 0.8 2012/08/05 22:17:53 kellogg # - Do all obfuscation in the script itself, no longer generate a shell script # to be run afterwards. This means that the files "cmd.sh" and "regexes.txt" # are no longer created. # - Generate a file "map.txt" containing the mapping of original file names # to obfuscated file names, and the mapping of original identifiers to # obfuscated identifiers. # - Currently the original line numbers are not maintained in the obfuscated # source. This is due to the reuse of code from indentada.pl for printing # the obfuscated source, which slightly changes the line numbering. # This will be fixed in the next version. # # Revision 0.7 2012/07/28 12:58:37 kellogg # Extend @do_not_mangle and add a note about its incompleteness. # In sub mangled_name, add the name component onto $result unmangled if # no mangling was performed on it. # Rename sub pkg_mname to unit_mname and rename @packages to @units. # At sub nexttoken, add optional arg $join_compound_name (default: false; # this is set true on processing unit names.) # New sub skip_to_first_of permits skipping to any of multiple given tokens; # skipping ends on encountering the first of the given tokens. # In main program: # - fix iteration over @lex by replacing the "for" loop incrementing $lndx # by a "while" loop employing sub nexttoken # - fix bug in processing of task and protected declarations (the comparison # against 'body' was broken) # - detect keyword "use" so that "use type" is out of the way (otherwise the # type declaration circuitry is erroneously triggered.) # In sub wregex, change search pattern to exclude preceding ' (tic) to avoid # substituting attributes. # In sub unit_mname and main program, change unit prefix to "U". # # Revision 0.6 2012/07/12 19:02:58 kellogg # Avoid "access subprogram" types and redeclarations of builtin functions # # Revision 0.5 2012/07/12 16:52:02 kellogg # Use UniLexer for scanning input files. # Fix grave bugs of previous version. # # Revision 0.4 2012/07/10 20:21:47 kellogg # Support child package specs # # Revision 0.3 2012/07/09 15:48:18 kellogg # sub base36: Change to base34. Exclude 'I' and 'O' from result characters. # # Revision 0.2 2009/06/30 21:42:56 okellogg # Fixed syntax error in generated file regexes.txt. # Added the do_not_mangle list which contains words to be excluded # from the obfuscation. # # Revision 0.1 2008/01/21 20:27:08 okellogg # Initial version. Current limitations: # Only processes package specs. Cannot handle child # packages or separate units. # # # Copyright (C) 2008, Oliver Kellogg # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # use UniLexer; # Extend this list as needed (it is a known weakness that the script # may substitute more than needed: this happens when the application # reuses names already used by the Ada predefined library) @do_not_mangle = qw/ Standard Ada System Interfaces C Fortran Cobol Tags Strings Pointers Index First Last Length Pred Succ Image Value Pos Val Alignment Size Storage_Size Component_Size Address Characters Streams Bounded Unbounded Containers Handling Exceptions Command_Line Numerics Direct_IO Sequential_IO Text_IO Enumeration_IO Fixed_IO Float_IO Integer_IO Modular_IO Floor Ceil Write Read Open Create Close Put Put_Line New_Line Get_Line Get Fore Aft Exp From Item Element Set Source Target Object Name Mode File In_File Out_File Sqrt Log Base Sin Cos Tan Arcsin Arccos Arctan Boolean Character String Integer Natural Positive Short_Integer Long_Integer Float Long_Float Char Short Int Long Double Unsigned Unsigned_Char Unsigned_Short Unsigned_Long Integer_8 Integer_16 Integer_32 Integer_64 Unsigned_8 Unsigned_16 Unsigned_32 Unsigned_64 Shift_Left Shift_Right Pointer Priority External Append Off Maps Mapping Truncation Membership Direction Identity Space Trim_End Left Right Both Error Inside Outside Forward Backward Calendar Time Duration Clock Split Date Year Month Day Hours Seconds Year_Number Month_Number Day_Number Day_Duration /; sub base34 { my $number = shift; # We exclude the letters I and O to avoid confusion with the numbers # 1 and 0. my @char = qw( 0 1 2 3 4 5 6 7 8 9 A B C D E F G H J K L M N P Q R S T U V W X Y Z ); $char[$number]; } sub fourdigits { my $number = shift; my $d1 = int($number / 39304); $number -= $d1 * 39304; my $d2 = int($number / 1156); $number -= $d2 * 1156; my $d3 = int($number / 34); $number -= $d3 * 34; base34($d1) . base34($d2) . base34($d3) . base34($number); } %count = ( 'U' => 0, 'E' => 0, 'O' => 0, 'F' => 0, 'P' => 0, 'T' => 0 ); %id = (); sub push_once { my $name = shift; my $prefix = shift; my $exclude_short_identifiers = 1; if (@_) { $exclude_short_identifiers = shift; } my @components = split(/\./, $name); foreach my $nm (@components) { next if grep(/^${nm}$/i, @do_not_mangle); my $n = lc($nm); next if exists($id{$n}); unless ($exclude_short_identifiers && length($n) < 3) { $id{$n} = $prefix . fourdigits(++$count{$prefix}); } } } sub mangled_name { my($compound_name, $prefix, $exclude_short_identifiers) = @_; unless (defined $exclude_short_identifiers) { $exclude_short_identifiers = 1; } push_once($compound_name, $prefix, $exclude_short_identifiers); my @components = split(/\./, $compound_name); my $first = 1; my $result; foreach my $name (@components) { my $nm = lc($name); if ($first) { $first = 0; } else { $result .= "."; } if (exists $id{$nm}) { $nm = $id{$nm}; } $result .= $nm; } return $result; } sub pkgspecfile { my $unitname = shift; my $stem = mangled_name($unitname, 'U', 0); $stem =~ s/\./-/g; return lc($stem) . ".ads"; } sub pkgbodyfile { my $unitname = shift; my $stem = mangled_name($unitname, 'U', 0); $stem =~ s/\./-/g; return lc($stem) . ".adb"; } @lex = (); # global buffer for return value from UniLexer::lex() $lndx = 0; # global index into @lex # Advance $lndx to the next identifier token sub nexttoken { my $join_compound_name = 0; if (@_) { $join_compound_name = shift; } my $result = ""; while (++$lndx < scalar(@lex)) { my $lx = $lex[$lndx]; next if ($lx =~ /^\d/); # skip numeric literal next if ($lx =~ /^'.'$/); # skip character literal next if ($lx =~ /^"/); # skip string literal if ($lx eq "'") { ++$lndx; # skip attribute name $lx = $lex[$lndx]; next unless ($lx eq "("); } $lx = lc($lx); $result .= $lx; last unless ($join_compound_name and $lx =~ /^[a-z]/ and $lndx < scalar(@lex) - 2 and $lex[$lndx + 1] eq '.' and $lex[$lndx + 2] =~ /^[A-Za-z]/); } return $result; } sub skip_to { my $end = shift; my $nxt; while (($nxt = nexttoken)) { last if ($nxt eq $end); } } sub skip_to_first_of { my @end = @_; my $nxt; OUTER: while (($nxt = nexttoken)) { foreach (@end) { last OUTER if ($nxt eq $_); } } } @reswd = qw( abort abs accept access aliased all and array at begin body case constant declare delay delta digits do else elsif end entry exception exit for function generic goto if in interface is limited loop mod new not null of or others out package pragma private procedure protected raise range record rem renames return reverse select separate subtype tagged task terminate then type until use when while with xor ); %reserved_word = map { $_ => 1 } @reswd; $srcpath = "."; if (@ARGV) { $srcpath = $ARGV[0]; } # Suppress comments in return list from UniLexer::lex() $UniLexer::promote_comments = 0; # Key : output file name after obfuscation # Value: reference to copy of list returned from UniLexer::lex() %tokens = (); # Key : output file name after obfuscation # Value: reference to copy of @UniLexer::linenum %linenums = (); open(MAP, ">map.txt") or die "cannot create file map.txt\n"; while (<$srcpath/*.ad?>) { my $filename = $_; print "Filename: $filename\n"; @lex = UniLexer::lex($filename); @lex or die "an error happened in UniLexer::lex, cannot continue\n"; my $pkgname = $filename; $pkgname =~ s@^.*/@@; $pkgname =~ s/\.ad.$//; $pkgname =~ s/-/./g; push_once($pkgname, 'U', 0); my $outfilename; if ($filename =~ /\.ads$/) { $outfilename = pkgspecfile($pkgname); } else { $outfilename = pkgbodyfile($pkgname); } print " => $outfilename\n"; $filename =~ s/^.*\///; print MAP "CU $filename $outfilename\n"; $lndx = -1; my $lx; while (($lx = nexttoken)) { # print " lex[$lndx] = $lex[$lndx]\n"; my $l = lc($lx); if ($l eq 'package') { if ($lex[$lndx + 1] eq 'body') { $lndx++; nexttoken(1); # name nexttoken; # 'is' if ($lex[$lndx + 1] eq 'separate') { skip_to(';'); } } else { push_once(nexttoken(1), 'U', 0); nexttoken; # skip 'is' } } elsif ($l eq 'procedure') { push_once(nexttoken(1), 'P'); } elsif ($l eq 'function') { my $nxt = nexttoken(1); if ($nxt =~ /^[A-Za-z]/) { # avoid redefinition of builtins, e.g. "+" push_once($nxt, 'F'); } } elsif ($l eq 'type') { push_once(nexttoken, 'T'); my $nxt = nexttoken; if ($nxt eq 'is') { $nxt = nexttoken; if ($nxt eq '(') { while (($nxt = nexttoken)) { last if ($nxt eq ';'); if ($nxt =~ /^[A-Za-z]/) { push_once($nxt, 'E'); } } } elsif ($nxt eq 'access') { # We need to specifically avoid "access subprogram" types # (because of the missing subprogram name) skip_to(';'); } } } elsif ($l eq 'subtype') { push_once(nexttoken, 'T'); skip_to(';'); } elsif ($l eq 'task' || $l eq 'protected') { my $nxt = nexttoken; if ($nxt eq 'body') { skip_to('is'); next; } my $targetlist; $targetlist = ($nxt eq 'type' ? 'T' : 'O'); push_once(nexttoken, $targetlist); nexttoken; # could be: '(' or ';' or 'is' } elsif ($l eq 'entry') { push_once(nexttoken, 'E'); } elsif ($l eq 'use') { # catch "use" so that "use type" is out of the way # (avoids triggering the type declaration circuitry) skip_to(';'); } elsif ($l =~ /^[A-Za-z]/) { next if is_reserved_word($l); my @def_ids = ($l); my $lexindex = ++$lndx; while ($lexindex < scalar(@lex) - 1 && $lex[$lexindex] eq ',') { push @def_ids, $lex[$lexindex + 1]; $lexindex += 2; } if ($lex[$lexindex] eq ':') { foreach (@def_ids) { push_once($_, 'O'); } $lndx = $lexindex + 1; } } } $tokens{$outfilename} = [ @lex ]; $linenums{$outfilename} = [ @UniLexer::linenum ]; } foreach my $name (sort(keys %id)) { my $mangled = $id{$name}; print MAP "ID $name $mangled\n"; } close MAP; $one_indentation = 3; # one indentation measured in spaces $right_border = 117; # column after which to wrap lines $indentlevel = 0; $prindentlevel = 0; # "pretty indent level", used for long RHS expressions # that span multiple lines $line = 1; # output line number $column = 0; # output column of next character that will be printed @linenum = (); # working buffer for current value retrieved from %linenums $at_new_line = 1; $last_thing_printed = ""; sub emit { my $txt = shift; if ($txt eq "\n" && $lndx < scalar(@lex) - 1 && $line >= $linenum[$lndx + 1]) { # newline was printed already if ($last_thing_printed =~ /\w$/) { # Have to print at least one space to separate consecutive # keywords/identifiers $last_thing_printed = ' '; print OUT $last_thing_printed; } return; } print OUT $txt; $last_thing_printed = $txt; $at_new_line = 0; if ($txt =~ /\n/) { $column = 0; if ($txt =~ /\n$/) { $at_new_line = 1; } $txt =~ s/[^\n]//g; $line += length($txt); if ($lndx < scalar(@lex) - 1) { my $nxtline = $linenum[$lndx + 1]; while ($line < $nxtline - 1) { # print OUT "-- ($line < $nxtline)\n"; print OUT "\n"; $last_thing_printed = "\n"; ++$line; } } } else { $column += length($txt); } } sub amount { return $one_indentation * ($indentlevel + $prindentlevel); } sub spaces { return ' ' x amount; } sub dent { emit(spaces . shift); } sub indent { dent shift; $indentlevel++; } sub decr_indentlevel { my $where = shift; if ($indentlevel == 0) { warn "$where (tokenindex $lndx): internal error - negative indentlevel\n"; } else { $indentlevel--; } } sub dedent { my $text = shift; decr_indentlevel("dedent $text"); dent $text; } sub is_reserved_word { my $lx = shift; return (exists $reserved_word{lc($lx)}); } sub mask { # Replace a string by a run of digits of same length. # Example: For the input # "Hello, world." # the following is returned: # "12345, 89012." # The input is expected without surrounding quotation marks and # the output is produced without surrounding quotation marks. my $str = shift; my $ret = ""; for (my $i = 0; $i < length($str); $i++) { my $c = substr($str, $i, 1); if ($c =~ /\w/) { $ret .= ($i + 1) % 10; } else { $ret .= $c; } } return $ret; } sub prettytoken { my $assemble_compound_name = 1; my $lexindex = $lndx; if (@_) { $lexindex = shift; $assemble_compound_name = 0; } my $lx = $lex[$lexindex]; if ($lx =~ /^[A-Za-z]/) { my $lcx = lc($lx); if (exists $id{$lcx}) { $lx = $id{$lcx}; } if ($assemble_compound_name) { # On assembling a compound name, $lndx is modified here. while ($lndx < scalar(@lex) - 2 && $lex[$lndx + 1] eq '.') { ++$lndx; $lx .= '.'; last if ($lndx >= scalar(@lex) - 1 or $lex[$lndx + 1] !~ /^[A-Za-z]/); ++$lndx; my $tok = $lex[$lndx]; $lcx = lc($tok); if (exists $id{$lcx}) { $tok = $id{$lcx}; } $lx .= $tok; } $lexindex = $lndx; } } elsif ($lx =~ /^"([^"]{4,})"/) { $lx = '"' . mask($1) . '"'; } if ($lexindex >= scalar(@lex) - 1) { return $lx; } my $nx = $lex[$lexindex + 1]; if (($lx eq ')' || $lx eq ',' || $lx eq "'" || $lx eq ';') && $line < $linenum[$lexindex]) { # sub emit increments $line (also for embedded newlines) $lx .= "\n" . spaces; } elsif ($lx eq ')' && $nx ne ')' && $nx ne ',' && $nx ne ';' && $nx ne '.') { $lx .= ' '; } elsif ($lx ne "." && $lx ne "'" && $lx ne "(" && $lx ne ")" && $nx ne "." && $nx ne "'" && $nx ne ")" && $nx ne "," && $nx ne ";") { $lx .= ' '; } return $lx; } sub find_closing { my $i = shift; my $stop_on_semi = 0; if (@_) { $stop_on_semi = shift; } my $parenth_level = 0; while ($i < scalar(@lex) - 1) { my $lx = $lex[++$i]; last if ($stop_on_semi && $lx eq ';'); if ($lx eq ')') { last if ($parenth_level == 0); $parenth_level--; } elsif ($lx eq '(') { $parenth_level++; } } return $i; } sub parenth_term { my $lexindex = shift; my $text = $lex[$lexindex]; if ($text ne '(') { return ""; } my $endpos = find_closing($lexindex, 0); for (my $i = $lexindex + 1; $i <= $endpos; $i++) { $text .= prettytoken($i); } return $text; } sub prettyprint { # Leaves $lndx pointing to the last token printed. my $param_decl = 0; if (@_) { $param_decl = shift; } if ($column >= $right_border) { warn("prettyprint: inserting newline at $lndx ($lex[$lndx]) " . "because column exceeds $right_border\n"); emit "\n"; emit spaces; } my $pterm = parenth_term($lndx); my $plen = length($pterm); unless ($plen) { my $text = &prettytoken($lndx); emit $text; return; } my $endindex = find_closing($lndx); $prindentlevel++; if ($param_decl && $lex[$lndx] eq '(') { if ($line < $linenum[$lndx]) { emit "\n"; } my $col = &amount - 1; emit(' ' x $col); } while (1) { emit(prettytoken($lndx)); last if ($lndx >= $endindex); $lndx++; if ($line < $linenum[$lndx]) { emit "\n"; emit spaces; } } $prindentlevel--; } # Values pushed onto @stack in sub parse_block: sub K_BEGIN () { 0 } # only set on 'begin' without preceding 'declare' sub K_WHEN () { 1 } sub parse_block; sub parse_block { my $seen_declare = 1; my $seen_unit = 0; my $seen_case = 0; my $seen_end = 0; my $seen_assignment = 0; my $seen_exception = 0; my @stack = (); for (; $lndx < scalar(@lex); $lndx++) { my $lx = $lex[$lndx]; if ($lx eq ';') { emit ";\n"; if ($seen_end) { emit "\n"; $seen_end = 0; } $seen_assignment = 0; next; } $lx = lc($lx); if ($lx eq 'end') { my $nx = lc($lex[$lndx + 1]); if (@stack && $stack[$#stack] == K_WHEN and $nx !~ /^(if|loop|select)$/) { decr_indentlevel("end case"); pop @stack; } dedent "$lx "; unless ($nx =~ /^(record|if|case|loop|select)$/) { if (@stack && $stack[$#stack] == K_BEGIN) { pop @stack; } else { return 0; } } if ($seen_exception) { # @todo This is far too primitive and does not work in the # presence of blocks nested in the exception handler. $seen_exception = 0; } } elsif ($lx eq 'record' || $lx eq 'loop' || $lx eq 'select') { if ($at_new_line) { emit spaces; } emit "$lx"; if (lc($lex[$lndx - 1]) eq 'end') { if ($lx eq 'record') { $seen_end = 1; } } elsif (not ($lx eq 'record' and lc($lex[$lndx - 1]) eq 'null')) { emit "\n"; $indentlevel++; } } elsif (($lx eq 'then' && lc($lex[$lndx - 1]) ne 'and') || $lx eq 'do') { if ($at_new_line) { emit spaces; } emit "$lx\n"; $indentlevel++; } elsif ($lx eq 'declare') { indent "$lx\n"; $lndx++; parse_block; $seen_end = 1; } elsif ($lx eq 'case') { if (lc($lex[$lndx - 1]) eq 'end') { emit "$lx"; $seen_case = 0; } else { emit spaces; $seen_case = 1; emit "$lx "; } } elsif ($lx eq 'exception' && $lex[$lndx + 1] ne ';') { dedent "$lx\n"; $indentlevel++; $seen_exception = 1; } elsif ($lx eq 'exit' && $lex[$lndx + 1] eq 'when') { emit spaces; while ($lndx < scalar(@lex)) { emit prettytoken($lndx); last if ($lex[$lndx] eq ';'); $lndx++; } emit "\n"; } elsif ($lx eq 'when' && ($seen_case || $seen_exception)) { if (@stack && $stack[$#stack] == K_WHEN) { decr_indentlevel("repeated \"when\""); } else { push @stack, K_WHEN; } emit spaces; $indentlevel++; while ($lndx < scalar(@lex)) { emit prettytoken($lndx); last if ($lex[$lndx] eq '=>'); $lndx++; } emit "\n"; } elsif ($lx eq 'is') { if ($seen_unit || $seen_case) { if ($at_new_line) { emit spaces; } emit "is"; if ($lex[$lndx + 1] eq 'separate') { emit " separate;\n"; $lndx += 2; } else { emit "\n"; $indentlevel++; if ($seen_unit) { $lndx++; parse_block; $seen_end = 1; $seen_unit = 0; } } } else { emit "$lx "; } } elsif ($lx eq 'begin') { if ($seen_declare) { $seen_declare = 0; decr_indentlevel("begin after declare"); } else { push @stack, K_BEGIN; } indent "$lx\n"; } elsif ($lx eq 'elsif') { dedent "$lx "; } elsif ($lx eq 'else' && lc($lex[$lndx - 1]) ne 'or') { dedent "$lx\n"; $indentlevel++; } else { if ($lx eq 'body') { $seen_unit = 1; $seen_declare = 1; } elsif ($lx eq 'package' || $lx eq 'procedure' || $lx eq 'function') { my $after_end_of_sig = $lndx + 2; if ($lex[$after_end_of_sig] eq '(') { while (++$after_end_of_sig < scalar(@lex)) { if ($lex[$after_end_of_sig] eq ')') { ++$after_end_of_sig; last; } } } if ($lex[$after_end_of_sig] eq 'return') { $after_end_of_sig += 2; } unless (lc($lex[$after_end_of_sig]) eq 'is' and lc($lex[$after_end_of_sig + 1]) =~ /^(new|abstract|null|<>)$/) { emit "\n"; dent "$lx "; ++$lndx; if ($lex[$lndx] eq "body") { emit "body "; ++$lndx; } emit prettytoken; if ($lex[$lndx + 1] eq '(') { $lndx++; prettyprint(1); } # Determine whether to set $is_unit - # which shall not be set on specifications. if ($lex[$lndx + 1] eq 'return') { while (++$lndx < scalar(@lex)) { emit(prettytoken($lndx)); my $txt = lc($lex[$lndx + 1]); last if ($txt eq 'is' || $txt eq ';'); } } if ($lex[$lndx + 1] eq 'is') { $seen_unit = 1; } next; } } elsif ($lx eq 'task' || $lx eq 'protected') { emit "\n"; # Determine whether to set $is_unit - # which shall not be set on specifications. my $ndx = $lndx + 1; if ($lex[$ndx] eq 'type') { $ndx++; } ++$ndx; if ($lex[$ndx] eq 'is') { $seen_unit = 1; } } elsif ($lx eq ':=') { $seen_assignment = 1; } if ($at_new_line) { emit spaces; $prindentlevel = 0; } prettyprint; } } } #### Main program #### foreach my $outfilename (keys %tokens) { open(OUT, ">$outfilename") or die "cannot open $outfilename\n"; print "writing $outfilename ...\n"; @lex = @{$tokens{$outfilename}}; @linenum = @{$linenums{$outfilename}}; $lndx = 0; $line = 1; $last_thing_printed = ""; while ($line < $linenum[0]) { print OUT "\n"; ++$line; } $column = 0; $at_new_line = 1; $indentlevel = 0; $prindentlevel = 0; parse_block; while ($lndx + 1 < scalar(@lex)) { emit(prettytoken(++$lndx)); } emit "\n"; close OUT; } print "all done.\n"; 1;