#!/usr/bin/perl

# Locates and wrapps in modules to build a safeperl version
#
# Doesn't work all that well, but kinda works for some things
#
# This script is licensed under the GPL
#
#      Nick Burch		15/10/03	v0.01

use strict; 

my $file = shift;

my $sfile = shift;
unless($sfile) {
   $sfile = $file;
   $sfile =~ s/.pl$/.safe.pl/;
   if($sfile eq $file) {
      print "Can't see how to name the outfile, must be given\n\n";
      $file = undef;
   }
}

unless($file) {
   print "Usage:\n";
   print "   make-safeperl-version.pl <filename> [outfile]\n";
   exit;
}

unless(-f $file) {
   die("Can't find input file\n");
}
if(-f $sfile) {
#  die("Output file $sfile already present!\n");
}

my %loaded;
$loaded{$file} = 'no';

my $hasunloaded;
my $toload;
my $filecount = 0;

my $header = "";
my $globalvars = "my \$usingsafeperl = 1;\n";
my $mainsection = "";
my $datasection = "";

open OUT, ">$sfile";

do {
  $hasunloaded = 0;
  $toload = "";
  foreach(keys %loaded) {
     if($loaded{$_} eq 'no') {
        $toload = $_;
        $hasunloaded = 1;
     }
  }

  if($toload) {
     open INP, "<$toload";
     print "Processing $toload\n";

     my $doingdata = 0;
     my $doingglobal = 0;

     $filecount++;

     unless($filecount == 1) {
        $mainsection .= "#################################################\n";
        $mainsection .= "## Begin include of $toload\n\n";
        $mainsection .= "\n{\n";
     }

     my $cont = 0;
     my $gcont = 0;
     my $gcontto = "";
     my $lastg = "";
     my $skipdoc = 0;
     my $qwcont = "";
     my $noqwcont = 0;
     while(<INP>) {
        # Check for perldoc
        if($skipdoc) {
           if(/^\=cut/) {
              $skipdoc = 0;
           }
           next;
        }
        if(/^\=head/) { $skipdoc = 1; next; }
        if(/^__DATA__/) { $doingdata = 1; }

	# qw line spanning
	if(/qw\s*\((.*)$/) {
		my $qwline = $1;
		unless($qwline =~ /\;/) {
			$qwcont = $_;
			$noqwcont++;
			chomp $qwcont;
			print "handling spanned 'qw' line:";
			next;
		}
	}
	if($qwcont) {
		$noqwcont++;
		if(/\;/) {
			$_ = $qwcont.$_;
			$qwcont = "";
			$noqwcont = 0;
			print " spanned $noqwcont lines\n";
		} else {
			$qwcont .= $_;
			chomp $qwcont;
			next;
		}
	}

        # Munge usingsafeperl early on
        s/^\s*(my \$usingsafeperl[\=\s].*)$/\# $1/;

        if(/^\s*sub\s/) { $doingglobal = -1; }
        if($filecount == 1 && /^\s*my/) { $doingglobal = -1; }
        if($doingglobal >= 0) {
           my @todo;
           if($gcont) {
              #print "Continuing a global vars line, looking for '$gcontto'\n";
              $globalvars .= $_;
              if(/$gcontto\s*$/) {
                 $gcont = 0;
              }
              next;
           }
           elsif(/^(\s*my .*?)(\;?)\s*$/i) {
              @todo = ($1,$2);
              ($lastg) = ($todo[0] =~ /^\s*my\s+([\$\@\%].*)/);
              $lastg =~ s/^(.*?)\s.*/$1/;
              $lastg =~ s/[\@\%]/\$/;
              $lastg =~ s/\$/\\\$/;
              #print "lastg is '$lastg' vs '$todo[0]'\n";
           }
           elsif($lastg) {
              if(/^(\s*$lastg.*?)(\;?)\s*$/i) {
                 @todo = ($1,$2);
                 #print "Found continued line of '$1'\n";
              } else {
                 #print "Line didn't match '$lastg'\n";
              }
           } else {
              if($lastg) {
                 #print "Didn't find continued line of '$lastg'\n";
              }
              $lastg = "";
           }

           if(@todo) {
              #print "Doing $todo[0]\n";
              unless($todo[1]) { $gcont = 1; $gcontto = ';'; }
              if(/\<\<\s*[\"\'](.*?)[\"\']/) { $gcont = 2; $gcontto = $1; }
              if($doingglobal == 0) {
                 $globalvars .= "# Globals from $toload\n";
              }
              $globalvars .= $_;
              $doingglobal = 1;
              next;
           }
        }
        
        # Skip export and strict statements
        s/^\s*(use strict\;)/\# $1/i;
        s/^\s*(use vars .*\;)/\# $1/i;
        s/^\s*(use Exporter\;)/\# $1/i;
        s/^\s*(require strict\;)/\# $1/i;
        s/^\s*(require vars .*\;)/\# $1/i;
        s/^\s*(require Exporter\;)/\# $1/i;
	s/^\s*(require 5.\d+\;)/\# $1/i;
        s/^\s*(\$VERSION\s?\=.*)/\# $1/i;
        if($cont) {
           s/(.*)/\# $1/;
           if( /\;/ ) { 
              $cont = 0;
           }
        }
        if(/^\s*BEGIN (.*?)(\}?)\s*$/i) {
           unless($2) { $cont = 1; }
           s/(BEGIN .*)/\# $1/i;
        }
        if(/^\s*\@EXPORT (.*?)(\)?\;?)\s*$/i) {
           unless($2) { $cont = 1; }
           s/(\@EXPORT .*)/\# $1/i;
        }
        if(/^\s*\@EXPORT_OK (.*?)(\)?\;?)\s*$/i) {
           unless($2) { $cont = 1; }
           s/(\@EXPORT_OK .*)/\# $1/i;
        }
        if(/^\s*\@ISA (.*?)(\)?\;?)\s*$/i) {
           unless($2) { $cont = 1; }
           s/(\@ISA .*)/\# $1/i;
        }
        if(/^(.*?)\s([\w\d]+)\:\:([\w\d]+\(.*)$/) {
           print "Removing package reference to \"$2\"\n";
           $_ = $1." ".$3;
        }

        # Safeperl "foreach my $foo" not allowed workaround
        if(/^(\s*)(foreach) my (\$[\w\d\_]+)\s(.*)$/i) {
           $_ = $1."my ".$3.";\n";
           $_ .= $1.$2." ".$3." ".$4;
        }
        # Safeperl "scalar caller" not allowed workaround
        s/scalar caller/\"main\"/;
        s/\: caller \}/\: \(\"main\"\) \}/;
        s/\: caller\;/\: \(\"main\"\)\;/;

        # Safeperl sort workaround
        s/([\s\(])sort keys /$1sort_ascii keys /;

        # Skip package
        s/^(package .*)/\# This is $1/;
        s/^1\;\s?//;

        if(/^\s*use (.*?)( .*)?\;/ || /^\s*require (.*?)( .*)?\;/) {
            print "   - $_";
            print " I need to load \"$1\"\n";
            my $lfile = $1;
            $lfile =~ s/\:\:/\//g;
            unless($lfile =~ /\.p.$/) {
               $lfile .= ".pm";
            }
            print " Looking for \"$lfile\"\n";
            if(-f $lfile) {
               unless($loaded{$lfile}) {
                  $loaded{$lfile} = 'no';
               }
               next;
            } else {
                my $found = 0;
                foreach my $dir (@INC) {
                   if(-f $dir."/".$lfile) {
                      unless($loaded{$dir."/".$lfile}) {
                         $loaded{$dir."/".$lfile} = 'no';
                      }
                      $found = 1;
                   }
                }
                unless($found) {
                   die( "Can't find dependency \"$lfile\"\n" );
                }
                next;
            }
        }
        if($doingdata) {
           $datasection .= $_;
        } else {
           if($filecount == 1 && $doingglobal >= 0) {
              $header .= $_;
           } else {
              $mainsection .= $_;
           }
        }
     }
     close INP;
     $loaded{$toload} = 'yes';
     $mainsection .= "\n";

     unless($filecount == 1) {
        $mainsection .= "}\n";
     }
  }

} while $hasunloaded;

print OUT $header;
if($globalvars) {
   print OUT "########## Start of the globals ###########\n\n";
   print OUT $globalvars;
   print OUT "########### End of the globals ############\n\n";
}
print OUT $mainsection;

if($datasection) {
   print OUT $datasection;
}

close OUT;

exit;