| 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 .= " perl5$Config{PERL_VERSION}.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] [-I /foo] [-L /foo] [-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;
|
|---|
