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