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