diff options
| -rw-r--r-- | doio.c | 65 | ||||
| -rw-r--r-- | ext/Socket/Socket.xs | 5 | ||||
| -rw-r--r-- | lib/Class/Struct.pm | 2 | ||||
| -rw-r--r-- | lib/Cwd.pm | 13 | ||||
| -rw-r--r-- | lib/File/Find.pm | 170 | ||||
| -rw-r--r-- | lib/Math/BigInt.pm | 6 | ||||
| -rw-r--r-- | lib/lib.pm | 4 | ||||
| -rw-r--r-- | lib/strict.pm | 15 | ||||
| -rw-r--r-- | op.c | 2 | ||||
| -rw-r--r-- | pod/perldiag.pod | 5 | ||||
| -rw-r--r-- | pod/perlfunc.pod | 16 | ||||
| -rw-r--r-- | pp.c | 21 | ||||
| -rw-r--r-- | pp_ctl.c | 7 | ||||
| -rw-r--r-- | sv.c | 14 | ||||
| -rwxr-xr-x | t/op/gv.t | 20 | ||||
| -rwxr-xr-x | t/op/misc.t | 5 | ||||
| -rwxr-xr-x | t/op/pack.t | 8 |
17 files changed, 222 insertions, 156 deletions
@@ -583,6 +583,7 @@ do_close(GV *gv, bool not_implicit) if (!io) { /* never opened */ if (dowarn && not_implicit) warn("Close on unopened file <%s>",GvENAME(gv)); + SETERRNO(EBADF,SS$_IVCHAN); return FALSE; } retval = io_close(io); @@ -619,6 +620,9 @@ io_close(IO *io) } IoOFP(io) = IoIFP(io) = Nullfp; } + else { + SETERRNO(EBADF,SS$_IVCHAN); + } return retval; } @@ -1033,9 +1037,14 @@ apply(I32 type, register SV **mark, register SV **sp) register I32 val; register I32 val2; register I32 tot = 0; + char *what; char *s; SV **oldmark = mark; +#define APPLY_TAINT_PROPER() \ + if (!(tainting && tainted)) {} else { goto taint_proper; } + + /* This is a first heuristic; it doesn't catch tainting magic. */ if (tainting) { while (++mark <= sp) { if (SvTAINTED(*mark)) { @@ -1047,25 +1056,33 @@ apply(I32 type, register SV **mark, register SV **sp) } switch (type) { case OP_CHMOD: - TAINT_PROPER("chmod"); + what = "chmod"; + APPLY_TAINT_PROPER(); if (++mark <= sp) { - tot = sp - mark; val = SvIVx(*mark); + APPLY_TAINT_PROPER(); + tot = sp - mark; while (++mark <= sp) { - if (PerlLIO_chmod(SvPVx(*mark, na),val)) + char *name = SvPVx(*mark, na); + APPLY_TAINT_PROPER(); + if (PerlLIO_chmod(name, val)) tot--; } } break; #ifdef HAS_CHOWN case OP_CHOWN: - TAINT_PROPER("chown"); + what = "chown"; + APPLY_TAINT_PROPER(); if (sp - mark > 2) { val = SvIVx(*++mark); val2 = SvIVx(*++mark); + APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { - if (chown(SvPVx(*mark, na),val,val2)) + char *name = SvPVx(*mark, na); + APPLY_TAINT_PROPER(); + if (chown(name, val, val2)) tot--; } } @@ -1073,11 +1090,11 @@ apply(I32 type, register SV **mark, register SV **sp) #endif #ifdef HAS_KILL case OP_KILL: - TAINT_PROPER("kill"); + what = "kill"; + APPLY_TAINT_PROPER(); if (mark == sp) break; s = SvPVx(*++mark, na); - tot = sp - mark; if (isUPPER(*s)) { if (*s == 'S' && s[1] == 'I' && s[2] == 'G') s += 3; @@ -1086,6 +1103,8 @@ apply(I32 type, register SV **mark, register SV **sp) } else val = SvIVx(*mark); + APPLY_TAINT_PROPER(); + tot = sp - mark; #ifdef VMS /* kill() doesn't do process groups (job trees?) under VMS */ if (val < 0) val = -val; @@ -1098,6 +1117,7 @@ apply(I32 type, register SV **mark, register SV **sp) while (++mark <= sp) { I32 proc = SvIVx(*mark); register unsigned long int __vmssts; + APPLY_TAINT_PROPER(); if (!((__vmssts = sys$delprc(&proc,0)) & 1)) { tot--; switch (__vmssts) { @@ -1120,6 +1140,7 @@ apply(I32 type, register SV **mark, register SV **sp) val = -val; while (++mark <= sp) { I32 proc = SvIVx(*mark); + APPLY_TAINT_PROPER(); #ifdef HAS_KILLPG if (PerlProc_killpg(proc,val)) /* BSD */ #else @@ -1130,17 +1151,21 @@ apply(I32 type, register SV **mark, register SV **sp) } else { while (++mark <= sp) { - if (PerlProc_kill(SvIVx(*mark),val)) + I32 proc = SvIVx(*mark); + APPLY_TAINT_PROPER(); + if (PerlProc_kill(proc, val)) tot--; } } break; #endif case OP_UNLINK: - TAINT_PROPER("unlink"); + what = "unlink"; + APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { s = SvPVx(*mark, na); + APPLY_TAINT_PROPER(); if (euid || unsafe) { if (UNLINK(s)) tot--; @@ -1161,7 +1186,8 @@ apply(I32 type, register SV **mark, register SV **sp) break; #ifdef HAS_UTIME case OP_UTIME: - TAINT_PROPER("utime"); + what = "utime"; + APPLY_TAINT_PROPER(); if (sp - mark > 2) { #if defined(I_UTIME) || defined(VMS) struct utimbuf utbuf; @@ -1180,9 +1206,12 @@ apply(I32 type, register SV **mark, register SV **sp) utbuf.actime = SvIVx(*++mark); /* time accessed */ utbuf.modtime = SvIVx(*++mark); /* time modified */ #endif + APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { - if (PerlLIO_utime(SvPVx(*mark, na),&utbuf)) + char *name = SvPVx(*mark, na); + APPLY_TAINT_PROPER(); + if (PerlLIO_utime(name, &utbuf)) tot--; } } @@ -1192,6 +1221,12 @@ apply(I32 type, register SV **mark, register SV **sp) #endif } return tot; + + taint_proper: + TAINT_PROPER(what); + return 0; /* this should never happen */ + +#undef APPLY_TAINT_PROPER } /* Do the permissions allow some operation? Assumes statcache already set. */ @@ -1305,7 +1340,7 @@ do_ipcget(I32 optype, SV **mark, SV **sp) return -1; /* should never happen */ } -#if defined(__sun__) && defined(__svr4__) /* XXX Need metaconfig test */ +#if defined(__sun) && defined(__svr4__) /* XXX Need metaconfig test */ /* Solaris manpage says that it uses (like linux) int semctl (int semid, int semnum, int cmd, union semun arg) but the system include files do not define union semun !!!! @@ -1325,7 +1360,7 @@ do_ipcctl(I32 optype, SV **mark, SV **sp) char *a; I32 id, n, cmd, infosize, getinfo; I32 ret = -1; -#if defined(__linux__) || (defined(__sun__) && defined(__svr4__)) +#if defined(__linux__) || (defined(__sun) && defined(__svr4__)) /* XXX Need metaconfig test */ union semun unsemds; #endif @@ -1358,7 +1393,7 @@ do_ipcctl(I32 optype, SV **mark, SV **sp) else if (cmd == GETALL || cmd == SETALL) { struct semid_ds semds; -#if defined(__linux__) || (defined(__sun__) && defined(__svr4__)) +#if defined(__linux__) || (defined(__sun) && defined(__svr4__)) /* XXX Need metaconfig test */ /* linux and Solaris2 uses : int semctl (int semid, int semnum, int cmd, union semun arg) @@ -1419,7 +1454,7 @@ do_ipcctl(I32 optype, SV **mark, SV **sp) #endif #ifdef HAS_SEM case OP_SEMCTL: -#if defined(__linux__) || (defined(__sun__) && defined(__svr4__)) +#if defined(__linux__) || (defined(__sun) && defined(__svr4__)) /* XXX Need metaconfig test */ unsemds.buf = (struct semid_ds *)a; ret = semctl(id, n, cmd, unsemds); diff --git a/ext/Socket/Socket.xs b/ext/Socket/Socket.xs index 823e704ed8..09b41d3fce 100644 --- a/ext/Socket/Socket.xs +++ b/ext/Socket/Socket.xs @@ -757,7 +757,10 @@ pack_sockaddr_un(pathname) STRLEN len; Zero( &sun_ad, sizeof sun_ad, char ); sun_ad.sun_family = AF_UNIX; - strncpy(sun_ad.sun_path, pathname, sizeof sun_ad.sun_path); + len = strlen(pathname); + if (len > sizeof(sun_ad.sun_path)) + len = sizeof(sun_ad.sun_path); + Copy( pathname, sun_ad.sun_path, len, char ); ST(0) = sv_2mortal(newSVpv((char *)&sun_ad, sizeof sun_ad)); #else ST(0) = (SV *) not_here("pack_sockaddr_un"); diff --git a/lib/Class/Struct.pm b/lib/Class/Struct.pm index 09ab196254..a39d1ac04a 100644 --- a/lib/Class/Struct.pm +++ b/lib/Class/Struct.pm @@ -180,7 +180,7 @@ sub struct { } elsif( defined $classes{$name} ){ if ( $CHECK_CLASS_MEMBERSHIP ) { - $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$type');\n"; + $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n"; } } $out .= " croak 'Too many args to $name' if \@_ > 1;\n"; diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 652ee7e493..64798da00f 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -20,11 +20,21 @@ getcwd - get pathname of current working directory chdir "/tmp"; print $ENV{'PWD'}; + use Cwd 'abs_path'; + print abs_path($ENV{'PWD'}); + + use Cwd 'fast_abs_path'; + print fast_abs_path($ENV{'PWD'}); + =head1 DESCRIPTION The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions in Perl. +The abs_path() function takes a single argument and returns the +absolute pathname for that argument. It uses the same algoritm as +getcwd(). (actually getcwd() is abs_path(".")) + The fastcwd() function looks the same as getcwd(), but runs faster. It's also more dangerous because it might conceivably chdir() you out of a directory that it can't chdir() you back into. If fastcwd @@ -35,6 +45,9 @@ that it leaves you in the same directory that it started in. If it has changed it will C<die> with the message "Unstable directory path, current directory changed unexpectedly". That should never happen. +The fast_abs_path() function looks the same as abs_path(), but runs faster. +And like fastcwd() is more dangerous. + The cwd() function looks the same as getcwd and fastgetcwd but is implemented using the most natural and safe form for the current architecture. For most systems it is identical to `pwd` (but without diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 7abebc6544..67abf6088b 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -1,10 +1,7 @@ package File::Find; require 5.000; require Exporter; -use Config; require Cwd; -require File::Basename; - =head1 NAME @@ -24,6 +21,17 @@ finddepth - traverse a directory structure depth-first =head1 DESCRIPTION +The first argument to find() is either a hash reference describing the +operations to be performed for each file, or a code reference. If it +is a hash reference, then the value for the key C<wanted> should be a +code reference. This code reference is called I<the wanted() +function> below. + +Currently the only other supported key for the above hash is +C<bydepth>, in presense of which the walk over directories is +performed depth-first. Entry point finddepth() is a shortcut for +specifying C<{ bydepth => 1}> in the first argument of find(). + The wanted() function does whatever verifications you want. $File::Find::dir contains the current directory name, and $_ the current filename within that directory. $File::Find::name contains @@ -34,7 +42,7 @@ prune the tree. File::Find assumes that you don't alter the $_ variable. If you do then make sure you return it to its original value before exiting your function. -This library is primarily for the C<find2perl> tool, which when fed, +This library is useful for the C<find2perl> tool, which when fed, find2perl / -name .nfs\* -mtime +7 \ -exec rm -f {} \; -o -fstype nfs -prune @@ -75,9 +83,10 @@ There is no way to make find or finddepth follow symlinks. @EXPORT = qw(find finddepth); -sub find { +sub find_opt { my $wanted = shift; - my $cwd = Cwd::cwd(); + my $bydepth = $wanted->{bydepth}; + my $cwd = $bydepth ? Cwd::fastcwd() : Cwd::cwd(); # Localize these rather than lexicalizing them for backwards # compatibility. local($topdir,$topdev,$topino,$topmode,$topnlink); @@ -87,27 +96,35 @@ sub find { || (warn("Can't stat $topdir: $!\n"), next); if (-d _) { if (chdir($topdir)) { - ($dir,$_) = ($topdir,'.'); - $name = $topdir; $prune = 0; - &$wanted; + unless ($bydepth) { + ($dir,$_) = ($topdir,'.'); + $name = $topdir; + $wanted->{wanted}->(); + } next if $prune; my $fixtopdir = $topdir; $fixtopdir =~ s,/$,, ; $fixtopdir =~ s/\.dir$// if $Is_VMS; - &finddir($wanted,$fixtopdir,$topnlink); + &finddir($wanted,$fixtopdir,$topnlink, $bydepth); + if ($bydepth) { + ($dir,$_) = ($fixtopdir,'.'); + $name = $fixtopdir; + $wanted->{wanted}->(); + } } else { warn "Can't cd to $topdir: $!\n"; } } else { + require File::Basename; unless (($_,$dir) = File::Basename::fileparse($topdir)) { ($dir,$_) = ('.', $topdir); } if (chdir($dir)) { $name = $topdir; - &$wanted; + $wanted->{wanted}->(); } else { warn "Can't cd to $dir: $!\n"; @@ -118,14 +135,14 @@ sub find { } sub finddir { - my($wanted, $nlink); + my($wanted, $nlink, $bydepth); local($dir, $name); - ($wanted, $dir, $nlink) = @_; + ($wanted, $dir, $nlink, $bydepth) = @_; my($dev, $ino, $mode, $subcount); # Get the list of files in the current directory. - opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return); + opendir(DIR,'.') || (warn("Can't open $dir: $!\n"), $bydepth || return); my(@filenames) = readdir(DIR); closedir(DIR); @@ -135,7 +152,7 @@ sub finddir { next if $_ eq '..'; $name = "$dir/$_"; $nlink = 0; - &$wanted; + $wanted->{wanted}->(); } } else { # This dir has subdirectories. @@ -143,9 +160,10 @@ sub finddir { for (@filenames) { next if $_ eq '.'; next if $_ eq '..'; - $nlink = $prune = 0; + $nlink = 0; + $prune = 0 unless $bydepth; $name = "$dir/$_"; - &$wanted; + $wanted->{wanted}->() unless $bydepth; if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? # Get link count and check for directoriness. @@ -161,7 +179,7 @@ sub finddir { next if $prune; if (chdir $_) { $name =~ s/\.dir$// if $Is_VMS; - &finddir($wanted,$name,$nlink); + &finddir($wanted,$name,$nlink, $bydepth); chdir '..'; } else { @@ -169,109 +187,26 @@ sub finddir { } } } + $wanted->{wanted}->() if $bydepth; } } } - -sub finddepth { - my $wanted = shift; - my $cwd = Cwd::cwd(); - # Localize these rather than lexicalizing them for backwards - # compatibility. - local($topdir,$topdev,$topino,$topmode,$topnlink); - foreach $topdir (@_) { - (($topdev,$topino,$topmode,$topnlink) = - ($Is_VMS ? stat($topdir) : lstat($topdir))) - || (warn("Can't stat $topdir: $!\n"), next); - if (-d _) { - if (chdir($topdir)) { - my $fixtopdir = $topdir; - $fixtopdir =~ s,/$,, ; - $fixtopdir =~ s/\.dir$// if $Is_VMS; - &finddepthdir($wanted,$fixtopdir,$topnlink); - ($dir,$_) = ($topdir,'.'); - $name = $topdir; - &$wanted; - } - else { - warn "Can't cd to $topdir: $!\n"; - } - } - else { - unless (($_,$dir) = File::Basename::fileparse($topdir)) { - ($dir,$_) = ('.', $topdir); - } - if (chdir($dir)) { - $name = $topdir; - &$wanted; - } - else { - warn "Can't cd to $dir: $!\n"; - } - } - chdir $cwd; - } +sub wrap_wanted { + my $wanted = shift; + defined &$wanted ? {wanted => $wanted} : $wanted; } -sub finddepthdir { - my($wanted, $nlink); - local($dir, $name); - ($wanted, $dir, $nlink) = @_; - my($dev, $ino, $mode, $subcount); - - # Get the list of files in the current directory. - opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return); - my(@filenames) = readdir(DIR); - closedir(DIR); - - if ($nlink == 2 && !$dont_use_nlink) { # This dir has no subdirectories. - for (@filenames) { - next if $_ eq '.'; - next if $_ eq '..'; - $name = "$dir/$_"; - $nlink = 0; - &$wanted; - } - } - else { # This dir has subdirectories. - $subcount = $nlink - 2; - for (@filenames) { - next if $_ eq '.'; - next if $_ eq '..'; - $nlink = 0; - $name = "$dir/$_"; - if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? - - # Get link count and check for directoriness. - - ($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_)); - - if (-d _) { - - # It really is a directory, so do it recursively. - - --$subcount; - if (chdir $_) { - $name =~ s/\.dir$// if $Is_VMS; - &finddepthdir($wanted,$name,$nlink); - chdir '..'; - } - else { - warn "Can't cd to $_: $!\n"; - } - } - } - &$wanted; - } - } +sub find { + my $wanted = shift; + find_opt(wrap_wanted($wanted), @_); } -# Set dont_use_nlink in your hint file if your system's stat doesn't -# report the number of links in a directory as an indication -# of the number of files. -# See, e.g. hints/machten.sh for MachTen 2.2. -$dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); +sub find_depth { + my $wanted = wrap_wanted(shift); + $wanted->{bydepth} = 1; + find_opt($wanted, @_); +} # These are hard-coded for now, but may move to hint files. if ($^O eq 'VMS') { @@ -282,5 +217,14 @@ if ($^O eq 'VMS') { $dont_use_nlink = 1 if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32'; +# Set dont_use_nlink in your hint file if your system's stat doesn't +# report the number of links in a directory as an indication +# of the number of files. +# See, e.g. hints/machten.sh for MachTen 2.2. +unless ($dont_use_nlink) { + require Config; + $dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); +} + 1; diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm index 422dca42fd..013e55fadb 100644 --- a/lib/Math/BigInt.pm +++ b/lib/Math/BigInt.pm @@ -171,7 +171,7 @@ sub add { #(int_num_array, int_num_array) return int_num_array $car = 0; for $x (@x) { last unless @y || $car; - $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0; + $x -= 1e5 if $car = (($x += (@y ? shift(@y) : 0) + $car) >= 1e5) ? 1 : 0; } for $y (@y) { last unless $car; @@ -185,8 +185,8 @@ sub sub { #(int_num_array, int_num_array) return int_num_array local(*sx, *sy) = @_; $bar = 0; for $sx (@sx) { - last unless @y || $bar; - $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0); + last unless @sy || $bar; + $sx += 1e5 if $bar = (($sx -= (@sy ? shift(@sy) : 0) + $bar) < 0); } @sx; } diff --git a/lib/lib.pm b/lib/lib.pm index 4d32f96355..6e6e15e4ce 100644 --- a/lib/lib.pm +++ b/lib/lib.pm @@ -18,6 +18,10 @@ sub import { Carp::carp("Empty compile time value given to use lib"); # at foo.pl line ... } + if (-e && ! -d _) { + require Carp; + Carp::carp("Parameter to use lib must be directory, not file"); + } unshift(@INC, $_); # Put a corresponding archlib directory infront of $_ if it # looks like $_ has an archlib directory below it. diff --git a/lib/strict.pm b/lib/strict.pm index 8492e933fd..176af387a0 100644 --- a/lib/strict.pm +++ b/lib/strict.pm @@ -72,14 +72,17 @@ See L<perlmod/Pragmatic Modules>. =cut +$strict::VERSION = "1.01"; + +my %bitmask = ( +refs => 0x00000002, +subs => 0x00000200, +vars => 0x00000400 +); + sub bits { my $bits = 0; - my $sememe; - foreach $sememe (@_) { - $bits |= 0x00000002, next if $sememe eq 'refs'; - $bits |= 0x00000200, next if $sememe eq 'subs'; - $bits |= 0x00000400, next if $sememe eq 'vars'; - } + foreach my $s (@_){ $bits |= $bitmask{$s} || 0; }; $bits; } @@ -4877,6 +4877,8 @@ peep(register OP *o) o->op_seq = op_seqmax++; if (dowarn && o->op_next && o->op_next->op_type == OP_NEXTSTATE) { if (o->op_next->op_sibling && + o->op_next->op_sibling->op_type != OP_EXIT && + o->op_next->op_sibling->op_type != OP_WARN && o->op_next->op_sibling->op_type != OP_DIE) { line_t oldline = curcop->cop_line; diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 96f5c671ea..dedde649a6 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -2565,6 +2565,11 @@ have been defined yet. See L<perlfunc/sort>. (F) The format indicated doesn't seem to exist. Perhaps it's really in another package? See L<perlform>. +=item Undefined value assigned to typeglob + +(W) An undefined value was assigned to a typeglob, a la C<*foo = undef>. +This does nothing. It's possible that you really mean C<undef *foo>. + =item unexec of %s into %s failed! (F) The unexec() routine failed for some reason. See your local FSF diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 8ed707970a..92dbc2a135 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -3795,19 +3795,21 @@ digits. See also L</oct>, if all you have is a string. =item undef Undefines the value of EXPR, which must be an lvalue. Use only on a -scalar value, an entire array, an entire hash, or a subroutine name (using -"&"). (Using undef() will probably not do what you expect on most -predefined variables or DBM list values, so don't do that.) Always -returns the undefined value. You can omit the EXPR, in which case -nothing is undefined, but you still get an undefined value that you -could, for instance, return from a subroutine, assign to a variable or -pass as a parameter. Examples: +scalar value, an array (using "@"), a hash (using "%"), a subroutine +(using "&"), or a typeglob (using "*"). (Saying C<undef $hash{$key}> +will probably not do what you expect on most predefined variables or +DBM list values, so don't do that; see L<delete>.) Always returns the +undefined value. You can omit the EXPR, in which case nothing is +undefined, but you still get an undefined value that you could, for +instance, return from a subroutine, assign to a variable or pass as a +parameter. Examples: undef $foo; undef $bar{'blurfl'}; # Compare to: delete $bar{'blurfl'}; undef @ary; undef %hash; undef &mysub; + undef *xyz; # destroys $xyz, @xyz, %xyz, &xyz, etc. return (wantarray ? (undef, $errmsg) : undef) if $they_blew_it; select undef, undef, undef, 0.25; ($a, $b, undef, $c) = &foo; # Ignore third value returned @@ -774,7 +774,17 @@ PP(pp_undef) break; case SVt_PVGV: if (SvFAKE(sv)) - sv_setsv(sv, &sv_undef); + SvSetMagicSV(sv, &sv_undef); + else { + GP *gp; + gp_free((GV*)sv); + Newz(602, gp, 1, GP); + GvGP(sv) = gp_ref(gp); + GvSV(sv) = NEWSV(72,0); + GvLINE(sv) = curcop->cop_line; + GvEGV(sv) = (GV*)sv; + GvMULTI_on(sv); + } break; default: if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) { @@ -1781,6 +1791,7 @@ PP(pp_substr) char *tmps; I32 arybase = curcop->cop_arybase; + SvTAINTED_off(TARG); /* decontaminate */ if (MAXARG > 2) len = POPi; pos = POPi; @@ -1869,6 +1880,7 @@ PP(pp_vec) unsigned long retnum; I32 len; + SvTAINTED_off(TARG); /* decontaminate */ offset *= size; /* turn into bit offset */ len = (offset + size + 7) / 8; if (offset < 0 || size < 1) @@ -3216,6 +3228,13 @@ PP(pp_unpack) Copy(s, &aint, 1, int); s += sizeof(int); sv = NEWSV(40, 0); +#ifdef __osf__ + /* Without the dummy below unpack("i", pack("i",-1)) + * return 0xFFffFFff instead of -1 for Digital Unix V4.0 + * cc with optimization turned on */ + (aint) ? + sv_setiv(sv, (IV)aint) : +#endif sv_setiv(sv, (IV)aint); PUSHs(sv_2mortal(sv)); } @@ -86,11 +86,10 @@ PP(pp_regcomp) { else { t = SvPV(tmpstr, len); - /* JMR: Check against the last compiled regexp - To know for sure, we'd need the length of precomp. - But we don't have it, so we must ... take a guess. */ + /* Check against the last compiled regexp. */ if (!pm->op_pmregexp || !pm->op_pmregexp->precomp || - memNE(pm->op_pmregexp->precomp, t, len + 1)) + pm->op_pmregexp->prelen != len || + memNE(pm->op_pmregexp->precomp, t, len)) { if (pm->op_pmregexp) { ReREFCNT_dec(pm->op_pmregexp); @@ -1906,8 +1906,11 @@ sv_setsv(SV *dstr, register SV *sstr) switch (stype) { case SVt_NULL: - (void)SvOK_off(dstr); - return; + if (dtype != SVt_PVGV) { + (void)SvOK_off(dstr); + return; + } + break; case SVt_IV: if (dtype != SVt_IV && dtype < SVt_PVIV) { if (dtype < SVt_IV) @@ -2209,7 +2212,12 @@ sv_setsv(SV *dstr, register SV *sstr) SvIVX(dstr) = SvIVX(sstr); } else { - (void)SvOK_off(dstr); + if (dtype == SVt_PVGV) { + if (dowarn) + warn("Undefined value assigned to typeglob"); + } + else + (void)SvOK_off(dstr); } SvTAINT(dstr); } @@ -4,7 +4,7 @@ # various typeglob tests # -print "1..13\n"; +print "1..18\n"; # type coersion on assignment $foo = 'foo'; @@ -65,3 +65,21 @@ if (defined $baa) { { package Foo::Bar } print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n"; print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n"; + +# test undef operator clearing out entire glob +$foo = 'stuff'; +@foo = qw(more stuff); +%foo = qw(even more random stuff); +undef *foo; +print +($foo || @foo || %foo) ? "not ok" : "ok", " 16\n"; + +# test warnings from assignment of undef to glob +{ + my $msg; + local $SIG{__WARN__} = sub { $msg = $_[0] }; + local $^W = 1; + *foo = 'bar'; + print $msg ? "not ok" : "ok", " 17\n"; + *foo = undef; + print $msg ? "ok" : "not ok", " 18\n"; +} diff --git a/t/op/misc.t b/t/op/misc.t index 582ffa7905..9ab6831859 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -368,6 +368,11 @@ EXPECT 1 2 ######## +-w +sub testme { my $a = "test"; { local $a = "new test"; print $a }} +EXPECT +Can't localize lexical variable $a at - line 2. +######## package X; sub ascalar { my $r; bless \$r } sub DESTROY { print "destroyed\n" }; diff --git a/t/op/pack.t b/t/op/pack.t index f9a89a3ec0..de5fcff218 100755 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -2,7 +2,7 @@ # $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $ -print "1..29\n"; +print "1..30\n"; $format = "c2 x5 C C x s d i l a6"; # Need the expression in here to force ary[5] to be numeric. This avoids @@ -100,3 +100,9 @@ sub foo { my $a = "a"; return $a . $a++ . $a++ } # undef should give null pointer print((pack("p", undef) =~ /^\0+/ ? "ok " : "not ok "),$test++,"\n"); +# Check for optimizer bug (e.g. Digital Unix GEM cc with -O4 on DU V4.0B gives +# 4294967295 instead of -1) +# see #ifdef __osf__ in pp.c pp_unpack +# Test 30: +print( ((unpack("i",pack("i",-1))) == -1 ? "ok " : "not ok "),$test++,"\n"); + |