diff options
| -rw-r--r-- | gv.c | 4 | ||||
| -rw-r--r-- | lib/English.pm | 4 | ||||
| -rw-r--r-- | perl.c | 3 | ||||
| -rw-r--r-- | pod/perlfunc.pod | 16 | ||||
| -rwxr-xr-x | t/io/pipe.t | 26 | ||||
| -rwxr-xr-x | t/op/exec.t | 2 | ||||
| -rwxr-xr-x | t/op/ipcsem.t | 38 | ||||
| -rw-r--r-- | util.c | 7 | ||||
| -rw-r--r-- | utils/h2ph.PL | 81 | ||||
| -rw-r--r-- | utils/h2xs.PL | 3 |
10 files changed, 147 insertions, 37 deletions
@@ -712,7 +712,7 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) case '!': if(len > 1) break; - if(sv_type == SVt_PVHV) { + if(sv_type > SVt_PV) { HV* stash = gv_stashpvn("Errno",5,FALSE); if(!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { dSP; @@ -721,7 +721,7 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) SPAGAIN; stash = gv_stashpvn("Errno",5,FALSE); if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) - croak("%! is not avaliable on this machine"); + croak("Can't use %%! because Errno.pm is not avaliable"); } } goto magicalize; diff --git a/lib/English.pm b/lib/English.pm index bbb6bd7b28..1cbacd11f8 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -137,8 +137,8 @@ sub import { # Error status. *CHILD_ERROR = *? ; - *OS_ERROR = *! ; - *ERRNO = *! ; + *OS_ERROR = \$! ; + *ERRNO = \$! ; *EXTENDED_OS_ERROR = *^E ; *EVAL_ERROR = *@ ; @@ -937,6 +937,9 @@ print \" \\@INC:\\n @INC\\n\";"); #endif init_predump_symbols(); + /* init_postdump_symbols not currently designed to be called */ + /* more than once (ENV isn't cleared first, for example) */ + /* But running with -u leaves %ENV & @ARGV undefined! XXX */ if (!do_undump) init_postdump_symbols(argc,argv,env); diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 617879852c..28a3ba152d 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -2998,9 +2998,10 @@ function, or use this relation: =item sleep Causes the script to sleep for EXPR seconds, or forever if no EXPR. -May be interrupted by sending the process a SIGALRM. Returns the -number of seconds actually slept. You probably cannot mix alarm() and -sleep() calls, because sleep() is often implemented using alarm(). +May be interrupted if the process receives a signal such as SIGALRM. +Returns the number of seconds actually slept. You probably cannot +mix alarm() and sleep() calls, because sleep() is often implemented +using alarm(). On some older systems, it may sleep up to a full second less than what you requested, depending on how it counts seconds. Most modern systems @@ -3038,9 +3039,10 @@ specified, it gives the name of a subroutine that returns an integer less than, equal to, or greater than 0, depending on how the elements of the array are to be ordered. (The C<E<lt>=E<gt>> and C<cmp> operators are extremely useful in such routines.) SUBNAME may be a -scalar variable name, in which case the value provides the name of the -subroutine to use. In place of a SUBNAME, you can provide a BLOCK as -an anonymous, in-line sort subroutine. +scalar variable name (unsubscripted), in which case the value provides +the name of (or a reference to) the actual subroutine to use. In place +of a SUBNAME, you can provide a BLOCK as an anonymous, in-line sort +subroutine. In the interests of efficiency the normal calling code for subroutines is bypassed, with the following effects: the subroutine may not be a @@ -3676,7 +3678,7 @@ signals and core dumps. # forked, so the errno value is not visible in the parent. printf "command failed: %s\n", ($! || "Unknown system() error"); } - elsif ($rc > 0x80) { + elsif (($rc & 0xff) == 0) { $rc >>= 8; print "ran with non-zero exit status $rc\n"; } diff --git a/t/io/pipe.t b/t/io/pipe.t index 0387e556ca..4a7cb7a423 100755 --- a/t/io/pipe.t +++ b/t/io/pipe.t @@ -13,7 +13,7 @@ BEGIN { } $| = 1; -print "1..10\n"; +print "1..12\n"; open(PIPE, "|-") || (exec 'tr', 'YX', 'ko'); print PIPE "Xk 1\n"; @@ -25,6 +25,7 @@ if (open(PIPE, "-|")) { s/^not //; print; } + close PIPE; # avoid zombies which disrupt test 12 } else { print STDOUT "not ok 3\n"; @@ -40,6 +41,7 @@ if ($pid = fork) { y/A-Z/a-z/; print; } + close READER; # avoid zombies which disrupt test 12 } else { die "Couldn't fork" unless defined $pid; @@ -66,11 +68,13 @@ sleep 1; print "ok 8\n"; # VMS doesn't like spawning subprocesses that are still connected to -# STDOUT. Someone should modify tests #9 and #10 to work with VMS. +# STDOUT. Someone should modify tests #9 to #12 to work with VMS. if ($^O eq 'VMS') { print "ok 9\n"; print "ok 10\n"; + print "ok 11\n"; + print "ok 12\n"; exit; } @@ -109,3 +113,21 @@ elsif ($? == 0) { else { print "ok 10\n"; } + +# check that status for the correct process is collected +my $zombie = fork or exit 37; +my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n"; +$SIG{ALRM} = sub { return }; +alarm(1); +my $close = close FH; +if ($? == 13*256 && ! length $close && ! $!) { + print "ok 11\n"; +} else { + print "not ok 11\n# close $close\$?=$? \$!=", $!+0, ":$!\n"; +}; +my $wait = wait; +if ($? == 37*256 && $wait == $zombie && ! $!) { + print "ok 12\n"; +} else { + print "not ok 12\n# pid=$wait \$?=$? \$!=", $!+0, ":$!\n"; +} diff --git a/t/op/exec.t b/t/op/exec.t index 7dfcd6177f..506fc09fbd 100755 --- a/t/op/exec.t +++ b/t/op/exec.t @@ -6,6 +6,7 @@ $| = 1; # flush stdout if ($^O eq 'MSWin32') { print "# exec is unsupported on Win32\n"; + # XXX the system tests could be written to use ./perl and so work on Win32 print "1..0\n"; exit(0); } @@ -16,6 +17,7 @@ print "not ok 1\n" if system "echo ok \\1"; # shell interpreted print "not ok 2\n" if system "echo ok 2"; # split and directly called print "not ok 3\n" if system "echo", "ok", "3"; # directly called +# these should probably be rewritten to match the examples in perlfunc.pod if (system "true") {print "not ok 4\n";} else {print "ok 4\n";} if ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; } diff --git a/t/op/ipcsem.t b/t/op/ipcsem.t index f3f6e3ce4c..73b8a8f351 100755 --- a/t/op/ipcsem.t +++ b/t/op/ipcsem.t @@ -30,12 +30,15 @@ BEGIN { print "1..0\n"; exit; } + + use strict; + my @incpath = (split(/\s+/, $Config{usrinc}), split(/\s+/ ,$Config{locincpth})); my %done = (); my %define = (); sub process_file { - my($file) = @_; + my($file,$level) = @_; return unless defined $file; @@ -51,40 +54,55 @@ BEGIN { return if exists $done{$path}; $done{$path} = 1; - unless(defined $path) { + if(not defined $path and $level == 0) { warn "Cannot find '$file'"; return; } + local(*F); open(F,$path) or return; + $level = 1 unless defined $level; + my $indent = " " x $level; + print "#$indent open $path\n"; while(<F>) { s#/\*.*(\*/|$)##; - process_file($mm,$1) - if /^#\s*include\s*[<"]([^>"]+)[>"]/; + if ( /^#\s*include\s*[<"]([^>"]+)[>"]/ ) { + print "#${indent} include $1\n"; + process_file($1,$level+1); + print "#${indent} done include $1\n"; + print "#${indent} back in $path\n"; + } s/(?:\([^)]*\)\s*)//; - $define{$1} = $2 - if /^#\s*define\s+(\w+)\s+((0x)?\d+|\w+)/; + if ( /^#\s*define\s+(\w+)\s+(\w+)/ ) { + print "#${indent} define $1 $2\n"; + $define{$1} = $2; + } } close(F); + print "#$indent close $path\n"; } process_file("sys/sem.h"); process_file("sys/ipc.h"); process_file("sys/stat.h"); - foreach $d (@define) { + foreach my $d (@define) { while(defined($define{$d}) && $define{$d} !~ /^(0x)?\d+$/) { $define{$d} = exists $define{$define{$d}} ? $define{$define{$d}} : undef; } unless(defined $define{$d}) { - print "0..0\n"; + print "# $d undefined\n"; + print "1..0\n"; exit; - }; - ${ $d } = eval $define{$d}; + } + { + no strict 'refs'; + ${ $d } = eval $define{$d}; + } } } @@ -2086,6 +2086,7 @@ my_pclose(PerlIO *ptr) int status; SV **svp; int pid; + int pid2; bool close_failed; int saved_errno; #ifdef VMS @@ -2120,8 +2121,8 @@ my_pclose(PerlIO *ptr) rsignal_save(SIGINT, SIG_IGN, &istat); rsignal_save(SIGQUIT, SIG_IGN, &qstat); do { - pid = wait4pid(pid, &status, 0); - } while (pid == -1 && errno == EINTR); + pid2 = wait4pid(pid, &status, 0); + } while (pid2 == -1 && errno == EINTR); rsignal_restore(SIGHUP, &hstat); rsignal_restore(SIGINT, &istat); rsignal_restore(SIGQUIT, &qstat); @@ -2129,7 +2130,7 @@ my_pclose(PerlIO *ptr) SETERRNO(saved_errno, saved_vaxc_errno); return -1; } - return(pid < 0 ? pid : status == 0 ? 0 : (errno = 0, status)); + return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)); } #endif /* !DOSISH */ diff --git a/utils/h2ph.PL b/utils/h2ph.PL index 2c685e0383..730c2259e7 100644 --- a/utils/h2ph.PL +++ b/utils/h2ph.PL @@ -38,7 +38,9 @@ use Config; use File::Path qw(mkpath); use Getopt::Std; -getopts('Dd:rlh'); +getopts('Dd:rlha'); +die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a); +@inc_dirs = inc_dirs() if $opt_a; my $Exit = 0; @@ -82,6 +84,14 @@ while (defined ($file = next_file())) { $dir = $1; mkpath "$Dest_dir/$dir"; } + + if ($opt_a) { # automagic mode: locate header file in @inc_dirs + foreach (@inc_dirs) { + chdir $_; + last if -f $file; + } + } + open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next); open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n"; } @@ -240,6 +250,9 @@ while (defined ($file = next_file())) { } } print OUT "1;\n"; + + $is_converted{$file} = 1; + queue_includes_from($file) if ($opt_a); } exit $Exit; @@ -380,7 +393,9 @@ sub next_file } else { print STDERR "Skipping directory `$file'\n"; } - } else { + } elsif ($opt_a) { + return $file; + } else { print STDERR "Skipping `$file': not a file or directory\n"; } } @@ -402,11 +417,8 @@ sub expand_glob # expand_glob() is going to be called until $ARGV[0] isn't a # directory; so push directories, and unshift everything else. - if (-d "$directory/$_") { - push @ARGV, "$directory/$_"; - } else { - unshift @ARGV, "$directory/$_"; - } + if (-d "$directory/$_") { push @ARGV, "$directory/$_" } + else { unshift @ARGV, "$directory/$_" } } closedir DIR; } @@ -431,12 +443,13 @@ sub link_if_possible unlink "$Dest_dir/$dirlink" or print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n"; } + if (eval 'symlink($target, "$Dest_dir/$dirlink")') { print "Linking $target -> $Dest_dir/$dirlink\n"; # Make sure that the link _links_ to something: if (! -e "$Dest_dir/$target") { - mkdir("$Dest_dir/$target", 0755) or + mkpath("$Dest_dir/$target", 0755) or print STDERR "Could not create $Dest_dir/$target/\n"; } } else { @@ -446,6 +459,41 @@ sub link_if_possible } +# Push all #included files in $file onto our stack, except for STDIN +# and files we've already processed. +sub queue_includes_from +{ + my ($file) = @_; + my $line; + + return if ($file eq "-"); + + open HEADER, $file or return; + while (defined($line = <HEADER>)) { + while (/\\$/) { # Handle continuation lines + chop $line; + $line .= <HEADER>; + } + + if ($line =~ /^#\s*include\s+<(.*?)>/) { + push(@ARGV, $1) unless $is_converted{$1}; + } + } + close HEADER; +} + + +# Determine include directories; $Config{usrinc} should be enough for (all +# non-GCC?) C compilers, but gcc uses an additional include directory. +sub inc_dirs +{ + my $from_gcc = `$Config{cc} -v 2>&1`; + $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s; + + length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc}); +} + + 1; ############################################################################## @@ -457,7 +505,7 @@ h2ph - convert .h C header files to .ph Perl header files =head1 SYNOPSIS -B<h2ph [-d destination directory] [-r] [-l] [headerfiles]> +B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]> =head1 DESCRIPTION @@ -490,7 +538,15 @@ beneath the default Perl library location (C<$Config{'installsitsearch'}>). =item -r Run recursively; if any of B<headerfiles> are directories, then run I<h2ph> -on all files in those directories (and their subdirectories, etc.). +on all files in those directories (and their subdirectories, etc.). B<-r> +and B<-a> are mutually exclusive. + +=item -a + +Run automagically; convert B<headerfiles>, as well as any B<.h> files +which they include. This option will search for B<.h> files in all +directories which your C compiler ordinarily uses. B<-a> and B<-r> are +mutually exclusive. =item -l @@ -511,6 +567,11 @@ you will see the slightly more helpful However, the B<.ph> files almost double in size when built using B<-h>. +=item -D + +Include the code from the B<.h> file as a comment in the B<.ph> file. +This is primarily used for debugging I<h2ph>. + =back =head1 ENVIRONMENT diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 800329103a..97d3ceded3 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -486,6 +486,7 @@ sub AUTOLOAD { my \$constname; (\$constname = \$AUTOLOAD) =~ s/.*:://; + croak "&$module::constant not defined" if \$constname eq 'constant'; my \$val = constant(\$constname, \@_ ? \$_[0] : 0); if (\$! != 0) { if (\$! =~ /Invalid/) { @@ -496,7 +497,7 @@ sub AUTOLOAD { croak "Your vendor has not defined $module macro \$constname"; } } - eval "sub \$AUTOLOAD { \$val }"; + *\$AUTOLOAD = sub () { \$val }; goto &\$AUTOLOAD; } |