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