This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fixes for Borland compiler (from Vadim Konovalov
[perl5.git] / 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;