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