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