home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / utils / perlcc.PL < prev    next >
Perl Script  |  2000-03-13  |  34KB  |  1,120 lines
  1. #!/usr/local/bin/perl
  2.  
  3. use Config;
  4. use File::Basename qw(&basename &dirname);
  5. use File::Spec;
  6. use Cwd;
  7.  
  8. # List explicitly here the variables you want Configure to
  9. # generate.  Metaconfig only looks for shell variables, so you
  10. # have to mention them as if they were shell variables, not
  11. # %Config entries.  Thus you write
  12. #  $startperl
  13. # to ensure Configure will look for $Config{startperl}.
  14. # Wanted:  $archlibexp
  15.  
  16. # This forces PL files to create target in same directory as PL file.
  17. # This is so that make depend always knows where to find PL derivatives.
  18. $origdir = cwd;
  19. chdir dirname($0);
  20. $file = basename($0, '.PL');
  21. $file .= '.com' if $^O eq 'VMS';
  22.  
  23. open OUT,">$file" or die "Can't create $file: $!";
  24.  
  25. print "Extracting $file (with variable substitutions)\n";
  26.  
  27. # In this section, perl variables will be expanded during extraction.
  28. # You can use $Config{...} to use Configure variables.
  29.  
  30. print OUT <<"!GROK!THIS!";
  31. $Config{startperl}
  32.     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
  33.     if \$running_under_some_shell;
  34. !GROK!THIS!
  35.  
  36. # In the following, perl variables are not expanded during extraction.
  37.  
  38. print OUT <<'!NO!SUBS!';
  39.  
  40. use Config;
  41. use strict;
  42. use FileHandle;
  43. use File::Basename qw(&basename &dirname);
  44. use Cwd;
  45.  
  46. use Getopt::Long;
  47.  
  48. $Getopt::Long::bundling_override = 1;
  49. $Getopt::Long::passthrough = 0;
  50. $Getopt::Long::ignore_case = 0;
  51.  
  52. my $pathsep = ($Config{'osname'} eq 'MSWin32')? "\\" : "/"; # MAJOR HACK. SHOULD
  53.                                                             # BE IN Config.pm
  54.  
  55. my $options = {};
  56. my $_fh;
  57. unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS};
  58.  
  59. main();
  60.  
  61. sub main
  62. {
  63.  
  64.     GetOptions
  65.             (
  66.             $options,   "L:s",
  67.                         "I:s",
  68.                         "C:s",
  69.                         "o:s",
  70.                         "e:s",
  71.                         "regex:s",
  72.                         "verbose:s",
  73.                         "log:s",
  74.                         "argv:s",
  75.                         "b",
  76.                         "opt",
  77.                         "gen",
  78.                         "sav",
  79.                         "run",
  80.                         "prog",
  81.                         "mod"
  82.             );
  83.  
  84.  
  85.     my $key;
  86.  
  87.     local($") = "|";
  88.  
  89.     _usage() if (!_checkopts());
  90.     push(@ARGV, _maketempfile()) if ($options->{'e'});
  91.  
  92.     _usage() if (!@ARGV);
  93.                 
  94.     my $file;
  95.     foreach $file (@ARGV)
  96.     {
  97.         _print("
  98. --------------------------------------------------------------------------------
  99. Compiling $file:
  100. --------------------------------------------------------------------------------
  101. ", 36 );
  102.         _doit($file);
  103.     }
  104. }
  105.         
  106. sub _doit
  107. {
  108.     my ($file) = @_;
  109.  
  110.     my ($program_ext, $module_ext) = _getRegexps();
  111.     my ($obj, $objfile, $so, $type, $backend, $gentype);
  112.  
  113.     $backend = $options->{'b'} ? 'Bytecode' : $options->{'opt'} ? 'CC' : 'C';
  114.  
  115.     $gentype = $options->{'b'} ? 'Bytecode' : 'C';
  116.  
  117.     if  (
  118.             (($file =~ m"@$program_ext") && ($file !~ m"@$module_ext"))
  119.             || (defined($options->{'prog'}) || defined($options->{'run'}))
  120.         )
  121.     {
  122.         $type = 'program';
  123.  
  124.         if ($options->{'b'})
  125.         {
  126.             $obj = $objfile = $options->{'o'} ? $options->{'o'} : "${file}c";
  127.         }
  128.         else
  129.         {
  130.             $objfile = $options->{'C'} ? $options->{'C'} : "$file.c";
  131.             $obj = $options->{'o'} ? $options->{'o'}
  132.                                    : _getExecutable( $file,$program_ext);
  133.         }
  134.  
  135.         return() if (!$obj);
  136.  
  137.     }
  138.     elsif (($file =~ m"@$module_ext") || ($options->{'mod'}))
  139.     {
  140.         $type = 'module';
  141.  
  142.         if ($options->{'b'})
  143.         {
  144.             $obj = $objfile = $options->{'o'} ? $options->{'o'} : "${file}c";
  145.         }
  146.         else
  147.         {
  148.             die "Shared objects are not supported on Win32 yet!!!!\n"
  149.                                           if ($Config{'osname'} eq 'MSWin32');
  150.  
  151.             $objfile = $options->{'C'} ? $options->{'C'} : "$file.c";
  152.             $obj = $options->{'o'} ? $options->{'o'}
  153.                                    : _getExecutable($file, $module_ext);
  154.             $so = "$obj.$Config{so}";
  155.         }
  156.  
  157.         return() if (!$obj);
  158.     }
  159.     else
  160.     {
  161.         _error("noextension", $file, $program_ext, $module_ext);
  162.         return();
  163.     }
  164.  
  165.     if ($type eq 'program')
  166.     {
  167.         _print("Making $gentype($objfile) for $file!\n", 36 );
  168.  
  169.         my $errcode = _createCode($backend, $objfile, $file);
  170.         (_print( "ERROR: In generating code for $file!\n", -1), return()) 
  171.                                                                 if ($errcode);
  172.  
  173.         _print("Compiling C($obj) for $file!\n", 36 ) if (!$options->{'gen'} &&
  174.                                                           !$options->{'b'});
  175.         $errcode = _compileCode($file, $objfile, $obj) 
  176.                                             if (!$options->{'gen'} &&
  177.                                                 !$options->{'b'});
  178.  
  179.         if ($errcode)
  180.         {
  181.             _print( "ERROR: In compiling code for $objfile !\n", -1);
  182.             my $ofile = File::Basename::basename($objfile);
  183.             $ofile =~ s"\.c$"\.o"s;
  184.             
  185.             _removeCode("$ofile"); 
  186.             return()
  187.         }
  188.     
  189.         _runCode($objfile) if ($options->{'run'} && $options->{'b'});
  190.         _runCode($obj) if ($options->{'run'} && !$options->{'b'});
  191.  
  192.         _removeCode($objfile) if (($options->{'b'} &&
  193.                                    ($options->{'e'} && !$options->{'o'})) ||
  194.                                   (!$options->{'b'} &&
  195.                                    (!$options->{'sav'} || 
  196.                                     ($options->{'e'} && !$options->{'C'}))));
  197.  
  198.         _removeCode($file) if ($options->{'e'}); 
  199.  
  200.         _removeCode($obj) if (!$options->{'b'} &&
  201.                               (($options->{'e'} &&
  202.                     !$options->{'sav'} && !$options->{'o'}) ||
  203.                    ($options->{'run'} && !$options->{'sav'})));
  204.     }
  205.     else
  206.     {
  207.         _print( "Making $gentype($objfile) for $file!\n", 36 );
  208.         my $errcode = _createCode($backend, $objfile, $file, $obj);
  209.         (_print( "ERROR: In generating code for $file!\n", -1), return()) 
  210.                                                                 if ($errcode);
  211.     
  212.         _print( "Compiling C($so) for $file!\n", 36 ) if (!$options->{'gen'} &&
  213.                                                           !$options->{'b'});
  214.  
  215.         $errcode = 
  216.             _compileCode($file, $objfile, $obj, $so ) if (!$options->{'gen'} &&
  217.                                                           !$options->{'b'});
  218.  
  219.         (_print( "ERROR: In compiling code for $objfile!\n", -1), return()) 
  220.                                                                 if ($errcode);
  221.     }
  222. }
  223.  
  224. sub _getExecutable
  225. {
  226.     my ($sourceprog, $ext) = @_;
  227.     my ($obj);
  228.  
  229.     if (defined($options->{'regex'}))
  230.     {
  231.         eval("(\$obj = \$sourceprog) =~ $options->{'regex'}");
  232.         return(0) if (_error('badeval', $@));
  233.         return(0) if (_error('equal', $obj, $sourceprog));
  234.     }
  235.     elsif (defined ($options->{'ext'}))
  236.     {
  237.         ($obj = $sourceprog) =~ s"@$ext"$options->{ext}"g;        
  238.         return(0) if (_error('equal', $obj, $sourceprog));
  239.     }
  240.     elsif (defined ($options->{'run'}))
  241.     {
  242.         $obj = "perlc$$";
  243.     }
  244.     else
  245.     {
  246.         ($obj = $sourceprog) =~ s"@$ext""g;
  247.         return(0) if (_error('equal', $obj, $sourceprog));
  248.     }
  249.     return($obj);
  250. }
  251.  
  252. sub _createCode
  253. {
  254.     my ( $backend, $generated_file, $file, $final_output ) = @_;
  255.     my $return;
  256.     my $output_switch = "o";
  257.     my $max_line_len = '';
  258.  
  259.     local($") = " -I";
  260.  
  261.     if ($^O eq 'MSWin32' && $backend =~ /^CC?$/ && $Config{cc} =~ /^cl/i) {
  262.     $max_line_len = '-l2000,';
  263.     }
  264.  
  265.     if ($backend eq "Bytecode")
  266.     {
  267.         require ByteLoader;
  268.  
  269.     open(GENFILE, "> $generated_file") || die "Can't open $generated_file: $!";
  270.     binmode GENFILE;
  271.         print GENFILE "#!$^X\n" if @_ == 3;
  272.         print GENFILE "use ByteLoader $ByteLoader::VERSION;\n";
  273.     close(GENFILE);
  274.  
  275.     $output_switch ="a";
  276.     }
  277.  
  278.     if (@_ == 3)                                   # compiling a program   
  279.     {
  280.         chmod $generated_file, 0777 & ~umask if $backend eq "Bytecode";
  281.     my $null=File::Spec->devnull;
  282.         _print( "$^X -I@INC -MB::Stash -c  $file\n", 36);
  283.         my @stash=`$^X -I@INC -MB::Stash -c  $file 2>$null`;
  284.     my $stash=$stash[-1];
  285.         chomp $stash;
  286.  
  287.         _print( "$^X -I@INC -MO=$backend,$max_line_len$stash $file\n", 36);
  288.         $return =  _run("$^X -I@INC -MO=$backend,$max_line_len$stash,-$output_switch$generated_file $file", 9);
  289.         $return;
  290.     }
  291.     else                                           # compiling a shared object
  292.     {            
  293.         _print( 
  294.             "$^X -I@INC -MO=$backend,$max_line_len-m$final_output $file\n", 36);
  295.         $return = 
  296.         _run("$^X -I@INC -MO=$backend,$max_line_len-m$final_output,-$output_switch$generated_file $file  ", 9);
  297.         $return;
  298.     }
  299. }
  300.  
  301. sub _compileCode
  302. {
  303.     my ($sourceprog, $generated_cfile, $output_executable, $shared_object) = @_;
  304.     my @return;
  305.  
  306.     if (@_ == 3)                            # just compiling a program 
  307.     {
  308.         $return[0] = 
  309.         _ccharness('static', $sourceprog, "-o", $output_executable,
  310.            $generated_cfile);  
  311.         $return[0];
  312.     }
  313.     else
  314.     {
  315.         my $object_file = $generated_cfile;
  316.         $object_file =~ s"\.c$"$Config{_o}";   
  317.  
  318.         $return[0] = _ccharness('compile', $sourceprog, "-c", $generated_cfile);
  319.         $return[1] = _ccharness
  320.                             (
  321.                                 'dynamic', 
  322.                                 $sourceprog, "-o", 
  323.                                 $shared_object, $object_file 
  324.                             );
  325.         return(1) if (grep ($_, @return));
  326.         return(0);
  327.     }
  328. }
  329.  
  330. sub _runCode
  331. {
  332.     my ($executable) = @_;
  333.     _print("$executable $options->{'argv'}\n", 36);
  334.     _run("$executable $options->{'argv'}", -1 );
  335. }
  336.  
  337. sub _removeCode
  338. {
  339.     my ($file) = @_;
  340.     unlink($file) if (-e $file);
  341. }
  342.  
  343. sub _ccharness
  344. {
  345.     my $type = shift;
  346.     my (@args) = @_;
  347.     local($") = " ";
  348.  
  349.     my $sourceprog = shift(@args);
  350.     my ($libdir, $incdir);
  351.  
  352.     my $L = '-L';
  353.     $L = '-libpath:' if $^O eq 'MSWin32' && $Config{cc} =~ /^cl/i;
  354.  
  355.     if (-d "$Config{installarchlib}/CORE")
  356.     {
  357.         $libdir = "$L$Config{installarchlib}/CORE";
  358.         $incdir = "-I$Config{installarchlib}/CORE";
  359.     }
  360.     else
  361.     {
  362.         $libdir = "$L.. $L."; 
  363.         $incdir = "-I.. -I.";
  364.     }
  365.  
  366.     $libdir .= " $L$options->{L}" if (defined($options->{L}));
  367.     $incdir .= " -I$options->{L}" if (defined($options->{L}));
  368.  
  369.     my $linkargs = '';
  370.     my $dynaloader = '';
  371.     my $optimize = '';
  372.     my $flags = '';
  373.  
  374.     if (!grep(/^-[cS]$/, @args))
  375.     {
  376.     my $lperl = $^O eq 'os2' ? '-llibperl' 
  377.        : $^O eq 'MSWin32' ? "$Config{archlibexp}\\CORE\\$Config{libperl}"
  378.        : '-lperl';
  379.        ($lperl = $Config{libperl}) =~ s/lib(.*)\Q$Config{_a}\E/-l$1/
  380.         if($^O eq 'cygwin');
  381.  
  382.     $optimize = $Config{'optimize'} =~ /-O\d/ ? '' : $Config{'optimize'};
  383.  
  384.     $flags = $type eq 'dynamic' ? $Config{lddlflags} : $Config{ldflags};
  385.     $linkargs = "$flags $libdir $lperl @Config{libs}";
  386.     $linkargs = "/link $linkargs" if $^O eq 'MSWin32' && $Config{cc} =~ /^cl/i;
  387.     }
  388.  
  389.     my $libs = _getSharedObjects($sourceprog);
  390.     @$libs = grep { !(/DynaLoader\.a$/ && ($dynaloader = $_)) } @$libs
  391.     if($^O eq 'cygwin');
  392.  
  393.     my $args = "@args";
  394.     if ($^O eq 'MSWin32' && $Config{cc} =~ /^bcc/i) {
  395.         # BC++ cmd line syntax does not allow space between -[oexz...] and arg
  396.         $args =~ s/(^|\s+)-([oe])\s+/$1-$2/g;
  397.     }
  398.  
  399.     my $ccflags = $Config{ccflags};
  400.     $ccflags .= ' -DUSEIMPORTLIB' if $^O eq 'cygwin';
  401.     my $cccmd = "$Config{cc} $ccflags $optimize $incdir "
  402.         ."$args $dynaloader $linkargs @$libs";
  403.  
  404.     _print ("$cccmd\n", 36);
  405.     _run("$cccmd", 18 );
  406. }
  407.  
  408. sub _getSharedObjects
  409. {
  410.     my ($sourceprog) = @_;
  411.     my ($tmpfile, $incfile);
  412.     my (@sharedobjects, @libraries);
  413.     local($") = " -I";
  414.  
  415.     my ($tmpprog);
  416.     ($tmpprog = $sourceprog) =~ s"(.*)[\\/](.*)"$2";
  417.  
  418.     my $tempdir= File::Spec->tmpdir;
  419.  
  420.     $tmpfile = "$tempdir/$tmpprog.tst";
  421.     $incfile = "$tempdir/$tmpprog.val";
  422.  
  423.     my $fd = new FileHandle("> $tmpfile") || die "Couldn't open $tmpfile!\n";
  424.     my $fd2 = 
  425.         new FileHandle("$sourceprog") || die "Couldn't open $sourceprog!\n";
  426.  
  427.     print $fd <<"EOF";
  428.         use FileHandle;
  429.         my \$fh3  = new FileHandle("> $incfile") 
  430.                                         || die "Couldn't open $incfile\\n";
  431.  
  432.         my \$key;
  433.         foreach \$key (keys(\%INC)) { print \$fh3 "\$key:\$INC{\$key}\\n"; }
  434.         close(\$fh3);
  435.         exit();
  436. EOF
  437.  
  438.     print $fd (   <$fd2>    );
  439.     close($fd);
  440.  
  441.     _print("$^X -I@INC $tmpfile\n", 36);
  442.     _run("$^X -I@INC $tmpfile", 9 );
  443.  
  444.     $fd = new FileHandle ("$incfile"); 
  445.     my @lines = <$fd>;    
  446.  
  447.     unlink($tmpfile);
  448.     unlink($incfile);
  449.  
  450.     my $line;
  451.     my $autolib;
  452.  
  453.     my @return;
  454.  
  455.     foreach $line (@lines) 
  456.     {
  457.         chomp($line);
  458.  
  459.         my ($modname, $modpath) = split(':', $line);
  460.         my ($dir, $file) = ($modpath=~ m"(.*)[\\/]($modname)");
  461.  
  462.         if ($autolib = _lookforAuto($dir, $file)) { push(@return, $autolib); }
  463.     }
  464.     return(\@return);
  465. }
  466.  
  467. sub _maketempfile
  468. {
  469.     my $return;
  470.  
  471. #    if ($Config{'osname'} eq 'MSWin32') 
  472. #            { $return = "C:\\TEMP\\comp$$.p"; }
  473. #    else
  474. #            { $return = "/tmp/comp$$.p"; }
  475.  
  476.     $return = "comp$$.p"; 
  477.  
  478.     my $fd = new FileHandle( "> $return") || die "Couldn't open $return!\n";
  479.     print $fd $options->{'e'};
  480.     close($fd);
  481.  
  482.     return($return);
  483. }
  484.     
  485.     
  486. sub _lookforAuto
  487. {
  488.     my ($dir, $file) = @_;    
  489.  
  490.     my ($relabs, $relshared);
  491.     my ($prefix);
  492.     my $return;
  493.     my $sharedextension = $^O =~ /MSWin32|cygwin|os2/i
  494.               ? $Config{_a} : ".$Config{so}";
  495.     ($prefix = $file) =~ s"(.*)\.pm"$1";
  496.  
  497.     my ($tmp, $modname) = ($prefix =~ m"(?:(.*)[\\/]){0,1}(.*)"s);
  498.  
  499.     $relshared = "$pathsep$prefix$pathsep$modname$sharedextension";
  500.     $relabs    = "$pathsep$prefix$pathsep$modname$Config{_a}";
  501.                                                # HACK . WHY DOES _a HAVE A '.'
  502.                                                # AND so HAVE NONE??
  503.  
  504.     my @searchpaths =   map("$_${pathsep}auto", @INC);
  505.     
  506.     my $path;
  507.     foreach $path (@searchpaths)
  508.     {
  509.         if (-e ($return = "$path$relshared")) { return($return); } 
  510.         if (-e ($return = "$path$relabs"))    { return($return); }
  511.     }
  512.    return(undef);
  513. }
  514.  
  515. sub _getRegexps    # make the appropriate regexps for making executables, 
  516. {                  # shared libs
  517.  
  518.     my ($program_ext, $module_ext) = ([],[]); 
  519.  
  520.  
  521.     @$program_ext = ($ENV{PERL_SCRIPT_EXT})? split(':', $ENV{PERL_SCRIPT_EXT}) :
  522.                                             ('.p$', '.pl$', '.bat$');
  523.  
  524.  
  525.     @$module_ext  = ($ENV{PERL_MODULE_EXT})? split(':', $ENV{PERL_MODULE_EXT}) :
  526.                                             ('.pm$');
  527.  
  528.     _mungeRegexp( $program_ext );
  529.     _mungeRegexp( $module_ext  );    
  530.  
  531.     return($program_ext, $module_ext);
  532. }
  533.  
  534. sub _mungeRegexp
  535. {
  536.     my ($regexp) = @_;
  537.  
  538.     grep(s:(^|[^\\])\.:$1\x00\\.:g, @$regexp);
  539.     grep(s:(^|[^\x00])\\\.:$1\.:g,  @$regexp);
  540.     grep(s:\x00::g,                 @$regexp);
  541. }
  542.  
  543. sub _error
  544. {
  545.     my ($type, @args) = @_;
  546.  
  547.     if ($type eq 'equal')
  548.     {
  549.             
  550.         if ($args[0] eq $args[1])
  551.         {
  552.             _print ("ERROR: The object file '$args[0]' does not generate a legitimate executable file! Skipping!\n", -1);
  553.             return(1);
  554.         }
  555.     }
  556.     elsif ($type eq 'badeval')
  557.     {
  558.         if ($args[0])
  559.         {
  560.             _print ("ERROR: $args[0]\n", -1);
  561.             return(1);
  562.         }
  563.     }
  564.     elsif ($type eq 'noextension')
  565.     {
  566.         my $progext = join(',', @{$args[1]});
  567.         my $modext  = join(',', @{$args[2]});
  568.  
  569.         $progext =~ s"\\""g;
  570.         $modext  =~ s"\\""g;
  571.  
  572.         $progext =~ s"\$""g;
  573.         $modext  =~ s"\$""g;
  574.  
  575.         _print 
  576.         (
  577. "
  578. ERROR: '$args[0]' does not have a proper extension! Proper extensions are:
  579.  
  580.     PROGRAM:       $progext 
  581.     SHARED OBJECT: $modext
  582.  
  583. Use the '-prog' flag to force your files to be interpreted as programs.
  584. Use the '-mod' flag to force your files to be interpreted as modules.
  585. ", -1
  586.         );
  587.         return(1);
  588.     }
  589.  
  590.     return(0);
  591. }
  592.  
  593. sub _checkopts
  594. {
  595.     my @errors;
  596.     local($") = "\n";
  597.  
  598.     if ($options->{'log'})
  599.     {
  600.         $_fh = new FileHandle(">> $options->{'log'}") || push(@errors, "ERROR: Couldn't open $options->{'log'}\n");
  601.     }
  602.  
  603.     if ($options->{'b'} && $options->{'c'})
  604.     {
  605.         push(@errors,
  606. "ERROR: The '-b' and '-c' options are incompatible. The '-c' option specifies
  607.        a name for the intermediate C code but '-b' generates byte code
  608.        directly.\n");
  609.     }
  610.     if ($options->{'b'} && ($options->{'sav'} || $options->{'gen'}))
  611.     {
  612.         push(@errors,
  613. "ERROR: The '-sav' and '-gen' options are incompatible with the '-b' option.
  614.        They ask for intermediate C code to be saved by '-b' generates byte
  615.        code directly.\n");
  616.     }
  617.  
  618.     if (($options->{'c'}) && (@ARGV > 1) && ($options->{'sav'} ))
  619.     {
  620.         push(@errors, 
  621. "ERROR: The '-sav' and '-C' options are incompatible when you have more than 
  622.        one input file! ('-C' explicitly names resulting C code, '-sav' saves it,
  623.        and hence, with more than one file, the c code will be overwritten for 
  624.        each file that you compile)\n");
  625.     }
  626.     if (($options->{'o'}) && (@ARGV > 1))
  627.     {
  628.         push(@errors, 
  629. "ERROR: The '-o' option is incompatible when you have more than one input 
  630.        file! (-o explicitly names the resulting file, hence, with more than 
  631.        one file the names clash)\n");
  632.     }
  633.  
  634.     if ($options->{'e'} && ($options->{'sav'} || $options->{'gen'}) &&
  635.                                                             !$options->{'C'})
  636.     {
  637.         push(@errors, 
  638. "ERROR: You need to specify where you are going to save the resulting 
  639.        C code when using '-sav' and '-e'. Use '-C'.\n");
  640.     }
  641.  
  642.     if (($options->{'regex'} || $options->{'run'} || $options->{'o'}) 
  643.                                                     && $options->{'gen'})
  644.     {
  645.         push(@errors, 
  646. "ERROR: The options '-regex', '-run', and '-o' are incompatible with '-gen'. 
  647.        '-gen' says to stop at C generation, and the other three modify the 
  648.        compilation and/or running process!\n");
  649.     }
  650.  
  651.     if ($options->{'run'} && $options->{'mod'})
  652.     {
  653.         push(@errors, 
  654. "ERROR: Can't run modules that you are compiling! '-run' and '-mod' are 
  655.        incompatible!\n"); 
  656.     }
  657.  
  658.     if ($options->{'e'} && @ARGV)
  659.     {
  660.         push (@errors, 
  661. "ERROR: The option '-e' needs to be all by itself without any other 
  662.        file arguments!\n");
  663.     }
  664.     if ($options->{'e'} && !($options->{'o'} || $options->{'run'}))
  665.     {
  666.         $options->{'run'} = 1;
  667.     }
  668.  
  669.     if (!defined($options->{'verbose'})) 
  670.     { 
  671.         $options->{'verbose'} = ($options->{'log'})? 64 : 7; 
  672.     }
  673.  
  674.     my $verbose_error;
  675.  
  676.     if ($options->{'verbose'} =~ m"[^tagfcd]" && 
  677.             !( $options->{'verbose'} eq '0' || 
  678.                 ($options->{'verbose'} < 64 && $options->{'verbose'} > 0)))
  679.     {
  680.         $verbose_error = 1;
  681.         push(@errors, 
  682. "ERROR: Illegal verbosity level.  Needs to have either the letters 
  683.        't','a','g','f','c', or 'd' in it or be between 0 and 63, inclusive.\n");
  684.     }
  685.  
  686.     $options->{'verbose'} = ($options->{'verbose'} =~ m"[tagfcd]")? 
  687.                             ($options->{'verbose'} =~ m"d") * 32 +     
  688.                             ($options->{'verbose'} =~ m"c") * 16 +     
  689.                             ($options->{'verbose'} =~ m"f") * 8     +     
  690.                             ($options->{'verbose'} =~ m"t") * 4     +     
  691.                             ($options->{'verbose'} =~ m"a") * 2     +     
  692.                             ($options->{'verbose'} =~ m"g") * 1     
  693.                                                     : $options->{'verbose'};
  694.  
  695.     if     (!$verbose_error && (    $options->{'log'} && 
  696.                                 !(
  697.                                     ($options->{'verbose'} & 8)   || 
  698.                                     ($options->{'verbose'} & 16)  || 
  699.                                     ($options->{'verbose'} & 32 ) 
  700.                                 )
  701.                             )
  702.         )
  703.     {
  704.         push(@errors, 
  705. "ERROR: The verbosity level '$options->{'verbose'}' does not output anything 
  706.        to a logfile, and you specified '-log'!\n");
  707.     } # }
  708.  
  709.     if     (!$verbose_error && (    !$options->{'log'} && 
  710.                                 (
  711.                                     ($options->{'verbose'} & 8)   || 
  712.                                     ($options->{'verbose'} & 16)  || 
  713.                                     ($options->{'verbose'} & 32)  || 
  714.                                     ($options->{'verbose'} & 64)
  715.                                 )
  716.                             )
  717.         )
  718.     {
  719.         push(@errors, 
  720. "ERROR: The verbosity level '$options->{'verbose'}' requires that you also 
  721.        specify a logfile via '-log'\n");
  722.     } # }
  723.  
  724.  
  725.     (_print( "\n". join("\n", @errors), -1), return(0)) if (@errors);
  726.     return(1);
  727. }
  728.  
  729. sub _print
  730. {
  731.     my ($text, $flag ) = @_;
  732.     
  733.     my $logflag = int($flag/8) * 8;
  734.     my $regflag = $flag % 8;
  735.  
  736.     if ($flag == -1 || ($flag & $options->{'verbose'}))
  737.     {
  738.         my $dolog = ((($logflag & $options->{'verbose'}) || $flag == -1) 
  739.                                                         && $options->{'log'}); 
  740.  
  741.         my $doreg = (($regflag & $options->{'verbose'}) || $flag == -1);
  742.         
  743.         if ($doreg) { print( STDERR $text ); }
  744.         if ($dolog) { print $_fh $text; }
  745.     }
  746. }
  747.  
  748. sub _run
  749. {
  750.     my ($command, $flag) = @_;
  751.  
  752.     my $logflag = ($flag != -1)? int($flag/8) * 8 : 0;
  753.     my $regflag = $flag % 8;
  754.  
  755.     if ($flag == -1 || ($flag & $options->{'verbose'}))
  756.     {
  757.         my $dolog = ($logflag & $options->{'verbose'} && $options->{'log'});
  758.         my $doreg = (($regflag & $options->{'verbose'}) || $flag == -1);
  759.  
  760.         if ($doreg && !$dolog) 
  761.         {
  762.         print _interruptrun("$command");
  763.     }
  764.         elsif ($doreg && $dolog) 
  765.         { 
  766.         my $text = _interruptrun($command); 
  767.         print $_fh $text; 
  768.         print STDERR $text;
  769.     }
  770.         else 
  771.         { 
  772.         my $text = _interruptrun($command);
  773.         print $_fh $text; 
  774.     }
  775.     }
  776.     else 
  777.     {
  778.     _interruptrun($command);
  779.     }
  780.     return($?);
  781. }
  782.  
  783. sub _interruptrun
  784. {
  785.     my ($command) = @_;
  786.     my $pid = open (FD, "$command  |");
  787.  
  788.     local($SIG{HUP}) = sub { 
  789. #    kill 9, $pid + 1;  
  790. #    HACK... 2>&1 doesn't propogate
  791. #    kill, comment out for quick and dirty
  792. #    process killing of child.
  793.  
  794.     kill 9, $pid;  
  795.     exit(); 
  796.     };
  797.     local($SIG{INT}) = sub { 
  798. #    kill 9, $pid + 1;  
  799. #    HACK... 2>&1 doesn't propogate
  800. #    kill, comment out for quick and dirty
  801. #    process killing of child.
  802.     kill 9, $pid; 
  803.     exit(); 
  804.     }; 
  805.  
  806.     my $needalarm = 
  807.             ($ENV{'PERLCC_TIMEOUT'} && 
  808.                     $Config{'osname'} ne 'MSWin32' && $command =~ m"^perlc");
  809.     my $text;
  810.  
  811.     eval
  812.     {
  813.         local($SIG{ALRM}) = sub { die "INFINITE LOOP"; };
  814.         alarm($ENV{'PERLCC_TIMEOUT'}) if ($needalarm);
  815.         $text = join('', <FD>); 
  816.         alarm(0) if ($needalarm);
  817.     };
  818.  
  819.     if ($@) 
  820.     { 
  821.         eval { kill 'HUP', $pid; };
  822.         _print("SYSTEM TIMEOUT (infinite loop?)\n", 36); 
  823.     }
  824.         
  825.     close(FD);
  826.     return($text);
  827. }
  828.  
  829. sub _usage
  830. {
  831.     _print
  832.     ( 
  833.     <<"EOF"
  834.  
  835. Usage: $0 <file_list> 
  836.  
  837. WARNING: The whole compiler suite ('perlcc' included) is considered VERY
  838. experimental.  Use for production purposes is strongly discouraged.
  839.  
  840.     Flags with arguments
  841.         -L       < extra library dirs for installation (form of 'dir1:dir2') >
  842.         -I       < extra include dirs for installation (form of 'dir1:dir2') >
  843.         -C       < explicit name of resulting C code > 
  844.         -o       < explicit name of resulting executable >
  845.         -e       < to compile 'one liners'. Need executable name (-o) or '-run'>
  846.         -regex   < rename regex, -regex 's/\.p/\.exe/' compiles a.p to a.exe >
  847.         -verbose < verbose level < 1-63, or following letters 'gatfcd' >
  848.         -argv    < arguments for the executables to be run via '-run' or '-e' > 
  849.  
  850.     Boolean flags
  851.         -b       ( to generate byte code )
  852.         -opt     ( to generated optimised C code. May not work in some cases. )
  853.         -gen     ( to just generate the C code. Implies '-sav' )
  854.         -sav     ( to save intermediate C code, (and executables with '-run'))
  855.         -run     ( to run the compiled program on the fly, as were interpreted.)
  856.         -prog    ( to indicate that the files on command line are programs )
  857.         -mod     ( to indicate that the files on command line are modules  )
  858.  
  859. EOF
  860. , -1
  861.  
  862.     );
  863.     exit(255);
  864. }
  865.  
  866.  
  867. __END__
  868.  
  869. =head1 NAME
  870.  
  871. perlcc - frontend for perl compiler
  872.  
  873. =head1 SYNOPSIS
  874.  
  875.     %prompt  perlcc a.p        # compiles into executable 'a'
  876.  
  877.     %prompt  perlcc A.pm       # compile into 'A.so'
  878.  
  879.     %prompt  perlcc a.p -o execute  # compiles 'a.p' into 'execute'.
  880.  
  881.     %prompt  perlcc a.p -o execute -run # compiles 'a.p' into execute, runs on
  882.                                         # the fly
  883.  
  884.     %prompt  perlcc a.p -o execute -run -argv 'arg1 arg2 arg3' 
  885.                                         # compiles into execute, runs with 
  886.                                         # arg1 arg2 arg3 as @ARGV
  887.  
  888.     %prompt perlcc a.p b.p c.p -regex 's/\.p/\.exe'
  889.                                         # compiles into 'a.exe','b.exe','c.exe'.
  890.  
  891.     %prompt perlcc a.p -log compilelog  # compiles into 'a', saves compilation
  892.                                         # info into compilelog, as well
  893.                                         # as mirroring to screen
  894.  
  895.     %prompt perlcc a.p -log compilelog -verbose cdf 
  896.                                         # compiles into 'a', saves compilation
  897.                                         # info into compilelog, being silent
  898.                                         # on screen.
  899.  
  900.     %prompt perlcc a.p -C a.c -gen      # generates C code (into a.c) and 
  901.                                         # stops without compile.
  902.  
  903.     %prompt perlcc a.p -L ../lib a.c 
  904.                                         # Compiles with the perl libraries 
  905.                                         # inside ../lib included.
  906.  
  907. =head1 DESCRIPTION
  908.  
  909. 'perlcc' is the frontend into the perl compiler. Typing 'perlcc a.p'
  910. compiles the code inside a.p into a standalone executable, and 
  911. perlcc A.pm will compile into a shared object, A.so, suitable for inclusion 
  912. into a perl program via "use A".
  913.  
  914. There are quite a few flags to perlcc which help with such issues as compiling 
  915. programs in bulk, testing compiled programs for compatibility with the 
  916. interpreter, and controlling.
  917.  
  918. =head1 OPTIONS 
  919.  
  920. =over 4
  921.  
  922. =item -L < library_directories >
  923.  
  924. Adds directories in B<library_directories> to the compilation command.
  925.  
  926. =item -I  < include_directories > 
  927.  
  928. Adds directories inside B<include_directories> to the compilation command.
  929.  
  930. =item -C   < c_code_name > 
  931.  
  932. Explicitly gives the name B<c_code_name> to the generated file containing
  933. the C code which is to be compiled. Can only be used if compiling one file
  934. on the command line.
  935.  
  936. =item -o   < executable_name >
  937.  
  938. Explicitly gives the name B<executable_name> to the executable which is to be
  939. compiled. Can only be used if compiling one file on the command line.
  940.  
  941. =item -e   < perl_line_to_execute>
  942.  
  943. Compiles 'one liners', in the same way that B<perl -e> runs text strings at 
  944. the command line. Default is to have the 'one liner' be compiled, and run all
  945. in one go (see B<-run>); giving the B<-o> flag saves the resultant executable, 
  946. rather than throwing it away. Use '-argv' to pass arguments to the executable
  947. created.
  948.  
  949. =item -b
  950.  
  951. Generates bytecode instead of C code.
  952.  
  953. =item -opt
  954.  
  955. Uses the optimized C backend (C<B::CC>)rather than the simple C backend
  956. (C<B::C>).  Beware that the optimized C backend creates very large
  957. switch structures and structure initializations.  Many C compilers
  958. find it a challenge to compile the resulting output in finite amounts
  959. of time.  Many Perl features such as C<goto LABEL> are also not
  960. supported by the optimized C backend.  The simple C backend should
  961. work in more instances, but can only offer modest speed increases.
  962.  
  963. =item -regex   <rename_regex>
  964.  
  965. Gives a rule B<rename_regex> - which is a legal perl regular expression - to 
  966. create executable file names.
  967.  
  968. =item -verbose <verbose_level>
  969.  
  970. Show exactly what steps perlcc is taking to compile your code. You can
  971. change the verbosity level B<verbose_level> much in the same way that
  972. the C<-D> switch changes perl's debugging level, by giving either a
  973. number which is the sum of bits you want or a list of letters
  974. representing what you wish to see. Here are the verbosity levels so
  975. far :
  976.  
  977.     Bit 1(g):      Code Generation Errors to STDERR
  978.     Bit 2(a):      Compilation Errors to STDERR
  979.     Bit 4(t):      Descriptive text to STDERR 
  980.     Bit 8(f):      Code Generation Errors to file (B<-log> flag needed)
  981.     Bit 16(c):     Compilation Errors to file (B<-log> flag needed)
  982.     Bit 32(d):     Descriptive text to file (B<-log> flag needed) 
  983.  
  984. If the B<-log> tag is given, the default verbose level is 63 (ie: mirroring 
  985. all of perlcc's output to both the screen and to a log file). If no B<-log>
  986. tag is given, then the default verbose level is 7 (ie: outputting all of 
  987. perlcc's output to STDERR).
  988.  
  989. NOTE: Because of buffering concerns, you CANNOT shadow the output of '-run' to
  990. both a file, and to the screen! Suggestions are welcome on how to overcome this
  991. difficulty, but for now it simply does not work properly, and hence will only go
  992. to the screen.
  993.  
  994. =item -log <logname>
  995.  
  996. Opens, for append, a logfile to save some or all of the text for a given 
  997. compile command. No rewrite version is available, so this needs to be done 
  998. manually.
  999.  
  1000. =item -argv <arguments>
  1001.  
  1002. In combination with C<-run> or C<-e>, tells perlcc to run the resulting 
  1003. executable with the string B<arguments> as @ARGV.
  1004.  
  1005. =item -sav
  1006.  
  1007. Tells perl to save the intermediate C code. Usually, this C code is the name
  1008. of the perl code, plus '.c'; 'perlcode.p' gets generated in 'perlcode.p.c',
  1009. for example. If used with the C<-e> operator, you need to tell perlcc where to 
  1010. save resulting executables.
  1011.  
  1012. =item -gen
  1013.  
  1014. Tells perlcc to only create the intermediate C code, and not compile the 
  1015. results. Does an implicit B<-sav>, saving the C code rather than deleting it.
  1016.  
  1017. =item -run
  1018.  
  1019. Immediately run the perl code that has been generated. NOTE: IF YOU GIVE THE 
  1020. B<-run> FLAG TO B<perlcc>, THEN THE REST OF @ARGV WILL BE INTERPRETED AS 
  1021. ARGUMENTS TO THE PROGRAM THAT YOU ARE COMPILING.
  1022.  
  1023. =item -prog
  1024.  
  1025. Indicate that the programs at the command line are programs, and should be
  1026. compiled as such. B<perlcc> will automatically determine files to be 
  1027. programs if they have B<.p>, B<.pl>, B<.bat> extensions.
  1028.  
  1029. =item -mod
  1030.  
  1031. Indicate that the programs at the command line are modules, and should be
  1032. compiled as such. B<perlcc> will automatically determine files to be 
  1033. modules if they have the extension B<.pm>.
  1034.  
  1035. =back
  1036.  
  1037. =head1 ENVIRONMENT
  1038.  
  1039. Most of the work of B<perlcc> is done at the command line. However, you can 
  1040. change the heuristic which determines what is a module and what is a program.
  1041. As indicated above, B<perlcc> assumes that the extensions:
  1042.  
  1043. .p$, .pl$, and .bat$
  1044.  
  1045. indicate a perl program, and:
  1046.  
  1047. .pm$
  1048.  
  1049. indicate a library, for the purposes of creating executables. And furthermore,
  1050. by default, these extensions will be replaced (and dropped) in the process of 
  1051. creating an executable. 
  1052.  
  1053. To change the extensions which are programs, and which are modules, set the
  1054. environmental variables:
  1055.  
  1056. PERL_SCRIPT_EXT
  1057. PERL_MODULE_EXT
  1058.  
  1059. These two environmental variables take colon-separated, legal perl regular 
  1060. expressions, and are used by perlcc to decide which objects are which. 
  1061. For example:
  1062.  
  1063. setenv PERL_SCRIPT_EXT  '.prl$:.perl$'
  1064. prompt%   perlcc sample.perl
  1065.  
  1066. will compile the script 'sample.perl' into the executable 'sample', and
  1067.  
  1068. setenv PERL_MODULE_EXT  '.perlmod$:.perlmodule$'
  1069.  
  1070. prompt%   perlcc sample.perlmod
  1071.  
  1072. will  compile the module 'sample.perlmod' into the shared object 
  1073. 'sample.so'
  1074.  
  1075. NOTE: the '.' in the regular expressions for PERL_SCRIPT_EXT and PERL_MODULE_EXT
  1076. is a literal '.', and not a wild-card. To get a true wild-card, you need to 
  1077. backslash the '.'; as in:
  1078.  
  1079. setenv PERL_SCRIPT_EXT '\.\.\.\.\.'
  1080.  
  1081. which would have the effect of compiling ANYTHING (except what is in 
  1082. PERL_MODULE_EXT) into an executable with 5 less characters in its name.
  1083.  
  1084. The PERLCC_OPTS environment variable can be set to the default flags
  1085. that must be used by the compiler.
  1086.  
  1087. The PERLCC_TIMEOUT environment variable can be set to the number of
  1088. seconds to wait for the backends before giving up.  This is sometimes
  1089. necessary to avoid some compilers taking forever to compile the
  1090. generated output.  May not work on Windows and similar platforms.
  1091.  
  1092. =head1 FILES
  1093.  
  1094. 'perlcc' uses a temporary file when you use the B<-e> option to evaluate 
  1095. text and compile it. This temporary file is 'perlc$$.p'. The temporary C code is
  1096. perlc$$.p.c, and the temporary executable is perlc$$.
  1097.  
  1098. When you use '-run' and don't save your executable, the temporary executable is
  1099. perlc$$
  1100.  
  1101. =head1 BUGS
  1102.  
  1103. The whole compiler suite (C<perlcc> included) should be considered very
  1104. experimental.  Use for production purposes is strongly discouraged.
  1105.  
  1106. perlcc currently cannot compile shared objects on Win32. This should be fixed
  1107. in future.
  1108.  
  1109. Bugs in the various compiler backends still exist, and are perhaps too
  1110. numerous to list here.
  1111.  
  1112. =cut
  1113.  
  1114. !NO!SUBS!
  1115.  
  1116. close OUT or die "Can't close $file: $!";
  1117. chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
  1118. exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
  1119. chdir $origdir;
  1120.