utils/perlcc.PL

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