Installer: Early check whether the installation directory is writable
[msysgit.git] / bin / perlcc
blob87759ebeac3ebb213811e849038113c6111b843f
1 #!/usr/bin/perl
2 eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
3 if $running_under_some_shell;
4 --$running_under_some_shell;
6 # Version 2.0, Simon Cozens, Thu Mar 30 17:52:45 JST 2000
7 # Version 2.01, Tom Christiansen, Thu Mar 30 08:25:14 MST 2000
8 # Version 2.02, Simon Cozens, Sun Apr 16 01:53:36 JST 2000
9 # Version 2.03, Edward Peschko, Mon Feb 26 12:04:17 PST 2001
10 # Version 2.04, Enache Adrian,Fri, 18 Jul 2003 23:15:37 +0300
12 use strict;
13 use warnings;
14 use 5.006_000;
16 use FileHandle;
17 use Config;
18 use Fcntl qw(:DEFAULT :flock);
19 use File::Temp qw(tempfile);
20 use Cwd;
21 our $VERSION = 2.04;
22 $| = 1;
24 $SIG{INT} = sub { exit(); }; # exit gracefully and clean up after ourselves.
26 use subs qw{
27 cc_harness check_read check_write checkopts_byte choose_backend
28 compile_byte compile_cstyle compile_module generate_code
29 grab_stash parse_argv sanity_check vprint yclept spawnit
31 sub opt(*); # imal quoting
32 sub is_win32();
33 sub is_msvc();
35 our ($Options, $BinPerl, $Backend);
36 our ($Input => $Output);
37 our ($logfh);
38 our ($cfile);
39 our (@begin_output); # output from BEGIN {}, for testsuite
41 # eval { main(); 1 } or die;
43 main();
45 sub main {
46 parse_argv();
47 check_write($Output);
48 choose_backend();
49 generate_code();
50 run_code();
51 _die("XXX: Not reached?");
54 #######################################################################
56 sub choose_backend {
57 # Choose the backend.
58 $Backend = 'C';
59 if (opt(B)) {
60 checkopts_byte();
61 $Backend = 'Bytecode';
63 if (opt(S) && opt(c)) {
64 # die "$0: Do you want me to compile this or not?\n";
65 delete $Options->{S};
67 $Backend = 'CC' if opt(O);
71 sub generate_code {
73 vprint 0, "Compiling $Input";
75 $BinPerl = yclept(); # Calling convention for perl.
77 if (opt(shared)) {
78 compile_module();
79 } else {
80 if ($Backend eq 'Bytecode') {
81 compile_byte();
82 } else {
83 compile_cstyle();
86 exit(0) if (!opt('r'));
89 sub run_code {
90 vprint 0, "Running code";
91 run("$Output @ARGV");
92 exit(0);
95 # usage: vprint [level] msg args
96 sub vprint {
97 my $level;
98 if (@_ == 1) {
99 $level = 1;
100 } elsif ($_[0] =~ /^\d$/) {
101 $level = shift;
102 } else {
103 # well, they forgot to use a number; means >0
104 $level = 0;
106 my $msg = "@_";
107 $msg .= "\n" unless substr($msg, -1) eq "\n";
108 if (opt(v) > $level)
110 print "$0: $msg" if !opt('log');
111 print $logfh "$0: $msg" if opt('log');
115 sub parse_argv {
117 use Getopt::Long;
119 # disallows using long arguments
120 # Getopt::Long::Configure("bundling");
122 Getopt::Long::Configure("no_ignore_case");
124 # no difference in exists and defined for %ENV; also, a "0"
125 # argument or a "" would not help cc, so skip
126 unshift @ARGV, split ' ', $ENV{PERLCC_OPTS} if $ENV{PERLCC_OPTS};
128 $Options = {};
129 Getopt::Long::GetOptions( $Options,
130 'L:s', # lib directory
131 'I:s', # include directories (FOR C, NOT FOR PERL)
132 'o:s', # Output executable
133 'v:i', # Verbosity level
134 'e:s', # One-liner
135 'r', # run resulting executable
136 'B', # Byte compiler backend
137 'O', # Optimised C backend
138 'c', # Compile only
139 'h', # Help me
140 'S', # Dump C files
141 'r', # run the resulting executable
142 'T', # run the backend using perl -T
143 't', # run the backend using perl -t
144 'static', # Dirty hack to enable -shared/-static
145 'shared', # Create a shared library (--shared for compat.)
146 'log:s', # where to log compilation process information
147 'Wb:s', # pass (comma-sepearated) options to backend
148 'testsuite', # try to be nice to testsuite
151 $Options->{v} += 0;
153 if( opt(t) && opt(T) ) {
154 warn "Can't specify both -T and -t, -t ignored";
155 $Options->{t} = 0;
158 helpme() if opt(h); # And exit
160 $Output = opt(o) || ( is_win32 ? 'a.exe' : 'a.out' );
161 $Output = is_win32() ? $Output : relativize($Output);
162 $logfh = new FileHandle(">> " . opt('log')) if (opt('log'));
164 if (opt(e)) {
165 warn "$0: using -e 'code' as input file, ignoring @ARGV\n" if @ARGV;
166 # We don't use a temporary file here; why bother?
167 # XXX: this is not bullet proof -- spaces or quotes in name!
168 $Input = is_win32() ? # Quotes eaten by shell
169 '-e "'.opt(e).'"' :
170 "-e '".opt(e)."'";
171 } else {
172 $Input = shift @ARGV; # XXX: more files?
173 _usage_and_die("$0: No input file specified\n") unless $Input;
174 # DWIM modules. This is bad but necessary.
175 $Options->{shared}++ if $Input =~ /\.pm\z/;
176 warn "$0: using $Input as input file, ignoring @ARGV\n" if @ARGV;
177 check_read($Input);
178 check_perl($Input);
179 sanity_check();
184 sub opt(*) {
185 my $opt = shift;
186 return exists($Options->{$opt}) && ($Options->{$opt} || 0);
189 sub compile_module {
190 die "$0: Compiling to shared libraries is currently disabled\n";
193 sub compile_byte {
194 my $command = "$BinPerl -MO=Bytecode,-H,-o$Output $Input";
195 $Input =~ s/^-e.*$/-e/;
197 my ($output_r, $error_r) = spawnit($command);
199 if (@$error_r && $? != 0) {
200 _die("$0: $Input did not compile:\n@$error_r\n");
201 } else {
202 my @error = grep { !/^$Input syntax OK$/o } @$error_r;
203 warn "$0: Unexpected compiler output:\n@error" if @error;
206 chmod 0777 & ~umask, $Output or _die("can't chmod $Output: $!");
207 exit 0;
210 sub compile_cstyle {
211 my $stash = grab_stash();
212 my $taint = opt(T) ? '-T' :
213 opt(t) ? '-t' : '';
215 # What are we going to call our output C file?
216 my $lose = 0;
217 my ($cfh);
218 my $testsuite = '';
219 my $addoptions = opt(Wb);
221 if( $addoptions ) {
222 $addoptions .= ',' if $addoptions !~ m/,$/;
225 if (opt(testsuite)) {
226 my $bo = join '', @begin_output;
227 $bo =~ s/\\/\\\\\\\\/gs;
228 $bo =~ s/\n/\\n/gs;
229 $bo =~ s/,/\\054/gs;
230 # don't look at that: it hurts
231 $testsuite = q{-fuse-script-name,-fsave-data,-fsave-sig-hash,}.
232 qq[-e"print q{$bo}",] .
233 q{-e"open(Test::Builder::TESTOUT\054 '>&STDOUT') or die $!",} .
234 q{-e"open(Test::Builder::TESTERR\054 '>&STDERR') or die $!",};
236 if (opt(S) || opt(c)) {
237 # We need to keep it.
238 if (opt(e)) {
239 $cfile = "a.out.c";
240 } else {
241 $cfile = $Input;
242 # File off extension if present
243 # hold on: plx is executable; also, careful of ordering!
244 $cfile =~ s/\.(?:p(?:lx|l|h)|m)\z//i;
245 $cfile .= ".c";
246 $cfile = $Output if opt(c) && $Output =~ /\.c\z/i;
248 check_write($cfile);
249 } else {
250 # Don't need to keep it, be safe with a tempfile.
251 $lose = 1;
252 ($cfh, $cfile) = tempfile("pccXXXXX", SUFFIX => ".c");
253 close $cfh; # See comment just below
255 vprint 1, "Writing C on $cfile";
257 my $max_line_len = '';
258 if ($^O eq 'MSWin32' && $Config{cc} =~ /^cl/i) {
259 $max_line_len = '-l2000,';
262 # This has to do the write itself, so we can't keep a lock. Life
263 # sucks.
264 my $command = "$BinPerl $taint -MO=$Backend,$addoptions$testsuite$max_line_len$stash,-o$cfile $Input";
265 vprint 1, "Compiling...";
266 vprint 1, "Calling $command";
268 my ($output_r, $error_r) = spawnit($command);
269 my @output = @$output_r;
270 my @error = @$error_r;
272 if (@error && $? != 0) {
273 _die("$0: $Input did not compile, which can't happen:\n@error\n");
276 is_msvc ?
277 cc_harness_msvc($cfile,$stash) :
278 cc_harness($cfile,$stash) unless opt(c);
280 if ($lose) {
281 vprint 2, "unlinking $cfile";
282 unlink $cfile or _die("can't unlink $cfile: $!");
286 sub cc_harness_msvc {
287 my ($cfile,$stash)=@_;
288 use ExtUtils::Embed ();
289 my $obj = "${Output}.obj";
290 my $compile = ExtUtils::Embed::ccopts." -c -Fo$obj $cfile ";
291 my $link = "-out:$Output $obj";
292 $compile .= " -I".$_ for split /\s+/, opt(I);
293 $link .= " -libpath:".$_ for split /\s+/, opt(L);
294 my @mods = split /-?u /, $stash;
295 $link .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
296 $link .= " perl5$Config{PERL_VERSION}.lib kernel32.lib msvcrt.lib";
297 vprint 3, "running $Config{cc} $compile";
298 system("$Config{cc} $compile");
299 vprint 3, "running $Config{ld} $link";
300 system("$Config{ld} $link");
303 sub cc_harness {
304 my ($cfile,$stash)=@_;
305 use ExtUtils::Embed ();
306 my $command = ExtUtils::Embed::ccopts." -o $Output $cfile ";
307 $command .= " -DUSEIMPORTLIB";
308 $command .= " -I".$_ for split /\s+/, opt(I);
309 $command .= " -L".$_ for split /\s+/, opt(L);
310 my @mods = split /-?u /, $stash;
311 $command .= " ".ExtUtils::Embed::ldopts("-std", \@mods);
312 $command .= " -lperl";
313 vprint 3, "running $Config{cc} $command";
314 system("$Config{cc} $command");
317 # Where Perl is, and which include path to give it.
318 sub yclept {
319 my $command = "$^X ";
321 # DWIM the -I to be Perl, not C, include directories.
322 if (opt(I) && $Backend eq "Bytecode") {
323 for (split /\s+/, opt(I)) {
324 if (-d $_) {
325 push @INC, $_;
326 } else {
327 warn "$0: Include directory $_ not found, skipping\n";
332 $command .= "-I$_ " for @INC;
333 return $command;
336 # Use B::Stash to find additional modules and stuff.
338 my $_stash;
339 sub grab_stash {
341 warn "already called get_stash once" if $_stash;
343 my $taint = opt(T) ? '-T' :
344 opt(t) ? '-t' : '';
345 my $command = "$BinPerl $taint -MB::Stash -c $Input";
346 # Filename here is perfectly sanitised.
347 vprint 3, "Calling $command\n";
349 my ($stash_r, $error_r) = spawnit($command);
350 my @stash = @$stash_r;
351 my @error = @$error_r;
353 if (@error && $? != 0) {
354 _die("$0: $Input did not compile:\n@error\n");
357 # band-aid for modules with noisy BEGIN {}
358 foreach my $i ( @stash ) {
359 $i =~ m/-u(?:[\w:]+|\<none\>)$/ and $stash[0] = $i and next;
360 push @begin_output, $i;
362 chomp $stash[0];
363 $stash[0] =~ s/,-u\<none\>//;
364 $stash[0] =~ s/^.*?-u/-u/s;
365 vprint 2, "Stash: ", join " ", split /,?-u/, $stash[0];
366 chomp $stash[0];
367 return $_stash = $stash[0];
372 # Check the consistency of options if -B is selected.
373 # To wit, (-B|-O) ==> no -shared, no -S, no -c
374 sub checkopts_byte {
376 _die("$0: Please choose one of either -B and -O.\n") if opt(O);
378 if (opt(shared)) {
379 warn "$0: Will not create a shared library for bytecode\n";
380 delete $Options->{shared};
383 for my $o ( qw[c S] ) {
384 if (opt($o)) {
385 warn "$0: Compiling to bytecode is a one-pass process--",
386 "-$o ignored\n";
387 delete $Options->{$o};
393 # Check the input and output files make sense, are read/writeable.
394 sub sanity_check {
395 if ($Input eq $Output) {
396 if ($Input eq 'a.out') {
397 _die("$0: Compiling a.out is probably not what you want to do.\n");
398 # You fully deserve what you get now. No you *don't*. typos happen.
399 } else {
400 warn "$0: Will not write output on top of input file, ",
401 "compiling to a.out instead\n";
402 $Output = "a.out";
407 sub check_read {
408 my $file = shift;
409 unless (-r $file) {
410 _die("$0: Input file $file is a directory, not a file\n") if -d _;
411 unless (-e _) {
412 _die("$0: Input file $file was not found\n");
413 } else {
414 _die("$0: Cannot read input file $file: $!\n");
417 unless (-f _) {
418 # XXX: die? don't try this on /dev/tty
419 warn "$0: WARNING: input $file is not a plain file\n";
423 sub check_write {
424 my $file = shift;
425 if (-d $file) {
426 _die("$0: Cannot write on $file, is a directory\n");
428 if (-e _) {
429 _die("$0: Cannot write on $file: $!\n") unless -w _;
431 unless (-w cwd()) {
432 _die("$0: Cannot write in this directory: $!\n");
436 sub check_perl {
437 my $file = shift;
438 unless (-T $file) {
439 warn "$0: Binary `$file' sure doesn't smell like perl source!\n";
440 print "Checking file type... ";
441 system("file", $file);
442 _die("Please try a perlier file!\n");
445 open(my $handle, "<", $file) or _die("XXX: can't open $file: $!");
446 local $_ = <$handle>;
447 if (/^#!/ && !/perl/) {
448 _die("$0: $file is a ", /^#!\s*(\S+)/, " script, not perl\n");
453 # File spawning and error collecting
454 sub spawnit {
455 my ($command) = shift;
456 my (@error,@output);
457 my $errname;
458 (undef, $errname) = tempfile("pccXXXXX");
460 open (S_OUT, "$command 2>$errname |")
461 or _die("$0: Couldn't spawn the compiler.\n");
462 @output = <S_OUT>;
464 open (S_ERROR, $errname) or _die("$0: Couldn't read the error file.\n");
465 @error = <S_ERROR>;
466 close S_ERROR;
467 close S_OUT;
468 unlink $errname or _die("$0: Can't unlink error file $errname");
469 return (\@output, \@error);
472 sub helpme {
473 print "perlcc compiler frontend, version $VERSION\n\n";
474 { no warnings;
475 exec "pod2usage $0";
476 exec "perldoc $0";
477 exec "pod2text $0";
481 sub relativize {
482 my ($args) = @_;
484 return() if ($args =~ m"^[/\\]");
485 return("./$args");
488 sub _die {
489 $logfh->print(@_) if opt('log');
490 print STDERR @_;
491 exit(); # should die eventually. However, needed so that a 'make compile'
492 # can compile all the way through to the end for standard dist.
495 sub _usage_and_die {
496 _die(<<EOU);
497 $0: Usage:
498 $0 [-o executable] [-r] [-O|-B|-c|-S] [-I /foo] [-L /foo] [-log log] [source[.pl] | -e oneliner]
502 sub run {
503 my (@commands) = @_;
505 print interruptrun(@commands) if (!opt('log'));
506 $logfh->print(interruptrun(@commands)) if (opt('log'));
509 sub interruptrun
511 my (@commands) = @_;
513 my $command = join('', @commands);
514 local(*FD);
515 my $pid = open(FD, "$command |");
516 my $text;
518 local($SIG{HUP}) = sub { kill 9, $pid; exit };
519 local($SIG{INT}) = sub { kill 9, $pid; exit };
521 my $needalarm =
522 ($ENV{PERLCC_TIMEOUT} &&
523 $Config{'osname'} ne 'MSWin32' &&
524 $command =~ m"(^|\s)perlcc\s");
526 eval
528 local($SIG{ALRM}) = sub { die "INFINITE LOOP"; };
529 alarm($ENV{PERLCC_TIMEOUT}) if ($needalarm);
530 $text = join('', <FD>);
531 alarm(0) if ($needalarm);
534 if ($@)
536 eval { kill 'HUP', $pid };
537 vprint 0, "SYSTEM TIMEOUT (infinite loop?)\n";
540 close(FD);
541 return($text);
544 sub is_win32() { $^O =~ m/^MSWin/ }
545 sub is_msvc() { is_win32 && $Config{cc} =~ m/^cl/i }
547 END {
548 unlink $cfile if ($cfile && !opt(S) && !opt(c));
551 __END__
553 =head1 NAME
555 perlcc - generate executables from Perl programs
557 =head1 SYNOPSIS
559 $ perlcc hello # Compiles into executable 'a.out'
560 $ perlcc -o hello hello.pl # Compiles into executable 'hello'
562 $ perlcc -O file # Compiles using the optimised C backend
563 $ perlcc -B file # Compiles using the bytecode backend
565 $ perlcc -c file # Creates a C file, 'file.c'
566 $ perlcc -S -o hello file # Creates a C file, 'file.c',
567 # then compiles it to executable 'hello'
568 $ perlcc -c out.c file # Creates a C file, 'out.c' from 'file'
570 $ perlcc -e 'print q//' # Compiles a one-liner into 'a.out'
571 $ perlcc -c -e 'print q//' # Creates a C file 'a.out.c'
573 $ perlcc -I /foo hello # extra headers (notice the space after -I)
574 $ perlcc -L /foo hello # extra libraries (notice the space after -L)
576 $ perlcc -r hello # compiles 'hello' into 'a.out', runs 'a.out'.
577 $ perlcc -r hello a b c # compiles 'hello' into 'a.out', runs 'a.out'.
578 # with arguments 'a b c'
580 $ perlcc hello -log c # compiles 'hello' into 'a.out' logs compile
581 # log into 'c'.
583 =head1 DESCRIPTION
585 F<perlcc> creates standalone executables from Perl programs, using the
586 code generators provided by the L<B> module. At present, you may
587 either create executable Perl bytecode, using the C<-B> option, or
588 generate and compile C files using the standard and 'optimised' C
589 backends.
591 The code generated in this way is not guaranteed to work. The whole
592 codegen suite (C<perlcc> included) should be considered B<very>
593 experimental. Use for production purposes is strongly discouraged.
595 =head1 OPTIONS
597 =over 4
599 =item -LI<library directories>
601 Adds the given directories to the library search path when C code is
602 passed to your C compiler.
604 =item -II<include directories>
606 Adds the given directories to the include file search path when C code is
607 passed to your C compiler; when using the Perl bytecode option, adds the
608 given directories to Perl's include path.
610 =item -o I<output file name>
612 Specifies the file name for the final compiled executable.
614 =item -c I<C file name>
616 Create C code only; do not compile to a standalone binary.
618 =item -e I<perl code>
620 Compile a one-liner, much the same as C<perl -e '...'>
622 =item -S
624 Do not delete generated C code after compilation.
626 =item -B
628 Use the Perl bytecode code generator.
630 =item -O
632 Use the 'optimised' C code generator. This is more experimental than
633 everything else put together, and the code created is not guaranteed to
634 compile in finite time and memory, or indeed, at all.
636 =item -v
638 Increase verbosity of output; can be repeated for more verbose output.
640 =item -r
642 Run the resulting compiled script after compiling it.
644 =item -log
646 Log the output of compiling to a file rather than to stdout.
648 =back
650 =cut