source: trunk/third/perl/utils/perlcc.PL @ 14545

Revision 14545, 33.0 KB checked in by ghudson, 24 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r14544, which included commits to RCS files with non-trunk default branches.
Line 
1#!/usr/local/bin/perl
2 
3use Config;
4use File::Basename qw(&basename &dirname);
5use File::Spec;
6use 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;
19chdir dirname($0);
20$file = basename($0, '.PL');
21$file .= '.com' if $^O eq 'VMS';
22 
23open OUT,">$file" or die "Can't create $file: $!";
24 
25print "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 
30print 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 
38print OUT <<'!NO!SUBS!';
39
40use Config;
41use strict;
42use FileHandle;
43use File::Basename qw(&basename &dirname);
44use Cwd;
45
46use Getopt::Long;
47
48$Getopt::Long::bundling_override = 1;
49$Getopt::Long::passthrough = 0;
50$Getopt::Long::ignore_case = 0;
51
52my $pathsep = ($Config{'osname'} eq 'MSWin32')? "\\" : "/"; # MAJOR HACK. SHOULD
53                                                            # BE IN Config.pm
54
55my $options = {};
56my $_fh;
57unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS};
58
59main();
60
61sub 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--------------------------------------------------------------------------------
99Compiling $file:
100--------------------------------------------------------------------------------
101", 36 );
102        _doit($file);
103    }
104}
105       
106sub _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
224sub _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
252sub _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
301sub _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
330sub _runCode
331{
332    my ($executable) = @_;
333    _print("$executable $options->{'argv'}\n", 36);
334    _run("$executable $options->{'argv'}", -1 );
335}
336
337sub _removeCode
338{
339    my ($file) = @_;
340    unlink($file) if (-e $file);
341}
342
343sub _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
408sub _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();
436EOF
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
467sub _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   
486sub _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
515sub _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
534sub _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
543sub _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"
578ERROR: '$args[0]' does not have a proper extension! Proper extensions are:
579
580    PROGRAM:       $progext
581    SHARED OBJECT: $modext
582
583Use the '-prog' flag to force your files to be interpreted as programs.
584Use 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
593sub _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
729sub _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
748sub _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
783sub _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
829sub _usage
830{
831    _print
832    (
833    <<"EOF"
834
835Usage: $0 <file_list>
836
837WARNING: The whole compiler suite ('perlcc' included) is considered VERY
838experimental.  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
859EOF
860, -1
861
862    );
863    exit(255);
864}
865
866
867__END__
868
869=head1 NAME
870
871perlcc - 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'
910compiles the code inside a.p into a standalone executable, and
911perlcc A.pm will compile into a shared object, A.so, suitable for inclusion
912into a perl program via "use A".
913
914There are quite a few flags to perlcc which help with such issues as compiling
915programs in bulk, testing compiled programs for compatibility with the
916interpreter, and controlling.
917
918=head1 OPTIONS
919
920=over 4
921
922=item -L < library_directories >
923
924Adds directories in B<library_directories> to the compilation command.
925
926=item -I  < include_directories >
927
928Adds directories inside B<include_directories> to the compilation command.
929
930=item -C   < c_code_name >
931
932Explicitly gives the name B<c_code_name> to the generated file containing
933the C code which is to be compiled. Can only be used if compiling one file
934on the command line.
935
936=item -o   < executable_name >
937
938Explicitly gives the name B<executable_name> to the executable which is to be
939compiled. Can only be used if compiling one file on the command line.
940
941=item -e   < perl_line_to_execute>
942
943Compiles 'one liners', in the same way that B<perl -e> runs text strings at
944the command line. Default is to have the 'one liner' be compiled, and run all
945in one go (see B<-run>); giving the B<-o> flag saves the resultant executable,
946rather than throwing it away. Use '-argv' to pass arguments to the executable
947created.
948
949=item -b
950
951Generates bytecode instead of C code.
952
953=item -opt
954
955Uses 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
957switch structures and structure initializations.  Many C compilers
958find it a challenge to compile the resulting output in finite amounts
959of time.  Many Perl features such as C<goto LABEL> are also not
960supported by the optimized C backend.  The simple C backend should
961work in more instances, but can only offer modest speed increases.
962
963=item -regex   <rename_regex>
964
965Gives a rule B<rename_regex> - which is a legal perl regular expression - to
966create executable file names.
967
968=item -verbose <verbose_level>
969
970Show exactly what steps perlcc is taking to compile your code. You can
971change the verbosity level B<verbose_level> much in the same way that
972the C<-D> switch changes perl's debugging level, by giving either a
973number which is the sum of bits you want or a list of letters
974representing what you wish to see. Here are the verbosity levels so
975far :
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
984If the B<-log> tag is given, the default verbose level is 63 (ie: mirroring
985all of perlcc's output to both the screen and to a log file). If no B<-log>
986tag is given, then the default verbose level is 7 (ie: outputting all of
987perlcc's output to STDERR).
988
989NOTE: Because of buffering concerns, you CANNOT shadow the output of '-run' to
990both a file, and to the screen! Suggestions are welcome on how to overcome this
991difficulty, but for now it simply does not work properly, and hence will only go
992to the screen.
993
994=item -log <logname>
995
996Opens, for append, a logfile to save some or all of the text for a given
997compile command. No rewrite version is available, so this needs to be done
998manually.
999
1000=item -argv <arguments>
1001
1002In combination with C<-run> or C<-e>, tells perlcc to run the resulting
1003executable with the string B<arguments> as @ARGV.
1004
1005=item -sav
1006
1007Tells perl to save the intermediate C code. Usually, this C code is the name
1008of the perl code, plus '.c'; 'perlcode.p' gets generated in 'perlcode.p.c',
1009for example. If used with the C<-e> operator, you need to tell perlcc where to
1010save resulting executables.
1011
1012=item -gen
1013
1014Tells perlcc to only create the intermediate C code, and not compile the
1015results. Does an implicit B<-sav>, saving the C code rather than deleting it.
1016
1017=item -run
1018
1019Immediately run the perl code that has been generated. NOTE: IF YOU GIVE THE
1020B<-run> FLAG TO B<perlcc>, THEN THE REST OF @ARGV WILL BE INTERPRETED AS
1021ARGUMENTS TO THE PROGRAM THAT YOU ARE COMPILING.
1022
1023=item -prog
1024
1025Indicate that the programs at the command line are programs, and should be
1026compiled as such. B<perlcc> will automatically determine files to be
1027programs if they have B<.p>, B<.pl>, B<.bat> extensions.
1028
1029=item -mod
1030
1031Indicate that the programs at the command line are modules, and should be
1032compiled as such. B<perlcc> will automatically determine files to be
1033modules if they have the extension B<.pm>.
1034
1035=back
1036
1037=head1 ENVIRONMENT
1038
1039Most of the work of B<perlcc> is done at the command line. However, you can
1040change the heuristic which determines what is a module and what is a program.
1041As indicated above, B<perlcc> assumes that the extensions:
1042
1043.p$, .pl$, and .bat$
1044
1045indicate a perl program, and:
1046
1047.pm$
1048
1049indicate a library, for the purposes of creating executables. And furthermore,
1050by default, these extensions will be replaced (and dropped) in the process of
1051creating an executable.
1052
1053To change the extensions which are programs, and which are modules, set the
1054environmental variables:
1055
1056PERL_SCRIPT_EXT
1057PERL_MODULE_EXT
1058
1059These two environmental variables take colon-separated, legal perl regular
1060expressions, and are used by perlcc to decide which objects are which.
1061For example:
1062
1063setenv PERL_SCRIPT_EXT  '.prl$:.perl$'
1064prompt%   perlcc sample.perl
1065
1066will compile the script 'sample.perl' into the executable 'sample', and
1067
1068setenv PERL_MODULE_EXT  '.perlmod$:.perlmodule$'
1069
1070prompt%   perlcc sample.perlmod
1071
1072will  compile the module 'sample.perlmod' into the shared object
1073'sample.so'
1074
1075NOTE: the '.' in the regular expressions for PERL_SCRIPT_EXT and PERL_MODULE_EXT
1076is a literal '.', and not a wild-card. To get a true wild-card, you need to
1077backslash the '.'; as in:
1078
1079setenv PERL_SCRIPT_EXT '\.\.\.\.\.'
1080
1081which would have the effect of compiling ANYTHING (except what is in
1082PERL_MODULE_EXT) into an executable with 5 less characters in its name.
1083
1084The PERLCC_OPTS environment variable can be set to the default flags
1085that must be used by the compiler.
1086
1087The PERLCC_TIMEOUT environment variable can be set to the number of
1088seconds to wait for the backends before giving up.  This is sometimes
1089necessary to avoid some compilers taking forever to compile the
1090generated 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
1095text and compile it. This temporary file is 'perlc$$.p'. The temporary C code is
1096perlc$$.p.c, and the temporary executable is perlc$$.
1097
1098When you use '-run' and don't save your executable, the temporary executable is
1099perlc$$
1100
1101=head1 BUGS
1102
1103The whole compiler suite (C<perlcc> included) should be considered very
1104experimental.  Use for production purposes is strongly discouraged.
1105
1106perlcc currently cannot compile shared objects on Win32. This should be fixed
1107in future.
1108
1109Bugs in the various compiler backends still exist, and are perhaps too
1110numerous to list here.
1111
1112=cut
1113
1114!NO!SUBS!
1115
1116close OUT or die "Can't close $file: $!";
1117chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1118exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
1119chdir $origdir;
Note: See TracBrowser for help on using the repository browser.