utils/perlcc.PL

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