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