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