utils/perlcc.PL

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