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