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