This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
339c423f6ab711583da120eee91f2fa6642fb7eb
[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 --\$running_under_some_shell;
35 !GROK!THIS!
36  
37 # In the following, perl variables are not expanded during extraction.
38  
39 print OUT <<'!NO!SUBS!';
40
41 # Version 2.0, Simon Cozens, Thu Mar 30 17:52:45 JST 2000 
42 # Version 2.01, Tom Christiansen, Thu Mar 30 08:25:14 MST 2000
43 # Version 2.02, Simon Cozens, Sun Apr 16 01:53:36 JST 2000
44 # Version 2.03, Edward Peschko, Mon Feb 26 12:04:17 PST 2001
45 # Version 2.04, Enache Adrian,Fri, 18 Jul 2003 23:15:37 +0300
46
47 use strict;
48 use warnings;
49 use 5.006_000;
50
51 use FileHandle;
52 use Config;
53 use Fcntl qw(:DEFAULT :flock);
54 use File::Temp qw(tempfile);
55 use Cwd;
56 our $VERSION = 2.04;
57 $| = 1;
58
59 $SIG{INT} = sub { exit(); }; # exit gracefully and clean up after ourselves.
60
61 use subs qw{
62     cc_harness check_read check_write checkopts_byte choose_backend
63     compile_byte compile_cstyle compile_module generate_code
64     grab_stash parse_argv sanity_check vprint yclept spawnit
65 };
66 sub opt(*); # imal quoting
67 sub is_win32();
68 sub is_msvc();
69
70 our ($Options, $BinPerl, $Backend);
71 our ($Input => $Output);
72 our ($logfh);
73 our ($cfile);
74 our (@begin_output); # output from BEGIN {}, for testsuite
75
76 # eval { main(); 1 } or die;
77
78 main();
79
80 sub main {
81     parse_argv();
82     check_write($Output);
83     choose_backend();
84     generate_code();
85     run_code();
86     _die("XXX: Not reached?");
87 }
88
89 #######################################################################
90
91 sub choose_backend {
92     # Choose the backend.
93     $Backend = 'C';
94     if (opt(B)) {
95         checkopts_byte();
96         $Backend = 'Bytecode';
97     }
98     if (opt(S) && opt(c)) {
99         # die "$0: Do you want me to compile this or not?\n";
100         delete $Options->{S};
101     }
102     $Backend = 'CC' if opt(O);
103 }
104
105
106 sub generate_code { 
107
108     vprint 0, "Compiling $Input";
109
110     $BinPerl  = yclept();  # Calling convention for perl.
111
112     if (opt(shared)) {
113         compile_module();
114     } else {
115         if ($Backend eq 'Bytecode') {
116             compile_byte();
117         } else {
118             compile_cstyle();
119         }
120     }
121     exit(0) if (!opt('r'));
122 }
123
124 sub run_code {
125     vprint 0, "Running code";
126     run("$Output @ARGV");
127     exit(0);
128 }
129
130 # usage: vprint [level] msg args
131 sub vprint {
132     my $level;
133     if (@_ == 1) {
134         $level = 1;
135     } elsif ($_[0] =~ /^\d$/) {
136         $level = shift;
137     } else {
138         # well, they forgot to use a number; means >0
139         $level = 0;
140     } 
141     my $msg = "@_";
142     $msg .= "\n" unless substr($msg, -1) eq "\n";
143     if (opt(v) > $level)
144     {
145          print        "$0: $msg" if !opt('log');
146          print $logfh "$0: $msg" if  opt('log');
147     }
148 }
149
150 sub parse_argv {
151
152     use Getopt::Long; 
153
154     # disallows using long arguments
155     # Getopt::Long::Configure("bundling");
156
157     Getopt::Long::Configure("no_ignore_case");
158
159     # no difference in exists and defined for %ENV; also, a "0"
160     # argument or a "" would not help cc, so skip
161     unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS};
162
163     $Options = {};
164     Getopt::Long::GetOptions( $Options,
165         'L:s',          # lib directory
166         'I:s',          # include directories (FOR C, NOT FOR PERL)
167         'o:s',          # Output executable
168         'v:i',          # Verbosity level
169         'e:s',          # One-liner
170         'r',            # run resulting executable
171         'B',            # Byte compiler backend
172         'O',            # Optimised C backend
173         'c',            # Compile only
174         'h',            # Help me
175         'S',            # Dump C files
176         'r',            # run the resulting executable
177         'T',            # run the backend using perl -T
178         't',            # run the backend using perl -t
179         'static',       # Dirty hack to enable -shared/-static
180         'shared',       # Create a shared library (--shared for compat.)
181         'log:s',        # where to log compilation process information
182         'Wb:s',         # pass (comma-sepearated) options to backend
183         'testsuite',    # try to be nice to testsuite
184     );
185
186     $Options->{v} += 0;
187
188     if( opt(t) && opt(T) ) {
189         warn "Can't specify both -T and -t, -t ignored";
190         $Options->{t} = 0;
191     }
192
193     helpme() if opt(h); # And exit
194
195     $Output = opt(o) || ( is_win32 ? 'a.exe' : 'a.out' );
196     $Output = is_win32() ? $Output : relativize($Output);
197     $logfh  = new FileHandle(">> " . opt('log')) if (opt('log'));
198
199     if (opt(e)) {
200         warn "$0: using -e 'code' as input file, ignoring @ARGV\n" if @ARGV;
201         # We don't use a temporary file here; why bother?
202         # XXX: this is not bullet proof -- spaces or quotes in name!
203         $Input = is_win32() ? # Quotes eaten by shell
204             '-e "'.opt(e).'"' :
205             "-e '".opt(e)."'";
206     } else {
207         $Input = shift @ARGV;  # XXX: more files?
208         _usage_and_die("$0: No input file specified\n") unless $Input;
209         # DWIM modules. This is bad but necessary.
210         $Options->{shared}++ if $Input =~ /\.pm\z/;
211         warn "$0: using $Input as input file, ignoring @ARGV\n" if @ARGV;
212         check_read($Input);
213         check_perl($Input);
214         sanity_check();
215     }
216
217 }
218
219 sub opt(*) {
220     my $opt = shift;
221     return exists($Options->{$opt}) && ($Options->{$opt} || 0);
222
223
224 sub compile_module { 
225     die "$0: Compiling to shared libraries is currently disabled\n";
226 }
227
228 sub compile_byte {
229     my $command = "$BinPerl -MO=Bytecode,-H,-o$Output $Input";
230     $Input =~ s/^-e.*$/-e/;
231
232     my ($output_r, $error_r) = spawnit($command);
233
234     if (@$error_r && $? != 0) {
235         _die("$0: $Input did not compile:\n@$error_r\n");
236     } else {
237         my @error = grep { !/^$Input syntax OK$/o } @$error_r;
238         warn "$0: Unexpected compiler output:\n@error" if @error;
239     }
240
241     chmod 0777 & ~umask, $Output    or _die("can't chmod $Output: $!");
242     exit 0;
243 }
244
245 sub compile_cstyle {
246     my $stash = grab_stash();
247     my $taint = opt(T) ? '-T' :
248                 opt(t) ? '-t' : '';
249
250     # What are we going to call our output C file?
251     my $lose = 0;
252     my ($cfh);
253     my $testsuite = '';
254     my $addoptions = opt(Wb);
255
256     if( $addoptions ) {
257         $addoptions .= ',' if $addoptions !~ m/,$/;
258     }
259
260     if (opt(testsuite)) {
261         my $bo = join '', @begin_output;
262         $bo =~ s/\\/\\\\\\\\/gs;
263         $bo =~ s/\n/\\n/gs;
264         $bo =~ s/,/\\054/gs;
265         # don't look at that: it hurts
266         $testsuite = q{-fuse-script-name,-fsave-data,-fsave-sig-hash,}.
267             qq[-e"print q{$bo}",] .
268             q{-e"open(Test::Builder::TESTOUT\054 '>&STDOUT') or die $!",} .
269             q{-e"open(Test::Builder::TESTERR\054 '>&STDERR') or die $!",};
270     }
271     if (opt(S) || opt(c)) {
272         # We need to keep it.
273         if (opt(e)) {
274             $cfile = "a.out.c";
275         } else {
276             $cfile = $Input;
277             # File off extension if present
278             # hold on: plx is executable; also, careful of ordering!
279             $cfile =~ s/\.(?:p(?:lx|l|h)|m)\z//i;
280             $cfile .= ".c";
281             $cfile = $Output if opt(c) && $Output =~ /\.c\z/i;
282         }
283         check_write($cfile);
284     } else {
285         # Don't need to keep it, be safe with a tempfile.
286         $lose = 1;
287         ($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c"); 
288         close $cfh; # See comment just below
289     }
290     vprint 1, "Writing C on $cfile";
291
292     my $max_line_len = '';
293     if ($^O eq 'MSWin32' && $Config{cc} =~ /^cl/i) {
294         $max_line_len = '-l2000,';
295     }
296
297     # This has to do the write itself, so we can't keep a lock. Life
298     # sucks.
299     my $command = "$BinPerl $taint -MO=$Backend,$addoptions$testsuite$max_line_len$stash,-o$cfile $Input";
300     vprint 1, "Compiling...";
301     vprint 1, "Calling $command";
302
303         my ($output_r, $error_r) = spawnit($command);
304         my @output = @$output_r;
305         my @error = @$error_r;
306
307     if (@error && $? != 0) {
308         _die("$0: $Input did not compile, which can't happen:\n@error\n");
309     }
310
311     is_msvc ?
312         cc_harness_msvc($cfile,$stash) :
313         cc_harness($cfile,$stash) unless opt(c);
314
315     if ($lose) {
316         vprint 2, "unlinking $cfile";
317         unlink $cfile or _die("can't unlink $cfile: $!"); 
318     }
319 }
320
321 sub cc_harness_msvc {
322     my ($cfile,$stash)=@_;
323     use ExtUtils::Embed ();
324     my $obj = "${Output}.obj";
325     my $compile = ExtUtils::Embed::ccopts." -c -Fo$obj $cfile ";
326     my $link = "-out:$Output $obj";
327     $compile .= " -I".$_ for split /\s+/, opt(I);
328     $link .= " -libpath:".$_ for split /\s+/, opt(L);
329     my @mods = split /-?u /, $stash;
330     $link .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
331     $link .= " perl57.lib kernel32.lib msvcrt.lib";
332     vprint 3, "running $Config{cc} $compile";
333     system("$Config{cc} $compile");
334     vprint 3, "running $Config{ld} $link";
335     system("$Config{ld} $link");
336 }
337
338 sub cc_harness {
339         my ($cfile,$stash)=@_;
340         use ExtUtils::Embed ();
341         my $command = ExtUtils::Embed::ccopts." -o $Output $cfile ";
342         $command .= " -I".$_ for split /\s+/, opt(I);
343         $command .= " -L".$_ for split /\s+/, opt(L);
344         my @mods = split /-?u /, $stash;
345         $command .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
346         $command .= " -lperl";
347         vprint 3, "running $Config{cc} $command";
348         system("$Config{cc} $command");
349 }
350
351 # Where Perl is, and which include path to give it.
352 sub yclept {
353     my $command = "$^X ";
354
355     # DWIM the -I to be Perl, not C, include directories.
356     if (opt(I) && $Backend eq "Bytecode") {
357         for (split /\s+/, opt(I)) {
358             if (-d $_) {
359                 push @INC, $_;
360             } else {
361                 warn "$0: Include directory $_ not found, skipping\n";
362             }
363         }
364     }
365             
366     $command .= "-I$_ " for @INC;
367     return $command;
368 }
369
370 # Use B::Stash to find additional modules and stuff.
371 {
372     my $_stash;
373     sub grab_stash {
374
375         warn "already called get_stash once" if $_stash;
376
377         my $taint = opt(T) ? '-T' :
378                     opt(t) ? '-t' : '';
379         my $command = "$BinPerl $taint -MB::Stash -c $Input";
380         # Filename here is perfectly sanitised.
381         vprint 3, "Calling $command\n";
382
383                 my ($stash_r, $error_r) = spawnit($command);
384                 my @stash = @$stash_r;
385                 my @error = @$error_r;
386
387         if (@error && $? != 0) {
388             _die("$0: $Input did not compile:\n@error\n");
389         }
390
391         # band-aid for modules with noisy BEGIN {}
392         foreach my $i ( @stash ) {
393             $i =~ m/-u(?:[\w:]+|\<none\>)$/ and $stash[0] = $i and next;
394             push @begin_output, $i;
395         }
396         chomp $stash[0];
397         $stash[0] =~ s/,-u\<none\>//;
398         $stash[0] =~ s/^.*?-u/-u/s;
399         vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0];
400         chomp $stash[0];
401         return $_stash = $stash[0];
402     }
403
404 }
405
406 # Check the consistency of options if -B is selected.
407 # To wit, (-B|-O) ==> no -shared, no -S, no -c
408 sub checkopts_byte {
409
410     _die("$0: Please choose one of either -B and -O.\n") if opt(O);
411
412     if (opt(shared)) {
413         warn "$0: Will not create a shared library for bytecode\n";
414         delete $Options->{shared};
415     }
416
417     for my $o ( qw[c S] ) { 
418         if (opt($o)) { 
419             warn "$0: Compiling to bytecode is a one-pass process--",
420                   "-$o ignored\n";
421             delete $Options->{$o};
422         }
423     }
424
425 }
426
427 # Check the input and output files make sense, are read/writeable.
428 sub sanity_check {
429     if ($Input eq $Output) {
430         if ($Input eq 'a.out') {
431             _die("$0: Compiling a.out is probably not what you want to do.\n");
432             # You fully deserve what you get now. No you *don't*. typos happen.
433         } else {
434             warn "$0: Will not write output on top of input file, ",
435                 "compiling to a.out instead\n";
436             $Output = "a.out";
437         }
438     }
439 }
440
441 sub check_read { 
442     my $file = shift;
443     unless (-r $file) {
444         _die("$0: Input file $file is a directory, not a file\n") if -d _;
445         unless (-e _) {
446             _die("$0: Input file $file was not found\n");
447         } else {
448             _die("$0: Cannot read input file $file: $!\n");
449         }
450     }
451     unless (-f _) {
452         # XXX: die?  don't try this on /dev/tty
453         warn "$0: WARNING: input $file is not a plain file\n";
454     } 
455 }
456
457 sub check_write {
458     my $file = shift;
459     if (-d $file) {
460         _die("$0: Cannot write on $file, is a directory\n");
461     }
462     if (-e _) {
463         _die("$0: Cannot write on $file: $!\n") unless -w _;
464     } 
465     unless (-w cwd()) { 
466         _die("$0: Cannot write in this directory: $!\n");
467     }
468 }
469
470 sub check_perl {
471     my $file = shift;
472     unless (-T $file) {
473         warn "$0: Binary `$file' sure doesn't smell like perl source!\n";
474         print "Checking file type... ";
475         system("file", $file);  
476         _die("Please try a perlier file!\n");
477     } 
478
479     open(my $handle, "<", $file)    or _die("XXX: can't open $file: $!");
480     local $_ = <$handle>;
481     if (/^#!/ && !/perl/) {
482         _die("$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n");
483     } 
484
485
486
487 # File spawning and error collecting
488 sub spawnit {
489         my ($command) = shift;
490         my (@error,@output);
491         my $errname;
492         (undef, $errname) = tempfile("pccXXXXX");
493         { 
494         open (S_OUT, "$command 2>$errname |")
495                 or _die("$0: Couldn't spawn the compiler.\n");
496         @output = <S_OUT>;
497         }
498         open (S_ERROR, $errname) or _die("$0: Couldn't read the error file.\n");
499         @error = <S_ERROR>;
500         close S_ERROR;
501         close S_OUT;
502         unlink $errname or _die("$0: Can't unlink error file $errname");
503         return (\@output, \@error);
504 }
505
506 sub helpme {
507        print "perlcc compiler frontend, version $VERSION\n\n";
508        { no warnings;
509        exec "pod2usage $0";
510        exec "perldoc $0";
511        exec "pod2text $0";
512        }
513 }
514
515 sub relativize {
516         my ($args) = @_;
517
518         return() if ($args =~ m"^[/\\]");
519         return("./$args");
520 }
521
522 sub _die {
523     $logfh->print(@_) if opt('log');
524     print STDERR @_;
525     exit(); # should die eventually. However, needed so that a 'make compile'
526             # can compile all the way through to the end for standard dist.
527 }
528
529 sub _usage_and_die {
530     _die(<<EOU);
531 $0: Usage:
532 $0 [-o executable] [-r] [-O|-B|-c|-S] [-log log] [source[.pl] | -e oneliner]
533 EOU
534 }
535
536 sub run {
537     my (@commands) = @_;
538
539     print interruptrun(@commands) if (!opt('log'));
540     $logfh->print(interruptrun(@commands)) if (opt('log'));
541 }
542
543 sub interruptrun
544 {
545     my (@commands) = @_;
546
547     my $command = join('', @commands);
548     local(*FD);
549     my $pid = open(FD, "$command |");
550     my $text;
551     
552     local($SIG{HUP}) = sub { kill 9, $pid; exit };
553     local($SIG{INT}) = sub { kill 9, $pid; exit };
554
555     my $needalarm = 
556           ($ENV{PERLCC_TIMEOUT} && 
557           $Config{'osname'} ne 'MSWin32' && 
558           $command =~ m"(^|\s)perlcc\s");
559
560     eval 
561     {
562          local($SIG{ALRM}) = sub { die "INFINITE LOOP"; };
563          alarm($ENV{PERLCC_TIMEOUT}) if ($needalarm);
564          $text = join('', <FD>);
565          alarm(0) if ($needalarm);
566     };
567
568     if ($@)
569     {
570         eval { kill 'HUP', $pid };
571         vprint 0, "SYSTEM TIMEOUT (infinite loop?)\n";
572     }
573
574     close(FD);
575     return($text);
576 }
577
578 sub is_win32() { $^O =~ m/^MSWin/ }
579 sub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i }
580
581 END {
582     unlink $cfile if ($cfile && !opt(S) && !opt(c));
583 }
584
585 __END__
586
587 =head1 NAME
588
589 perlcc - generate executables from Perl programs
590
591 =head1 SYNOPSIS
592
593     $ perlcc hello              # Compiles into executable 'a.out'
594     $ perlcc -o hello hello.pl  # Compiles into executable 'hello'
595
596     $ perlcc -O file            # Compiles using the optimised C backend
597     $ perlcc -B file            # Compiles using the bytecode backend
598
599     $ perlcc -c file            # Creates a C file, 'file.c'
600     $ perlcc -S -o hello file   # Creates a C file, 'file.c',
601                                 # then compiles it to executable 'hello'
602     $ perlcc -c out.c file      # Creates a C file, 'out.c' from 'file'
603
604     $ perlcc -e 'print q//'     # Compiles a one-liner into 'a.out'
605     $ perlcc -c -e 'print q//'  # Creates a C file 'a.out.c'
606
607     $ perlcc -I /foo hello      # extra headers (notice the space after -I)
608     $ perlcc -L /foo hello      # extra libraries (notice the space after -L)
609
610     $ perlcc -r hello           # compiles 'hello' into 'a.out', runs 'a.out'.
611     $ perlcc -r hello a b c     # compiles 'hello' into 'a.out', runs 'a.out'.
612                                 # with arguments 'a b c' 
613
614     $ perlcc hello -log c       # compiles 'hello' into 'a.out' logs compile
615                                 # log into 'c'. 
616
617 =head1 DESCRIPTION
618
619 F<perlcc> creates standalone executables from Perl programs, using the
620 code generators provided by the L<B> module. At present, you may
621 either create executable Perl bytecode, using the C<-B> option, or 
622 generate and compile C files using the standard and 'optimised' C
623 backends.
624
625 The code generated in this way is not guaranteed to work. The whole
626 codegen suite (C<perlcc> included) should be considered B<very>
627 experimental. Use for production purposes is strongly discouraged.
628
629 =head1 OPTIONS
630
631 =over 4
632
633 =item -LI<library directories>
634
635 Adds the given directories to the library search path when C code is
636 passed to your C compiler.
637
638 =item -II<include directories>
639
640 Adds the given directories to the include file search path when C code is
641 passed to your C compiler; when using the Perl bytecode option, adds the
642 given directories to Perl's include path.
643
644 =item -o I<output file name>
645
646 Specifies the file name for the final compiled executable.
647
648 =item -c I<C file name>
649
650 Create C code only; do not compile to a standalone binary.
651
652 =item -e I<perl code>
653
654 Compile a one-liner, much the same as C<perl -e '...'>
655
656 =item -S
657
658 Do not delete generated C code after compilation.
659
660 =item -B
661
662 Use the Perl bytecode code generator.
663
664 =item -O
665
666 Use the 'optimised' C code generator. This is more experimental than
667 everything else put together, and the code created is not guaranteed to
668 compile in finite time and memory, or indeed, at all.
669
670 =item -v
671
672 Increase verbosity of output; can be repeated for more verbose output.
673
674 =item -r 
675
676 Run the resulting compiled script after compiling it.
677
678 =item -log
679
680 Log the output of compiling to a file rather than to stdout.
681
682 =back
683
684 =cut
685
686 !NO!SUBS!
687
688 close OUT or die "Can't close $file: $!";
689 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
690 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
691 chdir $origdir;