diff options
-rwxr-xr-x | contrib/perl5/configpm | 98 | ||||
-rw-r--r-- | contrib/perl5/ext/IPC/SysV/Makefile.PL | 4 | ||||
-rw-r--r-- | contrib/perl5/ext/POSIX/Makefile.PL | 7 | ||||
-rw-r--r-- | contrib/perl5/ext/POSIX/POSIX.xs | 130 | ||||
-rw-r--r-- | contrib/perl5/hints/freebsd.sh | 7 | ||||
-rw-r--r-- | contrib/perl5/lib/Cwd.pm | 122 | ||||
-rw-r--r-- | contrib/perl5/lib/ExtUtils/Install.pm | 132 | ||||
-rw-r--r-- | contrib/perl5/lib/ExtUtils/Liblist.pm | 86 | ||||
-rw-r--r-- | contrib/perl5/lib/ExtUtils/MM_Unix.pm | 136 | ||||
-rw-r--r-- | contrib/perl5/lib/ExtUtils/MakeMaker.pm | 161 | ||||
-rw-r--r-- | contrib/perl5/patchlevel.h | 2 | ||||
-rw-r--r-- | contrib/perl5/perl.c | 542 | ||||
-rw-r--r-- | contrib/perl5/perl.h | 305 | ||||
-rw-r--r-- | contrib/perl5/pp.c | 684 | ||||
-rw-r--r-- | contrib/perl5/utils/h2ph.PL | 45 | ||||
-rw-r--r-- | contrib/perl5/utils/perlbug.PL | 150 |
16 files changed, 1711 insertions, 900 deletions
diff --git a/contrib/perl5/configpm b/contrib/perl5/configpm index 6429a58..cd117f2 100755 --- a/contrib/perl5/configpm +++ b/contrib/perl5/configpm @@ -129,41 +129,84 @@ sub FETCH { # Search for it in the big string my($value, $start, $marker, $quote_type); - $marker = "$_[1]="; + $quote_type = "'"; - # return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m); - # Check for the common case, ' delimeted - $start = index($config_sh, "\n$marker$quote_type"); - # If that failed, check for " delimited - if ($start == -1) { - $quote_type = '"'; - $start = index($config_sh, "\n$marker$quote_type"); - } - return undef if ( ($start == -1) && # in case it's first - (substr($config_sh, 0, length($marker)) ne $marker) ); - if ($start == -1) { - # It's the very first thing we found. Skip $start forward - # and figure out the quote mark after the =. - $start = length($marker) + 1; - $quote_type = substr($config_sh, $start - 1, 1); - } - else { - $start += length($marker) + 2; + # Virtual entries. + if ($_[1] eq 'byteorder') { + # byteorder does exist on its own but we overlay a virtual + # dynamically recomputed value. + my $t = $Config{ivtype}; + my $s = $Config{ivsize}; + my $f = $t eq 'long' ? 'L!' : $s == 8 ? 'Q': 'I'; + if ($s == 4 || $s == 8) { + my $i = 0; + foreach my $c (reverse(2..$s)) { $i |= ord($c); $i <<= 8 } + $i |= ord(1); + $value = join('', unpack('a'x$s, pack($f, $i))); + } else { + $value = '?'x$s; + } + } elsif ($_[1] =~ /^((?:cc|ld)flags|libs(?:wanted)?)_nolargefiles/) { + # These are purely virtual, they do not exist, but need to + # be computed on demand for largefile-incapable extensions. + my $key = "${1}_uselargefiles"; + $value = $Config{$1}; + my $withlargefiles = $Config{$key}; + if ($key =~ /^(?:cc|ld)flags_/) { + $value =~ s/\Q$withlargefiles\E\b//; + } elsif ($key =~ /^libs/) { + my @lflibswanted = split(' ', $Config{libswanted_uselargefiles}); + if (@lflibswanted) { + my %lflibswanted; + @lflibswanted{@lflibswanted} = (); + if ($key =~ /^libs_/) { + my @libs = grep { /^-l(.+)/ && + not exists $lflibswanted{$1} } + split(' ', $Config{libs}); + $Config{libs} = join(' ', @libs); + } elsif ($key =~ /^libswanted_/) { + my @libswanted = grep { not exists $lflibswanted{$_} } + split(' ', $Config{libswanted}); + $Config{libswanted} = join(' ', @libswanted); + } + } + } + } else { + $marker = "$_[1]="; + # return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m); + # Check for the common case, ' delimeted + $start = index($config_sh, "\n$marker$quote_type"); + # If that failed, check for " delimited + if ($start == -1) { + $quote_type = '"'; + $start = index($config_sh, "\n$marker$quote_type"); + } + return undef if ( ($start == -1) && # in case it's first + (substr($config_sh, 0, length($marker)) ne $marker) ); + if ($start == -1) { + # It's the very first thing we found. Skip $start forward + # and figure out the quote mark after the =. + $start = length($marker) + 1; + $quote_type = substr($config_sh, $start - 1, 1); + } + else { + $start += length($marker) + 2; + } + $value = substr($config_sh, $start, + index($config_sh, "$quote_type\n", $start) - $start); } - $value = substr($config_sh, $start, - index($config_sh, "$quote_type\n", $start) - $start); - # If we had a double-quote, we'd better eval it so escape # sequences and such can be interpolated. Since the incoming # value is supposed to follow shell rules and not perl rules, # we escape any perl variable markers if ($quote_type eq '"') { - $value =~ s/\$/\\\$/g; - $value =~ s/\@/\\\@/g; - eval "\$value = \"$value\""; + $value =~ s/\$/\\\$/g; + $value =~ s/\@/\\\@/g; + eval "\$value = \"$value\""; } #$value = sprintf($value) if $quote_type eq '"'; - $value = undef if $value eq 'undef'; # So we can say "if $Config{'foo'}". + # So we can say "if $Config{'foo'}". + $value = undef if $value eq 'undef'; $_[0]->{$_[1]} = $value; # cache it return $value; } @@ -192,7 +235,8 @@ sub EXISTS { index($config_sh, "\n$_[1]='") != -1 or substr($config_sh, 0, length($_[1])+2) eq "$_[1]='" or index($config_sh, "\n$_[1]=\"") != -1 or - substr($config_sh, 0, length($_[1])+2) eq "$_[1]=\""; + substr($config_sh, 0, length($_[1])+2) eq "$_[1]=\"" or + $_[1] =~ /^(?:(?:cc|ld)flags|libs(?:wanted)?)_nolargefiles$/; } sub STORE { die "\%Config::Config is read-only\n" } diff --git a/contrib/perl5/ext/IPC/SysV/Makefile.PL b/contrib/perl5/ext/IPC/SysV/Makefile.PL index a4de7a9..dfea962 100644 --- a/contrib/perl5/ext/IPC/SysV/Makefile.PL +++ b/contrib/perl5/ext/IPC/SysV/Makefile.PL @@ -1,5 +1,5 @@ # This -*- perl -*- script makes the Makefile -# $Id: Makefile.PL,v 1.1.1.2 1999/05/02 14:20:37 markm Exp $ +# $FreeBSD$ require 5.002; use ExtUtils::MakeMaker; @@ -31,7 +31,7 @@ WriteMakefile( 'clean' => {FILES => join(" ", map { "$_ */$_ */*/$_" } - qw(*% *.html *.b[ac]k *.old *.orig)) + qw(*% *.html *.b[ac]k *.old)) }, 'macro' => { INSTALLDIRS => 'perl' }, ); diff --git a/contrib/perl5/ext/POSIX/Makefile.PL b/contrib/perl5/ext/POSIX/Makefile.PL index c035d75..5127b4d 100644 --- a/contrib/perl5/ext/POSIX/Makefile.PL +++ b/contrib/perl5/ext/POSIX/Makefile.PL @@ -3,12 +3,7 @@ use ExtUtils::MakeMaker; use Config; my @libs; if ($^O ne 'MSWin32') { - if ($Config{archname} =~ /RM\d\d\d-svr4/) { - @libs = ('LIBS' => ["-lm -lc -lposix -lcposix"]); - } - else { - @libs = ('LIBS' => ["-lm -lposix -lcposix"]); - } + @libs = ('LIBS' => ["-lm -lposix -lcposix"]); } WriteMakefile( NAME => 'POSIX', diff --git a/contrib/perl5/ext/POSIX/POSIX.xs b/contrib/perl5/ext/POSIX/POSIX.xs index 1dd4ae3..ef7d78a 100644 --- a/contrib/perl5/ext/POSIX/POSIX.xs +++ b/contrib/perl5/ext/POSIX/POSIX.xs @@ -56,6 +56,9 @@ #ifdef I_UNISTD #include <unistd.h> #endif +#ifdef MACOS_TRADITIONAL +#undef fdopen +#endif #include <fcntl.h> #if defined(__VMS) && !defined(__POSIX_SOURCE) @@ -81,7 +84,7 @@ /* The non-POSIX CRTL times() has void return type, so we just get the current time directly */ - clock_t vms_times(struct tms *PL_bufptr) { + clock_t vms_times(struct tms *bufptr) { dTHX; clock_t retval; /* Get wall time and convert to 10 ms intervals to @@ -102,7 +105,7 @@ _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder)); # endif /* Fill in the struct tms using the CRTL routine . . .*/ - times((tbuffer_t *)PL_bufptr); + times((tbuffer_t *)bufptr); return (clock_t) retval; } # define times(t) vms_times(t) @@ -140,10 +143,12 @@ # define sigdelset(a,b) not_here("sigdelset") # define sigfillset(a) not_here("sigfillset") # define sigismember(a,b) not_here("sigismember") +# define setuid(a) not_here("setuid") +# define setgid(a) not_here("setgid") #else # ifndef HAS_MKFIFO -# ifdef OS2 +# if defined(OS2) || defined(MACOS_TRADITIONAL) # define mkfifo(a,b) not_here("mkfifo") # else /* !( defined OS2 ) */ # ifndef mkfifo @@ -152,12 +157,17 @@ # endif # endif /* !HAS_MKFIFO */ -# include <grp.h> -# include <sys/times.h> -# ifdef HAS_UNAME -# include <sys/utsname.h> +# ifdef MACOS_TRADITIONAL +# define ttyname(a) (char*)not_here("ttyname") +# define tzset() not_here("tzset") +# else +# include <grp.h> +# include <sys/times.h> +# ifdef HAS_UNAME +# include <sys/utsname.h> +# endif +# include <sys/wait.h> # endif -# include <sys/wait.h> # ifdef I_UTIME # include <utime.h> # endif @@ -530,12 +540,12 @@ mini_mktime(struct tm *ptm) } #ifdef HAS_LONG_DOUBLE -# if LONG_DOUBLESIZE > DOUBLESIZE +# if LONG_DOUBLESIZE > NVSIZE # undef HAS_LONG_DOUBLE /* XXX until we figure out how to use them */ # endif #endif -#ifndef HAS_LONG_DOUBLE +#ifndef HAS_LONG_DOUBLE #ifdef LDBL_MAX #undef LDBL_MAX #endif @@ -555,11 +565,7 @@ not_here(char *s) } static -#if defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE) -long double -#else -double -#endif +NV constant(char *name, int arg) { errno = 0; @@ -1518,6 +1524,11 @@ constant(char *name, int arg) break; case 'H': if (strEQ(name, "HUGE_VAL")) +#if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) + /* HUGE_VALL is admittedly non-POSIX but if we are using long doubles + * we might as well use long doubles. --jhi */ + return HUGE_VALL; +#endif #ifdef HUGE_VAL return HUGE_VAL; #else @@ -2292,9 +2303,9 @@ constant(char *name, int arg) #else goto not_there; #endif - if (strEQ(name, "STRERR_FILENO")) -#ifdef STRERR_FILENO - return STRERR_FILENO; + if (strEQ(name, "STDERR_FILENO")) +#ifdef STDERR_FILENO + return STDERR_FILENO; #else goto not_there; #endif @@ -3006,7 +3017,7 @@ setcc(termios_ref, ccix, cc) MODULE = POSIX PACKAGE = POSIX -double +NV constant(name,arg) char * name int arg @@ -3162,7 +3173,7 @@ localeconv() #ifdef HAS_LOCALECONV struct lconv *lcbuf; RETVAL = newHV(); - if (lcbuf = localeconv()) { + if ((lcbuf = localeconv())) { /* the strings */ if (lcbuf->decimal_point && *lcbuf->decimal_point) hv_store(RETVAL, "decimal_point", 13, @@ -3295,73 +3306,73 @@ setlocale(category, locale = 0) RETVAL -double +NV acos(x) - double x + NV x -double +NV asin(x) - double x + NV x -double +NV atan(x) - double x + NV x -double +NV ceil(x) - double x + NV x -double +NV cosh(x) - double x + NV x -double +NV floor(x) - double x + NV x -double +NV fmod(x,y) - double x - double y + NV x + NV y void frexp(x) - double x + NV x PPCODE: int expvar; /* (We already know stack is long enough.) */ PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar)))); PUSHs(sv_2mortal(newSViv(expvar))); -double +NV ldexp(x,exp) - double x + NV x int exp -double +NV log10(x) - double x + NV x void modf(x) - double x + NV x PPCODE: - double intvar; + NV intvar; /* (We already know stack is long enough.) */ - PUSHs(sv_2mortal(newSVnv(modf(x,&intvar)))); + PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); PUSHs(sv_2mortal(newSVnv(intvar))); -double +NV sinh(x) - double x + NV x -double +NV tan(x) - double x + NV x -double +NV tanh(x) - double x + NV x SysRet sigaction(sig, action, oldaction = 0) @@ -3407,9 +3418,8 @@ sigaction(sig, action, oldaction = 0) /* Set up any desired mask. */ svp = hv_fetch(action, "MASK", 4, FALSE); if (svp && sv_isa(*svp, "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(*svp)); - sigset = (sigset_t*) tmp; + IV tmp = SvIV((SV*)SvRV(*svp)); + sigset = INT2PTR(sigset_t*, tmp); act.sa_mask = *sigset; } else @@ -3434,9 +3444,8 @@ sigaction(sig, action, oldaction = 0) /* Get back the mask. */ svp = hv_fetch(oldaction, "MASK", 4, TRUE); if (sv_isa(*svp, "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(*svp)); - sigset = (sigset_t*) tmp; + IV tmp = SvIV((SV*)SvRV(*svp)); + sigset = INT2PTR(sigset_t*, tmp); } else { New(0, sigset, 1, sigset_t); @@ -3507,7 +3516,7 @@ SysRet nice(incr) int incr -int +void pipe() PPCODE: int fds[2]; @@ -3550,7 +3559,7 @@ tcsetpgrp(fd, pgrp_id) int fd pid_t pgrp_id -int +void uname() PPCODE: #ifdef HAS_UNAME @@ -3684,7 +3693,7 @@ strtoul(str, base = 0) PUSHs(&PL_sv_undef); } -SV * +void strxfrm(src) SV * src CODE: @@ -3819,7 +3828,10 @@ mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) OUTPUT: RETVAL -char * +#XXX: if $xsubpp::WantOptimize is always the default +# sv_setpv(TARG, ...) could be used rather than +# ST(0) = sv_2mortal(newSVpv(...)) +void strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) char * fmt int sec diff --git a/contrib/perl5/hints/freebsd.sh b/contrib/perl5/hints/freebsd.sh index 734409a..ef40999 100644 --- a/contrib/perl5/hints/freebsd.sh +++ b/contrib/perl5/hints/freebsd.sh @@ -87,8 +87,6 @@ case "$osvers" in d_setegid='undef' d_seteuid='undef' ;; -# -# Guesses at what will be needed after 2.2 *) usevfork='true' usemymalloc='n' libswanted=`echo $libswanted | sed 's/ malloc / /'` @@ -180,7 +178,7 @@ $define|true|[yY]*) 0*|1*|2.0*|2.1*) cat <<EOM >&4 I did not know that FreeBSD $osvers supports POSIX threads. -Feel free to tell perlbug@perl.com otherwise. +Feel free to tell perlbug@perl.org otherwise. EOM exit 1 ;; @@ -190,7 +188,8 @@ EOM POSIX threads are not supported well by FreeBSD $osvers. Please consider upgrading to at least FreeBSD 2.2.8, -or preferably to 3.something. +or preferably to the most recent -RELEASE or -STABLE +version (see http://www.freebsd.org/releases/). (While 2.2.7 does have pthreads, it has some problems with the combination of threads and pipes and therefore diff --git a/contrib/perl5/lib/Cwd.pm b/contrib/perl5/lib/Cwd.pm index 9c078c6..b7acfe8 100644 --- a/contrib/perl5/lib/Cwd.pm +++ b/contrib/perl5/lib/Cwd.pm @@ -4,7 +4,7 @@ require 5.000; =head1 NAME -getcwd - get pathname of current working directory +Cwd - get pathname of current working directory =head1 SYNOPSIS @@ -15,6 +15,9 @@ getcwd - get pathname of current working directory $dir = getcwd; use Cwd; + $dir = fastcwd; + + use Cwd; $dir = fastgetcwd; use Cwd 'chdir'; @@ -29,16 +32,21 @@ getcwd - get pathname of current working directory =head1 DESCRIPTION +This module provides functions for determining the pathname of the +current working directory. By default, it exports the functions +cwd(), getcwd(), fastcwd(), and fastgetcwd() into the caller's +namespace. Each of these functions are called without arguments and +return the absolute path of the current working directory. It is +recommended that cwd (or another *cwd() function) be used in I<all> +code to ensure portability. + +The cwd() is the most natural and safe form for the current +architecture. For most systems it is identical to `pwd` (but without +the trailing line terminator). + 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 algorithm -as getcwd(). (Actually, getcwd() is abs_path(".")) Symbolic links -and relative-path components ("." and "..") are resolved to return -the canonical pathname, just like realpath(3). Also callable as -realpath(). - 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 @@ -49,16 +57,17 @@ 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 fastgetcwd() function is provided as a synonym for cwd(). -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 -the trailing line terminator). +The abs_path() function takes a single argument and returns the +absolute pathname for that argument. It uses the same algorithm as +getcwd(). (Actually, getcwd() is abs_path(".")) Symbolic links and +relative-path components ("." and "..") are resolved to return the +canonical pathname, just like realpath(3). This function is also +callable as realpath(). -It is recommended that cwd (or another *cwd() function) is used in -I<all> code to ensure portability. +The fast_abs_path() function looks the same as abs_path() but runs +faster and, like fastcwd(), is more dangerous. If you ask to override your chdir() built-in function, then your PWD environment variable will be kept up to date. (See @@ -67,31 +76,42 @@ kept up to date if all packages which use chdir import it from Cwd. =cut -## use strict; +use strict; use Carp; -$VERSION = '2.02'; +our $VERSION = '2.04'; -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); -@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); +use base qw/ Exporter /; +our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); +our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); # The 'natural and safe form' for UNIX (pwd may be setuid root) sub _backtick_pwd { - my $cwd; - chop($cwd = `/bin/pwd`); + my $cwd = `/bin/pwd`; + # `pwd` may fail e.g. if the disk is full + chomp($cwd) if defined $cwd; $cwd; } # Since some ports may predefine cwd internally (e.g., NT) # we take care not to override an existing definition for cwd(). -*cwd = \&_backtick_pwd unless defined &cwd; +unless(defined &cwd) { + # The pwd command is not available in some chroot(2)'ed environments + if($^O eq 'MacOS' || grep { -x "$_/pwd" } split(':', $ENV{PATH})) { + *cwd = \&_backtick_pwd; + } + else { + *cwd = \&getcwd; + } +} +# set a reasonable (and very safe) default for fastgetcwd, in case it +# isn't redefined later (20001212 rspier) +*fastgetcwd = \&cwd; # By Brandon S. Allbery # @@ -157,7 +177,7 @@ sub fastcwd { my $chdir_init = 0; sub chdir_init { - if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos') { + if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { @@ -165,10 +185,12 @@ sub chdir_init { } } else { - $ENV{'PWD'} = cwd(); + my $wd = cwd(); + $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32'; + $ENV{'PWD'} = $wd; } # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) - if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { + if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { my($pd,$pi) = stat($2); my($dd,$di) = stat($1); if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { @@ -179,11 +201,27 @@ sub chdir_init { } sub chdir { - my $newdir = shift || ''; # allow for no arg (chdir to HOME dir) - $newdir =~ s|///*|/|g; + my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) + $newdir =~ s|///*|/|g unless $^O eq 'MSWin32'; chdir_init() unless $chdir_init; + my $newpwd; + if ($^O eq 'MSWin32') { + # get the full path name *before* the chdir() + $newpwd = Win32::GetFullPathName($newdir); + } + return 0 unless CORE::chdir $newdir; - if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} } + + if ($^O eq 'VMS') { + return $ENV{'PWD'} = $ENV{'DEFAULT'} + } + elsif ($^O eq 'MacOS') { + return $ENV{'PWD'} = cwd(); + } + elsif ($^O eq 'MSWin32') { + $ENV{'PWD'} = $newpwd; + return 1; + } if ($newdir =~ m#^/#s) { $ENV{'PWD'} = $newdir; @@ -264,7 +302,7 @@ sub abs_path sub fast_abs_path { my $cwd = getcwd(); - my $path = shift || '.'; + my $path = @_ ? shift : '.'; CORE::chdir($path) || croak "Cannot chdir to $path:$!"; my $realpath = getcwd(); CORE::chdir($cwd) || croak "Cannot chdir back to $cwd:$!"; @@ -333,12 +371,17 @@ sub _qnx_cwd { } sub _qnx_abs_path { - my $path = shift || '.'; + my $path = @_ ? shift : '.'; my $realpath=`/usr/bin/fullpath -t $path`; chop $realpath; return $realpath; } +sub _epoc_cwd { + $ENV{'PWD'} = EPOC::getcwd(); + return $ENV{'PWD'}; +} + { no warnings; # assignments trigger 'subroutine redefined' warning @@ -387,6 +430,19 @@ sub _qnx_abs_path { *fastcwd = \&cwd; *abs_path = \&fast_abs_path; } + elsif ($^O eq 'epoc') { + *cwd = \&_epoc_cwd; + *getcwd = \&_epoc_cwd; + *fastgetcwd = \&_epoc_cwd; + *fastcwd = \&_epoc_cwd; + *abs_path = \&fast_abs_path; + } + elsif ($^O eq 'MacOS') { + *getcwd = \&cwd; + *fastgetcwd = \&cwd; + *fastcwd = \&cwd; + *abs_path = \&fast_abs_path; + } } # package main; eval join('',<DATA>) || die $@; # quick test diff --git a/contrib/perl5/lib/ExtUtils/Install.pm b/contrib/perl5/lib/ExtUtils/Install.pm index aa6c764..9a8e857 100644 --- a/contrib/perl5/lib/ExtUtils/Install.pm +++ b/contrib/perl5/lib/ExtUtils/Install.pm @@ -18,6 +18,28 @@ my $splitchar = $^O eq 'VMS' ? '|' : ($^O eq 'os2' || $^O eq 'dos') ? ';' : ':'; my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || ''; my $Inc_uninstall_warn_handler; +# install relative to here + +my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT}; + +use File::Spec; + +sub install_rooted_file { + if (defined $INSTALL_ROOT) { + MY->catfile($INSTALL_ROOT, $_[0]); + } else { + $_[0]; + } +} + +sub install_rooted_dir { + if (defined $INSTALL_ROOT) { + MY->catdir($INSTALL_ROOT, $_[0]); + } else { + $_[0]; + } +} + #our(@EXPORT, @ISA, $Is_VMS); #use strict; @@ -57,8 +79,9 @@ sub install { opendir DIR, $source_dir_or_file or next; for (readdir DIR) { next if $_ eq "." || $_ eq ".." || $_ eq ".exists"; - if (-w $hash{$source_dir_or_file} || - mkpath($hash{$source_dir_or_file})) { + my $targetdir = install_rooted_dir($hash{$source_dir_or_file}); + if (-w $targetdir || + mkpath($targetdir)) { last; } else { warn "Warning: You do not have permissions to " . @@ -68,7 +91,8 @@ sub install { } closedir DIR; } - $packlist->read($pack{"read"}) if (-f $pack{"read"}); + my $tmpfile = install_rooted_file($pack{"read"}); + $packlist->read($tmpfile) if (-f $tmpfile); my $cwd = cwd(); my($source); @@ -85,11 +109,13 @@ sub install { #October 1997: we want to install .pm files into archlib if #there are any files in arch. So we depend on having ./blib/arch #hardcoded here. - my $targetroot = $hash{$source}; + + my $targetroot = install_rooted_dir($hash{$source}); + if ($source eq "blib/lib" and exists $hash{"blib/arch"} and directory_not_empty("blib/arch")) { - $targetroot = $hash{"blib/arch"}; + $targetroot = install_rooted_dir($hash{"blib/arch"}); print "Files found in blib/arch: installing files in blib/lib into architecture dependent library tree\n"; } chdir($source) or next; @@ -98,8 +124,9 @@ sub install { $atime,$mtime,$ctime,$blksize,$blocks) = stat; return unless -f _; return if $_ eq ".exists"; - my $targetdir = MY->catdir($targetroot,$File::Find::dir); - my $targetfile = MY->catfile($targetdir,$_); + my $targetdir = MY->catdir($targetroot, $File::Find::dir); + my $origfile = $_; + my $targetfile = MY->catfile($targetdir, $_); my $diff = 0; if ( -f $targetfile && -s _ == $size) { @@ -136,16 +163,16 @@ sub install { } else { inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0 } - $packlist->{$targetfile}++; + $packlist->{$origfile}++; }, "."); chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!"); } if ($pack{'write'}) { - $dir = dirname($pack{'write'}); + $dir = install_rooted_dir(dirname($pack{'write'})); mkpath($dir,0,0755); print "Writing $pack{'write'}\n"; - $packlist->write($pack{'write'}); + $packlist->write(install_rooted_file($pack{'write'})); } } @@ -242,8 +269,22 @@ sub inc_uninstall { } } +sub run_filter { + my ($cmd, $src, $dest) = @_; + local *SRC, *CMD; + open(CMD, "|$cmd >$dest") || die "Cannot fork: $!"; + open(SRC, $src) || die "Cannot open $src: $!"; + my $buf; + my $sz = 1024; + while (my $len = sysread(SRC, $buf, $sz)) { + syswrite(CMD, $buf, $len); + } + close SRC; + close CMD or die "Filter command '$cmd' failed for $src"; +} + sub pm_to_blib { - my($fromto,$autodir) = @_; + my($fromto,$autodir,$pm_filter) = @_; use File::Basename qw(dirname); use File::Copy qw(copy); @@ -266,23 +307,37 @@ sub pm_to_blib { mkpath($autodir,0,0755); foreach (keys %$fromto) { - next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_; - unless (compare($_,$fromto->{$_})){ - print "Skip $fromto->{$_} (unchanged)\n"; + my $dest = $fromto->{$_}; + next if -f $dest && -M $dest < -M $_; + + # When a pm_filter is defined, we need to pre-process the source first + # to determine whether it has changed or not. Therefore, only perform + # the comparison check when there's no filter to be ran. + # -- RAM, 03/01/2001 + + my $need_filtering = defined $pm_filter && length $pm_filter && /\.pm$/; + + if (!$need_filtering && 0 == compare($_,$dest)) { + print "Skip $dest (unchanged)\n"; next; } - if (-f $fromto->{$_}){ - forceunlink($fromto->{$_}); + if (-f $dest){ + forceunlink($dest); } else { - mkpath(dirname($fromto->{$_}),0,0755); + mkpath(dirname($dest),0,0755); + } + if ($need_filtering) { + run_filter($pm_filter, $_, $dest); + print "$pm_filter <$_ >$dest\n"; + } else { + copy($_,$dest); + print "cp $_ $dest\n"; } - copy($_,$fromto->{$_}); my($mode,$atime,$mtime) = (stat)[2,8,9]; - utime($atime,$mtime+$Is_VMS,$fromto->{$_}); - chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_}); - print "cp $_ $fromto->{$_}\n"; - next unless /\.pm\z/; - autosplit($fromto->{$_},$autodir); + utime($atime,$mtime+$Is_VMS,$dest); + chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$dest); + next unless /\.pm$/; + autosplit($dest,$autodir); } } @@ -296,18 +351,20 @@ sub add { } sub DESTROY { - my $self = shift; - my($file,$i,$plural); - foreach $file (sort keys %$self) { - $plural = @{$self->{$file}} > 1 ? "s" : ""; - print "## Differing version$plural of $file found. You might like to\n"; - for (0..$#{$self->{$file}}) { - print "rm ", $self->{$file}[$_], "\n"; - $i++; + unless(defined $INSTALL_ROOT) { + my $self = shift; + my($file,$i,$plural); + foreach $file (sort keys %$self) { + $plural = @{$self->{$file}} > 1 ? "s" : ""; + print "## Differing version$plural of $file found. You might like to\n"; + for (0..$#{$self->{$file}}) { + print "rm ", $self->{$file}[$_], "\n"; + $i++; + } + } + $plural = $i>1 ? "all those files" : "this file"; + print "## Running 'make install UNINST=1' will unlink $plural for you.\n"; } - } - $plural = $i>1 ? "all those files" : "this file"; - print "## Running 'make install UNINST=1' will unlink $plural for you.\n"; } 1; @@ -370,6 +427,11 @@ no-don't-really-do-it-now switch. pm_to_blib() takes a hashref as the first argument and copies all keys of the hash to the corresponding values efficiently. Filenames with the extension pm are autosplit. Second argument is the autosplit -directory. +directory. If third argument is not empty, it is taken as a filter command +to be ran on each .pm file, the output of the command being what is finally +copied, and the source for auto-splitting. + +You can have an environment variable PERL_INSTALL_ROOT set which will +be prepended as a directory to each installed file (and directory). =cut diff --git a/contrib/perl5/lib/ExtUtils/Liblist.pm b/contrib/perl5/lib/ExtUtils/Liblist.pm index 6da7395..75e3c08 100644 --- a/contrib/perl5/lib/ExtUtils/Liblist.pm +++ b/contrib/perl5/lib/ExtUtils/Liblist.pm @@ -1,10 +1,31 @@ # $FreeBSD$ package ExtUtils::Liblist; +@ISA = qw(ExtUtils::Liblist::Kid File::Spec); + +sub lsdir { + shift; + my $rex = qr/$_[1]/; + opendir my $dir, $_[0]; + grep /$rex/, readdir $dir; +} + +sub file_name_is_absolute { + require File::Spec; + shift; + 'File::Spec'->file_name_is_absolute(@_); +} + + +package ExtUtils::Liblist::Kid; + +# This kid package is to be used by MakeMaker. It will not work if +# $self is not a Makemaker. + use 5.005_64; # Broken out of MakeMaker from version 4.11 -our $VERSION = substr q$Revision: 1.25 $, 10; +our $VERSION = substr q$Revision: 1.26 $, 10; use Config; use Cwd 'cwd'; @@ -17,19 +38,19 @@ sub ext { } sub _unix_os2_ext { - my($self,$potential_libs, $verbose) = @_; - if ($^O =~ 'os2' and $Config{libs}) { + my($self,$potential_libs, $verbose, $give_libs) = @_; + if ($^O =~ 'os2' and $Config{perllibs}) { # Dynamic libraries are not transitive, so we may need including # the libraries linked against perl.dll again. $potential_libs .= " " if $potential_libs; - $potential_libs .= $Config{libs}; + $potential_libs .= $Config{perllibs}; } - return ("", "", "", "") unless $potential_libs; + return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs; warn "Potential libraries are '$potential_libs':\n" if $verbose; my($so) = $Config{'so'}; - my($libs) = $Config{'libs'}; + my($libs) = $Config{'perllibs'}; my $Config_libext = $Config{lib_ext} || ".a"; @@ -40,6 +61,7 @@ sub _unix_os2_ext { my(@searchpath); # from "-L/path" entries in $potential_libs my(@libpath) = split " ", $Config{'libpth'}; my(@ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen); + my(@libs, %libs_seen); my($fullname, $thislib, $thispth, @fullname); my($pwd) = cwd(); # from Cwd.pm my($found) = 0; @@ -133,6 +155,7 @@ sub _unix_os2_ext { warn "'-l$thislib' found at $fullname\n" if $verbose; my($fullnamedir) = dirname($fullname); push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++; + push @libs, $fullname unless $libs_seen{$fullname}++; $found++; $found_lib++; @@ -180,28 +203,29 @@ sub _unix_os2_ext { ."No library found for -l$thislib\n" unless $found_lib>0; } - return ('','','','') unless $found; - ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path)); + return ('','','','', ($give_libs ? \@libs : ())) unless $found; + ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path), ($give_libs ? \@libs : ())); } sub _win32_ext { require Text::ParseWords; - my($self, $potential_libs, $verbose) = @_; + my($self, $potential_libs, $verbose, $give_libs) = @_; # If user did not supply a list, we punt. # (caller should probably use the list in $Config{libs}) - return ("", "", "", "") unless $potential_libs; + return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs; my $cc = $Config{cc}; my $VC = 1 if $cc =~ /^cl/i; my $BC = 1 if $cc =~ /^bcc/i; my $GC = 1 if $cc =~ /^gcc/i; my $so = $Config{'so'}; - my $libs = $Config{'libs'}; + my $libs = $Config{'perllibs'}; my $libpth = $Config{'libpth'}; my $libext = $Config{'lib_ext'} || ".lib"; + my(@libs, %libs_seen); if ($libs and $potential_libs !~ /:nodefault/i) { # If Config.pm defines a set of default libs, we always @@ -231,6 +255,10 @@ sub _win32_ext { # add "$Config{installarchlib}/CORE" to default search path push @libpath, "$Config{installarchlib}/CORE"; + if ($VC and exists $ENV{LIB} and $ENV{LIB}) { + push @libpath, split /;/, $ENV{LIB}; + } + foreach (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){ $thislib = $_; @@ -295,6 +323,7 @@ sub _win32_ext { $found++; $found_lib++; push(@extralibs, $fullname); + push @libs, $fullname unless $libs_seen{$fullname}++; last; } @@ -316,10 +345,11 @@ sub _win32_ext { } - return ('','','','') unless $found; + return ('','','','', ($give_libs ? \@libs : ())) unless $found; # make sure paths with spaces are properly quoted @extralibs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @extralibs; + @libs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @libs; $lib = join(' ',@extralibs); # normalize back to backward slashes (to help braindead tools) @@ -328,18 +358,18 @@ sub _win32_ext { $lib =~ s,/,\\,g; warn "Result: $lib\n" if $verbose; - wantarray ? ($lib, '', $lib, '') : $lib; + wantarray ? ($lib, '', $lib, '', ($give_libs ? \@libs : ())) : $lib; } sub _vms_ext { - my($self, $potential_libs,$verbose) = @_; + my($self, $potential_libs,$verbose,$give_libs) = @_; my(@crtls,$crtlstr); my($dbgqual) = $self->{OPTIMIZE} || $Config{'optimize'} || $self->{CCFLAS} || $Config{'ccflags'}; @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') . 'PerlShr/Share' ); - push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'}); push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); # In general, we pass through the basic libraries from %Config unchanged. # The one exception is that if we're building in the Perl source tree, and @@ -362,7 +392,7 @@ sub _vms_ext { unless ($potential_libs) { warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose; - return ('', '', $crtlstr, ''); + return ('', '', $crtlstr, '', ($give_libs ? [] : ())); } my(@dirs,@libs,$dir,$lib,%found,@fndlibs,$ldlib); @@ -371,6 +401,7 @@ sub _vms_ext { # List of common Unix library names and there VMS equivalents # (VMS equivalent of '' indicates that the library is automatially # searched by the linker, and should be skipped here.) + my(@flibs, %libs_seen); my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '', 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '', 'socket' => '', 'X11' => 'DECW$XLIBSHR', @@ -475,6 +506,7 @@ sub _vms_ext { if ($cand eq 'VAXCCURSE') { unshift @{$found{$ctype}}, $cand; } else { push @{$found{$ctype}}, $cand; } warn "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1; + push @flibs, $name unless $libs_seen{$fullname}++; next LIB; } } @@ -489,7 +521,7 @@ sub _vms_ext { $ldlib = $crtlstr ? "$lib $crtlstr" : $lib; warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose; - wantarray ? ($lib, '', $ldlib, '') : $lib; + wantarray ? ($lib, '', $ldlib, '', ($give_libs ? \@flibs : ())) : $lib; } 1; @@ -504,20 +536,22 @@ ExtUtils::Liblist - determine libraries to use and how to use them C<require ExtUtils::Liblist;> -C<ExtUtils::Liblist::ext($self, $potential_libs, $verbose);> +C<ExtUtils::Liblist::ext($self, $potential_libs, $verbose, $need_names);> =head1 DESCRIPTION This utility takes a list of libraries in the form C<-llib1 -llib2 --llib3> and prints out lines suitable for inclusion in an extension +-llib3> and returns lines suitable for inclusion in an extension Makefile. Extra library paths may be included with the form C<-L/another/path> this will affect the searches for all subsequent libraries. -It returns an array of four scalar values: EXTRALIBS, BSLOADLIBS, -LDLOADLIBS, and LD_RUN_PATH. Some of these don't mean anything -on VMS and Win32. See the details about those platform specifics -below. +It returns an array of four or five scalar values: EXTRALIBS, +BSLOADLIBS, LDLOADLIBS, LD_RUN_PATH, and, optionally, a reference to +the array of the filenames of actual libraries. Some of these don't +mean anything unless on Unix. See the details about those platform +specifics below. The list of the filenames is returned only if +$need_names argument is true. Dependent libraries can be linked in one of three ways: @@ -625,7 +659,7 @@ Unix-OS/2 version in several respects: =item * If C<$potential_libs> is empty, the return value will be empty. -Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) +Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) will be appended to the list of C<$potential_libs>. The libraries will be searched for in the directories specified in C<$potential_libs>, C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. @@ -669,7 +703,7 @@ Entries in C<$potential_libs> beginning with a colon and followed by alphanumeric characters are treated as flags. Unknown flags will be ignored. An entry that matches C</:nodefault/i> disables the appending of default -libraries found in C<$Config{libs}> (this should be only needed very rarely). +libraries found in C<$Config{perllibs}> (this should be only needed very rarely). An entry that matches C</:nosearch/i> disables all searching for the libraries specified after it. Translation of C<-Lfoo> and @@ -679,7 +713,7 @@ valid files or directories. An entry that matches C</:search/i> reenables searching for the libraries specified after it. You can put it at the end to -enable searching for default libraries specified by C<$Config{libs}>. +enable searching for default libraries specified by C<$Config{perllibs}>. =item * diff --git a/contrib/perl5/lib/ExtUtils/MM_Unix.pm b/contrib/perl5/lib/ExtUtils/MM_Unix.pm index 891c533..4284eb1 100644 --- a/contrib/perl5/lib/ExtUtils/MM_Unix.pm +++ b/contrib/perl5/lib/ExtUtils/MM_Unix.pm @@ -209,6 +209,7 @@ sub ExtUtils::MM_Unix::parse_version ; sub ExtUtils::MM_Unix::pasthru ; sub ExtUtils::MM_Unix::path ; sub ExtUtils::MM_Unix::perl_archive; +sub ExtUtils::MM_Unix::perl_archive_after; sub ExtUtils::MM_Unix::perl_script ; sub ExtUtils::MM_Unix::perldepend ; sub ExtUtils::MM_Unix::pm_to_blib ; @@ -306,8 +307,8 @@ sub cflags { $libperl ||= $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ; $libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/; - @cflags{qw(cc ccflags optimize large split shellflags)} - = @Config{qw(cc ccflags optimize large split shellflags)}; + @cflags{qw(cc ccflags optimize shellflags)} + = @Config{qw(cc ccflags optimize shellflags)}; my($optdebug) = ""; $cflags{shellflags} ||= ''; @@ -342,16 +343,12 @@ sub cflags { optimize=\"$cflags{optimize}\" perltype=\"$cflags{perltype}\" optdebug=\"$cflags{optdebug}\" - large=\"$cflags{large}\" - split=\"$cflags{'split'}\" eval '$prog' echo cc=\$cc echo ccflags=\$ccflags echo optimize=\$optimize echo perltype=\$perltype echo optdebug=\$optdebug - echo large=\$large - echo split=\$split `; my($line); foreach $line (@o){ @@ -369,7 +366,7 @@ sub cflags { $cflags{optimize} = $optdebug; } - for (qw(ccflags optimize perltype large split)) { + for (qw(ccflags optimize perltype)) { $cflags{$_} =~ s/^\s+//; $cflags{$_} =~ s/\s+/ /g; $cflags{$_} =~ s/\s+$//; @@ -412,8 +409,6 @@ sub cflags { CCFLAGS = $self->{CCFLAGS} OPTIMIZE = $self->{OPTIMIZE} PERLTYPE = $self->{PERLTYPE} -LARGE = $self->{LARGE} -SPLIT = $self->{SPLIT} MPOLLUTE = $pollute }; @@ -458,7 +453,7 @@ EOT push(@otherfiles, qw[./blib $(MAKE_APERL_FILE) $(INST_ARCHAUTODIR)/extralibs.all perlmain.c mon.out core core.*perl.*.? *perl.core so_locations pm_to_blib - *~ */*~ */*/*~ *$(OBJ_EXT) *$(LIB_EXT) perl.exe + *$(OBJ_EXT) *$(LIB_EXT) perl.exe $(BOOTSTRAP) $(BASEEXT).bso $(BASEEXT).def $(BASEEXT).exp ]); @@ -484,7 +479,7 @@ sub const_cccmd { return '' unless $self->needs_linking(); return $self->{CONST_CCCMD} = q{CCCMD = $(CC) -c $(INC) $(CCFLAGS) $(OPTIMIZE) \\ - $(PERLTYPE) $(LARGE) $(SPLIT) $(MPOLLUTE) $(DEFINE_VERSION) \\ + $(PERLTYPE) $(MPOLLUTE) $(DEFINE_VERSION) \\ $(XS_DEFINE_VERSION)}; } @@ -587,7 +582,7 @@ MM_VERSION = $ExtUtils::MakeMaker::VERSION for $tmp (qw/ FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT - LDFROM LINKTYPE + LDFROM LINKTYPE PM_FILTER / ) { next unless defined $self->{$tmp}; push @m, "$tmp = $self->{$tmp}\n"; @@ -681,6 +676,10 @@ EXPORT_LIST = $tmp push @m, " PERL_ARCHIVE = $tmp "; + $tmp = $self->perl_archive_after; + push @m, " +PERL_ARCHIVE_AFTER = $tmp +"; # push @m, q{ #INST_PM = }.join(" \\\n\t", sort values %{$self->{PM}}).q{ @@ -813,7 +812,7 @@ DIST_DEFAULT = $dist_default =item dist_basics (o) -Defines the targets distclean, distcheck, skipcheck, manifest. +Defines the targets distclean, distcheck, skipcheck, manifest, veryclean. =cut @@ -841,6 +840,11 @@ manifest : $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=mkmanifest \\ -e mkmanifest }; + + push @m, q{ +veryclean : realclean + $(RM_F) *~ *.orig */*~ */*.orig +}; join "", @m; } @@ -1063,7 +1067,7 @@ ARMAYBE = '.$armaybe.' OTHERLDFLAGS = '.$otherldflags.' INST_DYNAMIC_DEP = '.$inst_dynamic_dep.' -$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) +$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) '); if ($armaybe ne ':'){ $ldfrom = 'tmp$(LIB_EXT)'; @@ -1072,18 +1076,20 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists } $ldfrom = "-all $ldfrom -none" if ($^O eq 'dec_osf'); - # Brain dead solaris linker does not use LD_RUN_PATH? - # This fixes dynamic extensions which need shared libs - my $ldrun = ''; - $ldrun = join ' ', map "-R$_", split /:/, $self->{LD_RUN_PATH} - if ($^O eq 'solaris'); - - # The IRIX linker also doesn't use LD_RUN_PATH - $ldrun = qq{-rpath "$self->{LD_RUN_PATH}"} + # The IRIX linker doesn't use LD_RUN_PATH + my $ldrun = qq{-rpath "$self->{LD_RUN_PATH}"} if ($^O eq 'irix' && $self->{LD_RUN_PATH}); - push(@m,' $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom. - ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)'); + # For example in AIX the shared objects/libraries from previous builds + # linger quite a while in the shared dynalinker cache even when nobody + # is using them. This is painful if one for instance tries to restart + # a failed build because the link command will fail unnecessarily 'cos + # the shared object/library is 'busy'. + push(@m,' $(RM_F) $@ +'); + + push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) '.$ldrun.' $(LDDLFLAGS) '.$ldfrom. + ' $(OTHERLDFLAGS) -o $@ $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(PERL_ARCHIVE_AFTER) $(EXPORT_LIST)'); push @m, ' $(CHMOD) $(PERM_RWX) $@ '; @@ -1148,9 +1154,9 @@ in these dirs: @$dirs "; } - foreach $dir (@$dirs){ - next unless defined $dir; # $self->{PERL_SRC} may be undefined - foreach $name (@$names){ + foreach $name (@$names){ + foreach $dir (@$dirs){ + next unless defined $dir; # $self->{PERL_SRC} may be undefined my ($abs, $val); if ($self->file_name_is_absolute($name)) { # /foo/bar $abs = $name; @@ -1250,11 +1256,6 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' next; } my($dev,$ino,$mode) = stat FIXIN; - # If they override perm_rwx, we won't notice it during fixin, - # because fixin is run through a new instance of MakeMaker. - # That is why we must run another CHMOD later. - $mode = oct($self->perm_rwx) unless $dev; - chmod $mode, $file; # Print out the new #! line (or equivalent). local $\; @@ -1262,7 +1263,15 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' print FIXOUT $shb, <FIXIN>; close FIXIN; close FIXOUT; - # can't rename open files on some DOSISH platforms + + # can't rename/chmod open files on some DOSISH platforms + + # If they override perm_rwx, we won't notice it during fixin, + # because fixin is run through a new instance of MakeMaker. + # That is why we must run another CHMOD later. + $mode = oct($self->perm_rwx) unless $dev; + chmod $mode, $file; + unless ( rename($file, "$file.bak") ) { warn "Can't rename $file to $file.bak: $!"; next; @@ -1277,6 +1286,7 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' } unlink "$file.bak"; } continue { + close(FIXIN) if fileno(FIXIN); chmod oct($self->perm_rwx), $file or die "Can't reset permissions for $file: $!\n"; system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';; @@ -1654,7 +1664,7 @@ sub init_main { unless ($self->{PERL_SRC}){ my($dir); - foreach $dir ($self->updir(),$self->catdir($self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir())){ + foreach $dir ($self->updir(),$self->catdir($self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir(),$self->updir())){ if ( -f $self->catfile($dir,"config.sh") && @@ -2369,7 +2379,7 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) # The front matter of the linkcommand... $linkcmd = join ' ', "\$(CC)", - grep($_, @Config{qw(large split ldflags ccdlflags)}); + grep($_, @Config{qw(ldflags ccdlflags)}); $linkcmd =~ s/\s+/ /g; $linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,; @@ -2452,7 +2462,7 @@ MAP_PERLINC = @{$perlinc || []} MAP_STATIC = ", join(" \\\n\t", reverse sort keys %static), " -MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} +MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib} "; if (defined $libperl) { @@ -2460,6 +2470,7 @@ MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} } unless ($libperl && -f $lperl) { # Ilya's code... my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE"; + $dir = "$self->{PERL_ARCHLIB}/.." if $self->{UNINSTALLED_PERL}; $libperl ||= "libperl$self->{LIB_EXT}"; $libperl = "$dir/$libperl"; $lperl ||= "libperl$self->{LIB_EXT}"; @@ -2497,14 +2508,9 @@ MAP_LIBPERL = $libperl # SUNOS ld does not take the full path to a shared library my $llibperl = ($libperl)?'$(MAP_LIBPERL)':'-lperl'; - # Brain dead solaris linker does not use LD_RUN_PATH? - # This fixes dynamic extensions which need shared libs - my $ldfrom = ($^O eq 'solaris')? - join(' ', map "-R$_", split /:/, $self->{LD_RUN_PATH}):''; - push @m, " \$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all - \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) $ldfrom \$(MAP_STATIC) $llibperl `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS) + \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) \$(LDFROM) \$(MAP_STATIC) $llibperl `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS) $self->{NOECHO}echo 'To install the new \"\$(MAP_TARGET)\" binary, call' $self->{NOECHO}echo ' make -f $makefilename inst_perl MAP_TARGET=\$(MAP_TARGET)' $self->{NOECHO}echo 'To remove the intermediate files say' @@ -3040,7 +3046,7 @@ sub pm_to_blib { pm_to_blib: $(TO_INST_PM) }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \ "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \ - -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{')" + -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{','$(PM_FILTER)')" }.$self->{NOECHO}.q{$(TOUCH) $@ }; } @@ -3112,6 +3118,7 @@ sub processPL { my $list = ref($self->{PL_FILES}->{$plfile}) ? $self->{PL_FILES}->{$plfile} : [$self->{PL_FILES}->{$plfile}]; + my $target; foreach $target (@$list) { push @m, " all :: $target @@ -3151,8 +3158,22 @@ realclean purge :: clean push(@m, " $self->{RM_F} \$(INST_DYNAMIC) \$(INST_BOOT)\n"); push(@m, " $self->{RM_F} \$(INST_STATIC)\n"); } - push(@m, " $self->{RM_F} " . join(" ", values %{$self->{PM}}) . "\n") - if keys %{$self->{PM}}; + # Issue a several little RM_F commands rather than risk creating a + # very long command line (useful for extensions such as Encode + # that have many files). + if (keys %{$self->{PM}}) { + my $line = ""; + foreach (values %{$self->{PM}}) { + if (length($line) + length($_) > 80) { + push @m, "\t$self->{RM_F} $line\n"; + $line = $_; + } + else { + $line .= " $_"; + } + } + push @m, "\t$self->{RM_F} $line\n" if $line; + } my(@otherfiles) = ($self->{MAKEFILE}, "$self->{MAKEFILE}.old"); # Makefiles last push(@otherfiles, $attribs{FILES}) if $attribs{FILES}; @@ -3171,9 +3192,11 @@ form Foo/Bar and replaces the slash with C<::>. Returns the replacement. sub replace_manpage_separator { my($self,$man) = @_; if ($^O eq 'uwin') { - $man =~ s,/+,.,g; + $man =~ s,/+,.,g; + } elsif ($Is_Dos) { + $man =~ s,/+,__,g; } else { - $man =~ s,/+,::,g; + $man =~ s,/+,::,g; } $man; } @@ -3492,13 +3515,13 @@ WARN_IF_OLD_PACKLIST = $(PERL) -we 'exit unless -f $$ARGV[0];' \\ -e 'print "Please make sure the two installations are not conflicting\n";' UNINST=0 -VERBINST=1 +VERBINST=0 MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \ -e "install({@ARGV},'$(VERBINST)',0,'$(UNINST)');" DOC_INSTALL = $(PERL) -e '$$\="\n\n";' \ --e 'print "=head2 ", scalar(localtime), ": C<", shift, ">", " L<", shift, ">";' \ +-e 'print "=head2 ", scalar(localtime), ": C<", shift, ">", " L<", $$arg=shift, "|", $$arg, ">";' \ -e 'print "=over 4";' \ -e 'while (defined($$key = shift) and defined($$val = shift)){print "=item *";print "C<$$key: $$val>";}' \ -e 'print "=back";' @@ -3793,6 +3816,21 @@ sub perl_archive return ""; } +=item perl_archive_after + +This is an internal method that returns path to a library which +should be put on the linker command line I<after> the external libraries +to be linked to dynamic extensions. This may be needed if the linker +is one-pass, and Perl includes some overrides for C RTL functions, +such as malloc(). + +=cut + +sub perl_archive_after +{ + return ""; +} + =item export_list This is internal method that returns name of a file that is diff --git a/contrib/perl5/lib/ExtUtils/MakeMaker.pm b/contrib/perl5/lib/ExtUtils/MakeMaker.pm index b29dcf6..651ffac 100644 --- a/contrib/perl5/lib/ExtUtils/MakeMaker.pm +++ b/contrib/perl5/lib/ExtUtils/MakeMaker.pm @@ -46,7 +46,7 @@ use vars qw( # default routine without having to know under what OS # it's running. # -@MM::ISA = qw[ExtUtils::MM_Unix ExtUtils::Liblist ExtUtils::MakeMaker]; +@MM::ISA = qw[ExtUtils::MM_Unix ExtUtils::Liblist::Kid ExtUtils::MakeMaker]; # # Setup dummy package: @@ -62,7 +62,7 @@ use vars qw( # "predeclare the package: we only load it via AUTOLOAD # but we have already mentioned it in @ISA -package ExtUtils::Liblist; +package ExtUtils::Liblist::Kid; package ExtUtils::MakeMaker; # @@ -84,7 +84,7 @@ if ($Is_OS2) { require ExtUtils::MM_OS2; } if ($Is_Mac) { - require ExtUtils::MM_Mac; + require ExtUtils::MM_MacOS; } if ($Is_Win32) { require ExtUtils::MM_Win32; @@ -191,7 +191,7 @@ sub full_setup { AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE FULLPERL FUNCLIST H - HTMLLIBPODS HTMLSCRIPTPOD IMPORTS + HTMLLIBPODS HTMLSCRIPTPODS IMPORTS INC INCLUDE_EXT INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLHTMLPRIVLIBDIR INSTALLHTMLSCRIPTDIR INSTALLHTMLSITELIBDIR INSTALLMAN1DIR INSTALLMAN3DIR INSTALLPRIVLIB INSTALLSCRIPT INSTALLSITEARCH @@ -202,10 +202,14 @@ sub full_setup { PERL_MALLOC_OK NAME NEEDS_LINKING NOECHO NORECURS NO_VC OBJECT OPTIMIZE PERL PERLMAINCC PERL_ARCHLIB PERL_LIB PERL_SRC PERM_RW PERM_RWX - PL_FILES PM PMLIBDIRS POLLUTE PPM_INSTALL_EXEC PPM_INSTALL_SCRIPT PREFIX + PL_FILES PM PM_FILTER PMLIBDIRS POLLUTE PPM_INSTALL_EXEC + PPM_INSTALL_SCRIPT PREFIX PREREQ_PM SKIP TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG XS_VERSION clean depend dist dynamic_lib linkext macro realclean tool_autosplit + + MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC + MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED /; # IMPORTS is used under OS/2 and Win32 @@ -241,7 +245,6 @@ sub full_setup { dir_target libscan makeaperl needs_linking perm_rw perm_rwx subdir_x test_via_harness test_via_script - ]; push @MM_Sections, qw[ @@ -984,23 +987,39 @@ be perl Makefile.PL LIB=~/lib This will install the module's architecture-independent files into -~/lib, the architecture-dependent files into ~/lib/$archname/auto. +~/lib, the architecture-dependent files into ~/lib/$archname. Another way to specify many INSTALL directories with a single parameter is PREFIX. perl Makefile.PL PREFIX=~ -This will replace the string specified by $Config{prefix} in all -$Config{install*} values. +This will replace the string specified by C<$Config{prefix}> in all +C<$Config{install*}> values. Note, that in both cases the tilde expansion is done by MakeMaker, not -by perl by default, nor by make. Conflicts between parameters LIB, -PREFIX and the various INSTALL* arguments are resolved so that -XXX +by perl by default, nor by make. + +Conflicts between parameters LIB, +PREFIX and the various INSTALL* arguments are resolved so that: + +=over 4 + +=item * + +setting LIB overrides any setting of INSTALLPRIVLIB, INSTALLARCHLIB, +INSTALLSITELIB, INSTALLSITEARCH (and they are not affected by PREFIX); + +=item * + +without LIB, setting PREFIX replaces the initial C<$Config{prefix}> +part of those INSTALL* arguments, even if the latter are explicitly +set (but are set to still start with C<$Config{prefix}>). + +=back If the user has superuser privileges, and is not working on AFS -(Andrew File System) or relatives, then the defaults for +or relatives, then the defaults for INSTALLPRIVLIB, INSTALLARCHLIB, INSTALLSCRIPT, etc. will be appropriate, and this incantation will be the best: @@ -1147,11 +1166,6 @@ or as NAME=VALUE pairs on the command line: =over 2 -=item AUTHOR - -String containing name (and email address) of package author(s). Is used -in PPD (Perl Package Description) files for PPM (Perl Package Manager). - =item ABSTRACT One line description of the module. Will be included in PPD file. @@ -1162,6 +1176,11 @@ Name of the file that contains the package description. MakeMaker looks for a line in the POD matching /^($package\s-\s)(.*)/. This is typically the first line in the "=head1 NAME" section. $2 becomes the abstract. +=item AUTHOR + +String containing name (and email address) of package author(s). Is used +in PPD (Perl Package Description) files for PPM (Perl Package Manager). + =item BINARY_LOCATION Used when creating PPD files for binary packages. It can be set to a @@ -1411,11 +1430,6 @@ to INSTALLBIN during 'make install' Old name for INST_SCRIPT. Deprecated. Please use INST_SCRIPT if you need to use it. -=item INST_LIB - -Directory where we put library files of this extension while building -it. - =item INST_HTMLLIBDIR Directory to hold the man pages in HTML format at 'make' time @@ -1424,6 +1438,11 @@ Directory to hold the man pages in HTML format at 'make' time Directory to hold the man pages in HTML format at 'make' time +=item INST_LIB + +Directory where we put library files of this extension while building +it. + =item INST_MAN1DIR Directory to hold the man pages at 'make' time @@ -1439,34 +1458,6 @@ Directory, where executable files should be installed during testing. make install will copy the files in INST_SCRIPT to INSTALLSCRIPT. -=item PERL_MALLOC_OK - -defaults to 0. Should be set to TRUE if the extension can work with -the memory allocation routines substituted by the Perl malloc() subsystem. -This should be applicable to most extensions with exceptions of those - -=over - -=item * - -with bugs in memory allocations which are caught by Perl's malloc(); - -=item * - -which interact with the memory allocator in other ways than via -malloc(), realloc(), free(), calloc(), sbrk() and brk(); - -=item * - -which rely on special alignment which is not provided by Perl's malloc(). - -=back - -B<NOTE.> Negligence to set this flag in I<any one> of loaded extension -nullifies many advantages of Perl's malloc(), such as better usage of -system resources, error detection, memory usage reporting, catchable failure -of memory allocations, etc. - =item LDFROM defaults to "$(OBJECT)" and is used in the ld command to specify @@ -1475,8 +1466,12 @@ specify ld flags) =item LIB -LIB can only be set at C<perl Makefile.PL> time. It has the effect of +LIB should only be set at C<perl Makefile.PL> time but is allowed as a +MakeMaker argument. It has the effect of setting both INSTALLPRIVLIB and INSTALLSITELIB to that value regardless any +explicit setting of those arguments (or of PREFIX). +INSTALLARCHLIB and INSTALLSITEARCH are set to the corresponding +architecture subdirectory. =item LIBPERL_A @@ -1580,6 +1575,8 @@ List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long string containing all object files, e.g. "tkpBind.o tkpButton.o tkpCanvas.o" +(Where BASEEXT is the last component of NAME, and OBJ_EXT is $Config{obj_ext}.) + =item OPTIMIZE Defaults to C<-O>. Set it to C<-g> to turn debugging on. The flag is @@ -1596,12 +1593,40 @@ to $(CC). =item PERL_ARCHLIB -Same as above for architecture dependent files. +Same as below, but for architecture dependent files. =item PERL_LIB Directory containing the Perl library to use. +=item PERL_MALLOC_OK + +defaults to 0. Should be set to TRUE if the extension can work with +the memory allocation routines substituted by the Perl malloc() subsystem. +This should be applicable to most extensions with exceptions of those + +=over 4 + +=item * + +with bugs in memory allocations which are caught by Perl's malloc(); + +=item * + +which interact with the memory allocator in other ways than via +malloc(), realloc(), free(), calloc(), sbrk() and brk(); + +=item * + +which rely on special alignment which is not provided by Perl's malloc(). + +=back + +B<NOTE.> Negligence to set this flag in I<any one> of loaded extension +nullifies many advantages of Perl's malloc(), such as better usage of +system resources, error detection, memory usage reporting, catchable failure +of memory allocations, etc. + =item PERL_SRC Directory containing the Perl source code (use of this should be @@ -1650,6 +1675,31 @@ they contain will be installed in the corresponding location in the library. A libscan() method can be used to alter the behaviour. Defining PM in the Makefile.PL will override PMLIBDIRS. +(Where BASEEXT is the last component of NAME.) + +=item PM_FILTER + +A filter program, in the traditional Unix sense (input from stdin, output +to stdout) that is passed on each .pm file during the build (in the +pm_to_blib() phase). It is empty by default, meaning no filtering is done. + +Great care is necessary when defining the command if quoting needs to be +done. For instance, you would need to say: + + {'PM_FILTER' => 'grep -v \\"^\\#\\"'} + +to remove all the leading coments on the fly during the build. The +extra \\ are necessary, unfortunately, because this variable is interpolated +within the context of a Perl program built on the command line, and double +quotes are what is used with the -e switch to build that command line. The +# is escaped for the Makefile, since what is going to be generated will then +be: + + PM_FILTER = grep -v \"^\#\" + +Without the \\ before the #, we'd have the start of a Makefile comment, +and the macro would be incorrectly defined. + =item POLLUTE Release 5.005 grandfathered old global symbol names by providing preprocessor @@ -1727,6 +1777,7 @@ MakeMaker object. The following lines will be parsed o.k.: ( $VERSION ) = '$Revision: 1.222 $ ' =~ /\$Revision:\s+([^\s]+)/; $FOO::VERSION = '1.10'; *FOO::VERSION = \'1.11'; + our $VERSION = 1.2.3; # new for perl5.6.0 but these will fail: @@ -1734,6 +1785,8 @@ but these will fail: local $VERSION = '1.02'; local $FOO::VERSION = '1.30'; +(Putting C<my> or C<local> on the preceding line will work o.k.) + The file named in VERSION_FROM is not added as a dependency to Makefile. This is not really correct, but it would be a major pain during development to have to rewrite the Makefile for any smallish @@ -1788,6 +1841,8 @@ part of the Makefile. {ANY_TARGET => ANY_DEPENDECY, ...} +(ANY_TARGET must not be given a double-colon rule by MakeMaker.) + =item dist {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz', diff --git a/contrib/perl5/patchlevel.h b/contrib/perl5/patchlevel.h index 1d65002..549661f 100644 --- a/contrib/perl5/patchlevel.h +++ b/contrib/perl5/patchlevel.h @@ -6,7 +6,7 @@ #define PERL_REVISION 5 /* age */ #define PERL_VERSION 6 /* epoch */ -#define PERL_SUBVERSION 0 /* generation */ +#define PERL_SUBVERSION 1 /* generation */ /* The following numbers describe the earliest compatible version of Perl ("compatibility" here being defined as sufficient binary/API diff --git a/contrib/perl5/perl.c b/contrib/perl5/perl.c index a84bf85..d18107c 100644 --- a/contrib/perl5/perl.c +++ b/contrib/perl5/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-2000 Larry Wall + * Copyright (c) 1987-2001 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -181,6 +181,8 @@ perl_construct(pTHXx) # endif /* EMULATE_ATOMIC_REFCOUNTS */ MUTEX_INIT(&PL_cred_mutex); + MUTEX_INIT(&PL_sv_lock_mutex); + MUTEX_INIT(&PL_fdpid_mutex); thr = init_main_thread(); #endif /* USE_THREADS */ @@ -273,10 +275,15 @@ perl_construct(pTHXx) PL_localpatches = local_patches; /* For possible -v */ #endif +#ifdef HAVE_INTERP_INTERN + sys_intern_init(); +#endif + PerlIO_init(); /* Hook to IO system */ PL_fdpid = newAV(); /* for remembering popen pids by fd */ PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ + PL_errors = newSVpvn("",0); ENTER; } @@ -292,9 +299,7 @@ Shuts down a Perl interpreter. See L<perlembed>. void perl_destruct(pTHXx) { - dTHR; int destruct_level; /* 0=none, 1=full, 2=full with checks */ - I32 last_sv_count; HV *hv; #ifdef USE_THREADS Thread t; @@ -371,6 +376,7 @@ perl_destruct(pTHXx) DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n")); MUTEX_DESTROY(&PL_threads_mutex); COND_DESTROY(&PL_nthreads_cond); + PL_nthreads--; #endif /* !defined(FAKE_THREADS) */ #endif /* USE_THREADS */ @@ -432,6 +438,21 @@ perl_destruct(pTHXx) return; } + /* jettison our possibly duplicated environment */ + +#ifdef USE_ENVIRON_ARRAY + if (environ != PL_origenviron) { + I32 i; + + for (i = 0; environ[i]; i++) + safesysfree(environ[i]); + /* Must use safesysfree() when working with environ. */ + safesysfree(environ); + + environ = PL_origenviron; + } +#endif + /* loosen bonds of global variables */ if(PL_rsfp) { @@ -556,6 +577,7 @@ perl_destruct(pTHXx) #ifdef USE_LOCALE_NUMERIC Safefree(PL_numeric_name); PL_numeric_name = Nullch; + SvREFCNT_dec(PL_numeric_radix_sv); #endif /* clear utf8 character classes */ @@ -596,9 +618,14 @@ perl_destruct(pTHXx) if (!specialWARN(PL_compiling.cop_warnings)) SvREFCNT_dec(PL_compiling.cop_warnings); PL_compiling.cop_warnings = Nullsv; -#ifndef USE_ITHREADS +#ifdef USE_ITHREADS + Safefree(CopFILE(&PL_compiling)); + CopFILE(&PL_compiling) = Nullch; + Safefree(CopSTASHPV(&PL_compiling)); +#else SvREFCNT_dec(CopFILEGV(&PL_compiling)); - CopFILEGV_set(&PL_compiling, Nullgv); + CopFILEGV(&PL_compiling) = Nullgv; + /* cop_stash is not refcounted */ #endif /* Prepare to destruct main symbol table. */ @@ -632,13 +659,13 @@ perl_destruct(pTHXx) } /* Now absolutely destruct everything, somehow or other, loops or no. */ - last_sv_count = 0; SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */ SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */ - while (PL_sv_count != 0 && PL_sv_count != last_sv_count) { - last_sv_count = PL_sv_count; - sv_clean_all(); - } + + /* the 2 is for PL_fdpid and PL_strtab */ + while (PL_sv_count > 2 && sv_clean_all()) + ; + SvFLAGS(PL_fdpid) &= ~SVTYPEMASK; SvFLAGS(PL_fdpid) |= SVt_PVAV; SvFLAGS(PL_strtab) &= ~SVTYPEMASK; @@ -648,6 +675,10 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_fdpid); /* needed in io_close() */ PL_fdpid = Nullav; +#ifdef HAVE_INTERP_INTERN + sys_intern_clear(); +#endif + /* Destruct the global string table. */ { /* Yell and reset the HeVAL() slots that are still holding refcounts, @@ -679,6 +710,11 @@ perl_destruct(pTHXx) } SvREFCNT_dec(PL_strtab); +#ifdef USE_ITHREADS + /* free the pointer table used for cloning */ + ptr_table_free(PL_ptr_table); +#endif + /* free special SVs */ SvREFCNT(&PL_sv_yes) = 0; @@ -697,9 +733,6 @@ perl_destruct(pTHXx) if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count); - sv_free_arenas(); - - /* No SVs have survived, need to clean out */ Safefree(PL_origfilename); Safefree(PL_reg_start_tmp); if (PL_reg_curpm) @@ -707,6 +740,9 @@ perl_destruct(pTHXx) Safefree(PL_reg_poscache); Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh)); Safefree(PL_op_mask); + Safefree(PL_psig_ptr); + Safefree(PL_psig_name); + Safefree(PL_bitcount); nuke_stacks(); PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ @@ -716,6 +752,7 @@ perl_destruct(pTHXx) MUTEX_DESTROY(&PL_sv_mutex); MUTEX_DESTROY(&PL_eval_mutex); MUTEX_DESTROY(&PL_cred_mutex); + MUTEX_DESTROY(&PL_fdpid_mutex); COND_DESTROY(&PL_eval_cond); #ifdef EMULATE_ATOMIC_REFCOUNTS MUTEX_DESTROY(&PL_svref_mutex); @@ -728,6 +765,8 @@ perl_destruct(pTHXx) PL_thrsv = Nullsv; #endif /* USE_THREADS */ + sv_free_arenas(); + /* As the absolutely last thing, free the non-arena SV for mess() */ if (PL_mess_sv) { @@ -795,7 +834,6 @@ Tells a Perl interpreter to parse a Perl script. See L<perlembed>. int perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { - dTHR; I32 oldscope; int ret; dJMPENV; @@ -818,7 +856,7 @@ setuid perl scripts securely.\n"); PL_origargv = argv; PL_origargc = argc; -#ifndef VMS /* VMS doesn't have environ array */ +#ifdef USE_ENVIRON_ARRAY PL_origenviron = environ; #endif @@ -897,7 +935,6 @@ S_vparse_body(pTHX_ va_list args) STATIC void * S_parse_body(pTHX_ char **env, XSINIT_t xsinit) { - dTHR; int argc = PL_origargc; char **argv = PL_origargv; char *scriptname = NULL; @@ -965,6 +1002,11 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) goto reswitch; case 'e': +#ifdef MACOS_TRADITIONAL + /* ignore -e for Dev:Pseudo argument */ + if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) + break; +#endif if (PL_euid != PL_uid || PL_egid != PL_gid) Perl_croak(aTHX_ "No -e allowed in setuid scripts"); if (!PL_e_script) { @@ -1135,6 +1177,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_tainting = TRUE; else { while (s && *s) { + char *d; while (isSPACE(*s)) s++; if (*s == '-') { @@ -1142,11 +1185,18 @@ print \" \\@INC:\\n @INC\\n\";"); if (isSPACE(*s)) continue; } + d = s; if (!*s) break; if (!strchr("DIMUdmw", *s)) Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); - s = moreswitches(s); + while (++s && *s) { + if (isSPACE(*s)) { + *s++ = '\0'; + break; + } + } + moreswitches(d); } } } @@ -1186,7 +1236,11 @@ print \" \\@INC:\\n @INC\\n\";"); } #endif +#ifdef MACOS_TRADITIONAL + if (PL_doextract || gMacPerl_AlwaysExtract) { +#else if (PL_doextract) { +#endif find_beginning(); if (cddir && PerlDir_chdir(cddir) < 0) Perl_croak(aTHX_ "Can't chdir to %s",cddir); @@ -1226,12 +1280,16 @@ print \" \\@INC:\\n @INC\\n\";"); if (xsinit) (*xsinit)(aTHXo); /* in case linked C routines want magical variables */ -#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) +#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) init_os_extras(); #endif #ifdef USE_SOCKS +# ifdef HAS_SOCKS5_INIT + socks5_init(argv[0]); +# else SOCKSinit(argv[0]); +# endif #endif init_predump_symbols(); @@ -1247,6 +1305,16 @@ print \" \\@INC:\\n @INC\\n\";"); SETERRNO(0,SS$_NORMAL); PL_error_count = 0; +#ifdef MACOS_TRADITIONAL + if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) { + if (PL_minus_c) + Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename)); + else { + Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n", + MacPerl_MPWFileName(PL_origfilename)); + } + } +#else if (yyparse() || PL_error_count) { if (PL_minus_c) Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename); @@ -1255,6 +1323,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_origfilename); } } +#endif CopLINE_set(PL_curcop, 0); PL_curstash = PL_defstash; PL_preprocess = FALSE; @@ -1300,7 +1369,6 @@ Tells a Perl interpreter to run. See L<perlembed>. int perl_run(pTHXx) { - dTHR; I32 oldscope; int ret = 0; dJMPENV; @@ -1368,8 +1436,6 @@ S_vrun_body(pTHX_ va_list args) STATIC void * S_run_body(pTHX_ I32 oldscope) { - dTHR; - DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n", PL_sawampersand ? "Enabling" : "Omitting")); @@ -1380,7 +1446,11 @@ S_run_body(pTHX_ I32 oldscope) PTR2UV(thr))); if (PL_minus_c) { +#ifdef MACOS_TRADITIONAL + PerlIO_printf(Perl_error_log, "%s syntax OK\n", MacPerl_MPWFileName(PL_origfilename)); +#else PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); +#endif my_exit(0); } if (PERLDB_SINGLE && PL_DBsingle) @@ -1424,10 +1494,8 @@ Perl_get_sv(pTHX_ const char *name, I32 create) #ifdef USE_THREADS if (name[1] == '\0' && !isALPHA(name[0])) { PADOFFSET tmp = find_threadsv(name); - if (tmp != NOT_IN_PAD) { - dTHR; + if (tmp != NOT_IN_PAD) return THREADSV(tmp); - } } #endif /* USE_THREADS */ gv = gv_fetchpv(name, create, SVt_PV); @@ -1566,18 +1634,7 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { - dSP; - OP myop; - if (!PL_op) { - Zero(&myop, 1, OP); - PL_op = &myop; - } - XPUSHs(sv_2mortal(newSVpv(methname,0))); - PUTBACK; - pp_method(); - if (PL_op == &myop) - PL_op = Nullop; - return call_sv(*PL_stack_sp--, flags); + return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD); } /* May be called with any of a CV, a GV, or an SV containing the name. */ @@ -1592,11 +1649,11 @@ L<perlcall>. I32 Perl_call_sv(pTHX_ SV *sv, I32 flags) - /* See G_* flags in cop.h */ { dSP; LOGOP myop; /* fake syntax tree node */ + UNOP method_op; I32 oldmark; I32 retval; I32 oldscope; @@ -1634,6 +1691,14 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) && !(flags & G_NODEBUG)) PL_op->op_private |= OPpENTERSUB_DB; + if (flags & G_METHOD) { + Zero(&method_op, 1, UNOP); + method_op.op_next = PL_op; + method_op.op_ppaddr = PL_ppaddr[OP_METHOD]; + myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; + PL_op = (OP*)&method_op; + } + if (!(flags & G_EVAL)) { CATCH_SET(TRUE); call_body((OP*)&myop, FALSE); @@ -1641,7 +1706,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) CATCH_SET(oldcatch); } else { - cLOGOP->op_other = PL_op; + myop.op_other = (OP*)&myop; PL_markstack_ptr--; /* we're trying to emulate pp_entertry() here */ { @@ -1651,7 +1716,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) ENTER; SAVETMPS; - push_return(PL_op->op_next); + push_return(Nullop); PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); PUSHEVAL(cx, 0, 0); PL_eval_root = PL_op; /* Only needed so that goto works right. */ @@ -1750,13 +1815,11 @@ S_vcall_body(pTHX_ va_list args) STATIC void S_call_body(pTHX_ OP *myop, int is_eval) { - dTHR; - if (PL_op == myop) { if (is_eval) - PL_op = Perl_pp_entereval(aTHX); + PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */ else - PL_op = Perl_pp_entersub(aTHX); + PL_op = Perl_pp_entersub(aTHX); /* this does */ } if (PL_op) CALLRUNOPS(aTHX); @@ -1878,7 +1941,6 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) dSP; SV* sv = newSVpv(p, 0); - PUSHMARK(SP); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); @@ -1939,7 +2001,7 @@ S_usage(pTHX_ char *name) /* XXX move this out into a module ? */ "-0[octal] specify record separator (\\0, if no argument)", "-a autosplit mode with -n or -p (splits $_ into @F)", "-C enable native wide character system interfaces", -"-c check syntax only (runs BEGIN and END blocks)", +"-c check syntax only (runs BEGIN and CHECK blocks)", "-d[:debugger] run program under debugger", "-D[number/list] set debugging flags (argument is a bit mask or alphabets)", "-e 'command' one line of program (several -e's allowed, omit programfile)", @@ -1967,9 +2029,11 @@ NULL }; char **p = usage_msg; - printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name); + PerlIO_printf(PerlIO_stdout(), + "\nUsage: %s [switches] [--] [programfile] [arguments]", + name); while (*p) - printf("\n %s", *p++); + PerlIO_printf(PerlIO_stdout(), "\n %s", *p++); } /* This routine handles any switches that can be given during run */ @@ -1977,13 +2041,13 @@ NULL char * Perl_moreswitches(pTHX_ char *s) { - I32 numlen; + STRLEN numlen; U32 rschar; switch (*s) { case '0': { - dTHR; + numlen = 0; /* disallow underscores */ rschar = (U32)scan_oct(s, 4, &numlen); SvREFCNT_dec(PL_nrs); if (rschar & ~((U8)~0)) @@ -2016,9 +2080,25 @@ Perl_moreswitches(pTHX_ char *s) case 'd': forbid_setid("-d"); s++; - if (*s == ':' || *s == '=') { - my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s)); + /* The following permits -d:Mod to accepts arguments following an = + in the fashion that -MSome::Mod does. */ + if (*s == ':' || *s == '=') { + char *start; + SV *sv; + sv = newSVpv("use Devel::", 0); + start = ++s; + /* We now allow -d:Module=Foo,Bar */ + while(isALNUM(*s) || *s==':') ++s; + if (*s != '=') + sv_catpv(sv, start); + else { + sv_catpvn(sv, start, s-start); + sv_catpv(sv, " split(/,/,q{"); + sv_catpv(sv, ++s); + sv_catpv(sv, "})"); + } s += strlen(s); + my_setenv("PERL5DB", SvPV(sv, PL_na)); } if (!PL_perldb) { PL_perldb = PERLDB_ALL; @@ -2030,7 +2110,7 @@ Perl_moreswitches(pTHX_ char *s) #ifdef DEBUGGING forbid_setid("-D"); if (isALPHA(s[1])) { - static char debopts[] = "psltocPmfrxuLHXDS"; + static char debopts[] = "psltocPmfrxuLHXDST"; char *d; for (s++; *s && (d = strchr(debopts,*s)); s++) @@ -2042,7 +2122,6 @@ Perl_moreswitches(pTHX_ char *s) } PL_debug |= 0x80000000; #else - dTHR; if (ckWARN_d(WARN_DEBUGGING)) Perl_warner(aTHX_ WARN_DEBUGGING, "Recompile perl with -DDEBUGGING to use -D switch\n"); @@ -2099,11 +2178,11 @@ Perl_moreswitches(pTHX_ char *s) if (isDIGIT(*s)) { PL_ors = savepv("\n"); PL_orslen = 1; + numlen = 0; /* disallow underscores */ *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen); s += numlen; } else { - dTHR; if (RsPARA(PL_nrs)) { PL_ors = "\n\n"; PL_orslen = 2; @@ -2136,6 +2215,9 @@ Perl_moreswitches(pTHX_ char *s) sv_catpv( sv, " ()"); } } else { + if (s == start) + Perl_croak(aTHX_ "Module name required with -%c option", + s[-1]); sv_catpvn(sv, start, s-start); sv_catpv(sv, " split(/,/,q{"); sv_catpv(sv, ++s); @@ -2168,6 +2250,9 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'u': +#ifdef MACOS_TRADITIONAL + Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh"); +#endif PL_do_undump = TRUE; s++; return s; @@ -2176,59 +2261,81 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'v': - printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s", - PL_patchlevel, ARCHNAME)); + PerlIO_printf(PerlIO_stdout(), + Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s", + PL_patchlevel, ARCHNAME)); #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) - printf("\n(with %d registered patch%s, see perl -V for more detail)", - (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); + PerlIO_printf(PerlIO_stdout(), + "\n(with %d registered patch%s, " + "see perl -V for more detail)", + (int)LOCAL_PATCH_COUNT, + (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - printf("\n\nCopyright 1987-2000, Larry Wall\n"); + PerlIO_printf(PerlIO_stdout(), + "\n\nCopyright 1987-2001, Larry Wall\n"); +#ifdef MACOS_TRADITIONAL + PerlIO_printf(PerlIO_stdout(), + "\nMac OS port Copyright (c) 1991-2001, Matthias Neeracher\n"); +#endif #ifdef MSDOS - printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); + PerlIO_printf(PerlIO_stdout(), + "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif #ifdef DJGPP - printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"); - printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n" + "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); #endif #ifdef OS2 - printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" - "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n"); + PerlIO_printf(PerlIO_stdout(), + "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" + "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef atarist - printf("atariST series port, ++jrb bammi@cadence.com\n"); + PerlIO_printf(PerlIO_stdout(), + "atariST series port, ++jrb bammi@cadence.com\n"); #endif #ifdef __BEOS__ - printf("BeOS port Copyright Tom Spindler, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "BeOS port Copyright Tom Spindler, 1997-1999\n"); #endif #ifdef MPE - printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n"); #endif #ifdef OEMVS - printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); #endif #ifdef __VOS__ - printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n"); #endif #ifdef __OPEN_VM - printf("VM/ESA port by Neale Ferguson, 1998-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "VM/ESA port by Neale Ferguson, 1998-1999\n"); #endif #ifdef POSIX_BC - printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); #endif #ifdef __MINT__ - printf("MiNT port by Guido Flohr, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "MiNT port by Guido Flohr, 1997-1999\n"); #endif #ifdef EPOC - printf("EPOC port by Olaf Flebbe, 1999-2000\n"); + PerlIO_printf(PerlIO_stdout(), + "EPOC port by Olaf Flebbe, 1999-2000\n"); #endif #ifdef BINARY_BUILD_NOTICE BINARY_BUILD_NOTICE; #endif - printf("\n\ + PerlIO_printf(PerlIO_stdout(), + "\n\ Perl may be copied only under the terms of either the Artistic License or the\n\ -GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\ +GNU General Public License, which may be found in the Perl 5 source kit.\n\n\ Complete documentation for Perl, including FAQ lists, should be found on\n\ this system using `man perl' or `perldoc perl'. If you have access to the\n\ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); @@ -2390,7 +2497,6 @@ S_init_interp(pTHX) STATIC void S_init_main_stash(pTHX) { - dTHR; GV *gv; /* Note that strtab is a rather special HV. Assumptions are made @@ -2426,6 +2532,7 @@ S_init_main_stash(pTHX) CopSTASH_set(&PL_compiling, PL_defstash); PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV)); + PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV)); /* We must init $/ before switches are processed. */ sv_setpvn(get_sv("/", TRUE), "\n", 1); } @@ -2433,8 +2540,6 @@ S_init_main_stash(pTHX) STATIC void S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) { - dTHR; - *fdscript = -1; if (PL_e_script) { @@ -2457,6 +2562,11 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) } } +#ifdef USE_ITHREADS + Safefree(CopFILE(PL_curcop)); +#else + SvREFCNT_dec(CopFILEGV(PL_curcop)); +#endif CopFILE_set(PL_curcop, PL_origfilename); if (strEQ(PL_origfilename,"-")) scriptname = ""; @@ -2479,7 +2589,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) sv_catpvn(sv, "-I", 2); sv_catpv(sv,PRIVLIB_EXP); -#ifdef MSDOS +#if defined(MSDOS) || defined(WIN32) Perl_sv_setpvf(aTHX_ cmd, "\ sed %s -e \"/^[^#]/b\" \ -e \"/^#[ ]*include[ ]/b\" \ @@ -2609,72 +2719,85 @@ S_fd_on_nosuid_fs(pTHX_ int fd) * an irrelevant filesystem while trying to reach the right one. */ -# ifdef HAS_FSTATVFS +#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(HAS_FSTATVFS) +# define FD_ON_NOSUID_CHECK_OKAY struct statvfs stfs; + check_okay = fstatvfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID); -# else -# ifdef PERL_MOUNT_NOSUID -# if defined(HAS_FSTATFS) && \ - defined(HAS_STRUCT_STATFS) && \ - defined(HAS_STRUCT_STATFS_F_FLAGS) +# endif /* fstatvfs */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(PERL_MOUNT_NOSUID) && \ + defined(HAS_FSTATFS) && \ + defined(HAS_STRUCT_STATFS) && \ + defined(HAS_STRUCT_STATFS_F_FLAGS) +# define FD_ON_NOSUID_CHECK_OKAY struct statfs stfs; + check_okay = fstatfs(fd, &stfs) == 0; on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID); -# else -# if defined(HAS_FSTAT) && \ - defined(HAS_USTAT) && \ - defined(HAS_GETMNT) && \ - defined(HAS_STRUCT_FS_DATA) && \ - defined(NOSTAT_ONE) +# endif /* fstatfs */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(PERL_MOUNT_NOSUID) && \ + defined(HAS_FSTAT) && \ + defined(HAS_USTAT) && \ + defined(HAS_GETMNT) && \ + defined(HAS_STRUCT_FS_DATA) && \ + defined(NOSTAT_ONE) +# define FD_ON_NOSUID_CHECK_OKAY struct stat fdst; + if (fstat(fd, &fdst) == 0) { - struct ustat us; - if (ustat(fdst.st_dev, &us) == 0) { - struct fs_data fsd; - /* NOSTAT_ONE here because we're not examining fields which - * vary between that case and STAT_ONE. */ + struct ustat us; + if (ustat(fdst.st_dev, &us) == 0) { + struct fs_data fsd; + /* NOSTAT_ONE here because we're not examining fields which + * vary between that case and STAT_ONE. */ if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) { - size_t cmplen = sizeof(us.f_fname); - if (sizeof(fsd.fd_req.path) < cmplen) - cmplen = sizeof(fsd.fd_req.path); - if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) && - fdst.st_dev == fsd.fd_req.dev) { - check_okay = 1; - on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID; - } - } - } - } - } -# endif /* fstat+ustat+getmnt */ -# endif /* fstatfs */ -# else -# if defined(HAS_GETMNTENT) && \ - defined(HAS_HASMNTOPT) && \ - defined(MNTOPT_NOSUID) - FILE *mtab = fopen("/etc/mtab", "r"); - struct mntent *entry; - struct stat stb, fsb; + size_t cmplen = sizeof(us.f_fname); + if (sizeof(fsd.fd_req.path) < cmplen) + cmplen = sizeof(fsd.fd_req.path); + if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) && + fdst.st_dev == fsd.fd_req.dev) { + check_okay = 1; + on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID; + } + } + } + } + } +# endif /* fstat+ustat+getmnt */ + +# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \ + defined(HAS_GETMNTENT) && \ + defined(HAS_HASMNTOPT) && \ + defined(MNTOPT_NOSUID) +# define FD_ON_NOSUID_CHECK_OKAY + FILE *mtab = fopen("/etc/mtab", "r"); + struct mntent *entry; + struct stat stb, fsb; if (mtab && (fstat(fd, &stb) == 0)) { - while (entry = getmntent(mtab)) { - if (stat(entry->mnt_dir, &fsb) == 0 - && fsb.st_dev == stb.st_dev) - { - /* found the filesystem */ - check_okay = 1; - if (hasmntopt(entry, MNTOPT_NOSUID)) - on_nosuid = 1; - break; - } /* A single fs may well fail its stat(). */ - } + while (entry = getmntent(mtab)) { + if (stat(entry->mnt_dir, &fsb) == 0 + && fsb.st_dev == stb.st_dev) + { + /* found the filesystem */ + check_okay = 1; + if (hasmntopt(entry, MNTOPT_NOSUID)) + on_nosuid = 1; + break; + } /* A single fs may well fail its stat(). */ + } } if (mtab) - fclose(mtab); -# endif /* getmntent+hasmntopt */ -# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */ -# endif /* statvfs */ + fclose(mtab); +# endif /* getmntent+hasmntopt */ if (!check_okay) Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename); @@ -2710,7 +2833,6 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) */ #ifdef DOSUID - dTHR; char *s, *s2; if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */ @@ -2908,7 +3030,6 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #else /* !DOSUID */ if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW - dTHR; PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */ if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID) || @@ -2931,9 +3052,29 @@ S_find_beginning(pTHX) /* skip forward in input to the real script? */ forbid_setid("-x"); +#ifdef MACOS_TRADITIONAL + /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */ + while (PL_doextract || gMacPerl_AlwaysExtract) { + if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { + if (!gMacPerl_AlwaysExtract) + Perl_croak(aTHX_ "No Perl script found in input\n"); + + if (PL_doextract) /* require explicit override ? */ + if (!OverrideExtract(PL_origfilename)) + Perl_croak(aTHX_ "User aborted script\n"); + else + PL_doextract = FALSE; + + /* Pater peccavi, file does not have #! */ + PerlIO_rewind(PL_rsfp); + + break; + } +#else while (PL_doextract) { if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) Perl_croak(aTHX_ "No Perl script found in input\n"); +#endif if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) { PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */ PL_doextract = FALSE; @@ -2978,7 +3119,6 @@ S_forbid_setid(pTHX_ char *s) void Perl_init_debugger(pTHX) { - dTHR; HV *ostash = PL_curstash; PL_curstash = PL_debstash; @@ -3046,7 +3186,6 @@ Perl_init_stacks(pTHX) STATIC void S_nuke_stacks(pTHX) { - dTHR; while (PL_curstackinfo->si_next) PL_curstackinfo = PL_curstackinfo->si_next; while (PL_curstackinfo) { @@ -3083,7 +3222,6 @@ S_init_lexer(pTHX) STATIC void S_init_predump_symbols(pTHX) { - dTHR; GV *tmpgv; IO *io; @@ -3115,17 +3253,19 @@ S_init_predump_symbols(pTHX) PL_statname = NEWSV(66,0); /* last filename we did stat on */ - if (!PL_osname) - PL_osname = savepv(OSNAME); + if (PL_osname) + Safefree(PL_osname); + PL_osname = savepv(OSNAME); } STATIC void S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) { - dTHR; char *s; SV *sv; GV* tmpgv; + char **dup_env_base = 0; + int dup_env_count = 0; argc--,argv++; /* skip name of script */ if (PL_doswitches) { @@ -3154,12 +3294,17 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register TAINT; if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) { +#ifdef MACOS_TRADITIONAL + /* $0 is not majick on a Mac */ + sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename)); +#else sv_setpv(GvSV(tmpgv),PL_origfilename); magicname("0", "0", 1); +#endif } if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) #ifdef OS2 - sv_setpv(GvSV(tmpgv), os2_execname()); + sv_setpv(GvSV(tmpgv), os2_execname(aTHX)); #else sv_setpv(GvSV(tmpgv),PL_origargv[0]); #endif @@ -3171,15 +3316,15 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register SV *sv = newSVpv(argv[0],0); av_push(GvAVn(PL_argvgv),sv); if (PL_widesyscalls) - sv_utf8_upgrade(sv); + (void)sv_utf8_decode(sv); } } if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) { HV *hv; GvMULTI_on(PL_envgv); hv = GvHVn(PL_envgv); - hv_magic(hv, PL_envgv, 'E'); -#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */ + hv_magic(hv, Nullgv, 'E'); +#ifdef USE_ENVIRON_ARRAY /* Note that if the supplied env parameter is actually a copy of the global environ then it may now point to free'd memory if the environment has been modified since. To avoid this @@ -3189,6 +3334,26 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register env = environ; if (env != environ) environ[0] = Nullch; +#ifdef NEED_ENVIRON_DUP_FOR_MODIFY + { + char **env_base; + for (env_base = env; *env; env++) + dup_env_count++; + if ((dup_env_base = (char **) + safesysmalloc( sizeof(char *) * (dup_env_count+1) ))) { + char **dup_env; + for (env = env_base, dup_env = dup_env_base; + *env; + env++, dup_env++) { + /* With environ one needs to use safesysmalloc(). */ + *dup_env = safesysmalloc(strlen(*env) + 1); + (void)strcpy(*dup_env, *env); + } + *dup_env = Nullch; + env = dup_env_base; + } /* else what? */ + } +#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */ for (; *env; env++) { if (!(s = strchr(*env,'='))) continue; @@ -3199,12 +3364,16 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register sv = newSVpv(s--,0); (void)hv_store(hv, *env, s - *env, sv, 0); *s = '='; -#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV) - /* Sins of the RTL. See note in my_setenv(). */ - (void)PerlEnv_putenv(savepv(*env)); -#endif } -#endif +#ifdef NEED_ENVIRON_DUP_FOR_MODIFY + if (dup_env_base) { + char **dup_env; + for (dup_env = dup_env_base; *dup_env; dup_env++) + safesysfree(*dup_env); + safesysfree(dup_env_base); + } +#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */ +#endif /* USE_ENVIRON_ARRAY */ #ifdef DYNAMIC_ENV_FETCH HvNAME(hv) = savepv(ENV_HV_NAME); #endif @@ -3249,6 +3418,27 @@ S_init_perllib(pTHX) #ifdef ARCHLIB_EXP incpush(ARCHLIB_EXP, FALSE, FALSE); #endif +#ifdef MACOS_TRADITIONAL + { + struct stat tmpstatbuf; + SV * privdir = NEWSV(55, 0); + char * macperl = PerlEnv_getenv("MACPERL"); + + if (!macperl) + macperl = ""; + + Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl); + if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) + incpush(SvPVX(privdir), TRUE, FALSE); + Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl); + if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) + incpush(SvPVX(privdir), TRUE, FALSE); + + SvREFCNT_dec(privdir); + } + if (!PL_tainting) + incpush(":", FALSE, FALSE); +#else #ifndef PRIVLIB_EXP # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif @@ -3298,17 +3488,26 @@ S_init_perllib(pTHX) incpush(PERL_VENDORLIB_STEM, FALSE, TRUE); #endif +#ifdef PERL_OTHERLIBDIRS + incpush(PERL_OTHERLIBDIRS, TRUE, TRUE); +#endif + if (!PL_tainting) incpush(".", FALSE, FALSE); +#endif /* MACOS_TRADITIONAL */ } -#if defined(DOSISH) +#if defined(DOSISH) || defined(EPOC) # define PERLLIB_SEP ';' #else # if defined(VMS) # define PERLLIB_SEP '|' # else -# define PERLLIB_SEP ':' +# if defined(MACOS_TRADITIONAL) +# define PERLLIB_SEP ',' +# else +# define PERLLIB_SEP ':' +# endif # endif #endif #ifndef PERLLIB_MANGLE @@ -3348,6 +3547,12 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) sv_setpv(libdir, PERLLIB_MANGLE(p, 0)); p = Nullch; /* break out */ } +#ifdef MACOS_TRADITIONAL + if (!strchr(SvPVX(libdir), ':')) + sv_insert(libdir, 0, 0, ":", 1); + if (SvPVX(libdir)[SvCUR(libdir)-1] != ':') + sv_catpv(libdir, ":"); +#endif /* * BEFORE pushing libdir onto @INC we may first push version- and @@ -3375,8 +3580,17 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) SvPV(libdir,len)); #endif if (addsubdirs) { +#ifdef MACOS_TRADITIONAL +#define PERL_AV_SUFFIX_FMT "" +#define PERL_ARCH_FMT "%s:" +#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT +#else +#define PERL_AV_SUFFIX_FMT "/" +#define PERL_ARCH_FMT "/%s" +#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT +#endif /* .../version/archname if -d .../version/archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT, libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION, ARCHNAME); @@ -3385,7 +3599,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) av_push(GvAVn(PL_incgv), newSVsv(subdir)); /* .../version if -d .../version */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir, + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && @@ -3393,7 +3607,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) av_push(GvAVn(PL_incgv), newSVsv(subdir)); /* .../archname if -d .../archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(PL_incgv), newSVsv(subdir)); @@ -3403,7 +3617,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) if (addoldvers) { for (incver = incverlist; *incver; incver++) { /* .../xxx if -d .../xxx */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(PL_incgv), newSVsv(subdir)); @@ -3468,8 +3682,9 @@ S_init_main_thread(pTHX) PERL_SET_THX(thr); /* - * These must come after the SET_THR because sv_setpvn does - * SvTAINT and the taint fields require dTHR. + * These must come after the thread self setting + * because sv_setpvn does SvTAINT and the taint + * fields thread selfness being set. */ PL_toptarget = NEWSV(0,0); sv_upgrade(PL_toptarget, SVt_PVFM); @@ -3497,7 +3712,6 @@ S_init_main_thread(pTHX) void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { - dTHR; SV *atsv; line_t oldline = CopLINE(PL_curcop); CV *cv; @@ -3507,7 +3721,14 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (AvFILL(paramList) >= 0) { cv = (CV*)av_shift(paramList); - SAVEFREESV(cv); + if ((PL_minus_c & 0x10) && (paramList == PL_beginav)) { + /* save PL_beginav for compiler */ + if (! PL_beginav_save) + PL_beginav_save = newAV(); + av_push(PL_beginav_save, (SV*)cv); + } else { + SAVEFREESV(cv); + } #ifdef PERL_FLEXIBLE_EXCEPTIONS CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv); #else @@ -3595,8 +3816,6 @@ S_call_list_body(pTHX_ CV *cv) void Perl_my_exit(pTHX_ U32 status) { - dTHR; - DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n", thr, (unsigned long) status)); switch (status) { @@ -3645,7 +3864,6 @@ Perl_my_failure_exit(pTHX) STATIC void S_my_exit_jump(pTHX) { - dTHR; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; diff --git a/contrib/perl5/perl.h b/contrib/perl5/perl.h index 1105563..2e2b8ca 100644 --- a/contrib/perl5/perl.h +++ b/contrib/perl5/perl.h @@ -1,6 +1,6 @@ /* perl.h * - * Copyright (c) 1987-2000, Larry Wall + * Copyright (c) 1987-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -165,8 +165,8 @@ class CPerlObj; #define aTHXo_ this, #define PERL_OBJECT_THIS aTHXo #define PERL_OBJECT_THIS_ aTHXo_ -#define dTHXoa(a) pTHXo = a -#define dTHXo dTHXoa(PERL_GET_THX) +#define dTHXoa(a) pTHXo = (CPerlObj*)a +#define dTHXo pTHXo = PERL_GET_THX #define pTHXx void #define pTHXx_ @@ -180,16 +180,17 @@ class CPerlObj; struct perl_thread; # define pTHX register struct perl_thread *thr # define aTHX thr -# define dTHR dNOOP +# define dTHR dNOOP /* only backward compatibility */ +# define dTHXa(a) pTHX = (struct perl_thread*)a # else # ifndef MULTIPLICITY # define MULTIPLICITY # endif # define pTHX register PerlInterpreter *my_perl # define aTHX my_perl +# define dTHXa(a) pTHX = (PerlInterpreter*)a # endif -# define dTHXa(a) pTHX = a -# define dTHX dTHXa(PERL_GET_THX) +# define dTHX pTHX = PERL_GET_THX # define pTHX_ pTHX, # define aTHX_ aTHX, # define pTHX_1 2 @@ -243,6 +244,7 @@ struct perl_thread; # define aTHXo aTHX # define aTHXo_ aTHX_ # define dTHXo dTHX +# define dTHXoa(x) dTHXa(x) #endif #ifndef pTHXx @@ -298,7 +300,7 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); #endif #define WITH_THX(s) STMT_START { dTHX; s; } STMT_END -#define WITH_THR(s) STMT_START { dTHR; s; } STMT_END +#define WITH_THR(s) WITH_THX(s) /* * SOFT_CAST can be used for args to prototyped functions to retain some @@ -487,21 +489,16 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); # include <sys/param.h> #endif -/* needed for IAMSUID case for 4.4BSD systems - * XXX there should probably be a Configure variable - */ - -#ifdef I_SYS_PARAM -#if (defined (BSD) && (BSD >= 199306)) -# include <sys/mount.h> -#endif /* !BSD */ -#endif /* !I_SYS_PARAM */ - /* Use all the "standard" definitions? */ #if defined(STANDARD_C) && defined(I_STDLIB) # include <stdlib.h> #endif +/* If this causes problems, set i_unistd=undef in the hint file. */ +#ifdef I_UNISTD +# include <unistd.h> +#endif + #ifdef PERL_MICRO /* Last chance to export Perl_my_swap */ # define MYSWAP #endif @@ -548,17 +545,6 @@ Free_t Perl_mfree (Malloc_t where); typedef struct perl_mstats perl_mstats_t; -struct perl_mstats { - unsigned long *nfree; - unsigned long *ntotal; - long topbucket, topbucket_ev, topbucket_odd, totfree, total, total_chain; - long total_sbrk, sbrks, sbrk_good, sbrk_slack, start_slack, sbrked_remains; - long minbucket; - /* Level 1 info */ - unsigned long *bucket_mem_size; - unsigned long *bucket_available_size; -}; - # define safemalloc Perl_malloc # define safecalloc Perl_calloc # define saferealloc Perl_realloc @@ -719,10 +705,50 @@ struct perl_mstats { #endif #include <errno.h> -#ifdef HAS_SOCKET -# ifdef I_NET_ERRNO -# include <net/errno.h> + +#if defined(WIN32) && (defined(PERL_OBJECT) || defined(PERL_IMPLICIT_SYS) || defined(PERL_CAPI)) +# define WIN32SCK_IS_STDSCK /* don't pull in custom wsock layer */ +#endif + +#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */ +# include <sys/socket.h> +# if defined(USE_SOCKS) && defined(I_SOCKS) +# if !defined(INCLUDE_PROTOTYPES) +# define INCLUDE_PROTOTYPES /* for <socks.h> */ +# define PERL_SOCKS_NEED_PROTOTYPES +# endif +# ifdef USE_THREADS +# define PERL_USE_THREADS /* store our value */ +# undef USE_THREADS +# endif +# include <socks.h> +# ifdef USE_THREADS +# undef USE_THREADS /* socks.h does this on its own */ +# endif +# ifdef PERL_USE_THREADS +# define USE_THREADS /* restore our value */ +# undef PERL_USE_THREADS +# endif +# ifdef PERL_SOCKS_NEED_PROTOTYPES /* keep cpp space clean */ +# undef INCLUDE_PROTOTYPES +# undef PERL_SOCKS_NEED_PROTOTYPES +# endif +# ifdef USE_64_BIT_ALL +# define SOCKS_64BIT_BUG /* until proven otherwise */ # endif +# endif +# ifdef I_NETDB +# include <netdb.h> +# endif +# ifndef ENOTSOCK +# ifdef I_NET_ERRNO +# include <net/errno.h> +# endif +# endif +#endif + +#ifdef SETERRNO +# undef SETERRNO /* SOCKS might have defined this */ #endif #ifdef VMS @@ -1072,8 +1098,16 @@ typedef UVTYPE UV; #define PTR2IV(p) INT2PTR(IV,p) #define PTR2UV(p) INT2PTR(UV,p) #define PTR2NV(p) NUM2PTR(NV,p) +#if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +#else +# define PTR2ul(p) INT2PTR(unsigned long,p) +#endif #ifdef USE_LONG_DOUBLE +# if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE == DOUBLESIZE +# define LONG_DOUBLE_EQUALS_DOUBLE +# endif # if !(defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE)) # undef USE_LONG_DOUBLE /* Ouch! */ # endif @@ -1154,16 +1188,22 @@ typedef NVTYPE NV; # include <sunmath.h> # endif # define NV_DIG LDBL_DIG -# ifdef HAS_SQRTL - /* libsunmath doesn't have modfl and frexpl as of mid-March 2000 */ - /* XXX Configure probe for modfl and frexpl needed XXX */ -# if defined(__sun) && defined(__svr4) -# define Perl_modf(x,y) ((long double)modf((double)(x),(double*)(y))) -# define Perl_frexp(x) ((long double)frexp((double)(x))) +# ifdef LDBL_MANT_DIG +# define NV_MANT_DIG LDBL_MANT_DIG +# endif +# ifdef LDBL_MAX +# define NV_MAX LDBL_MAX +# define NV_MIN LDBL_MIN +# else +# ifdef HUGE_VALL +# define NV_MAX HUGE_VALL # else -# define Perl_modf modfl -# define Perl_frexp frexpl +# ifdef HUGE_VAL +# define NV_MAX ((NV)HUGE_VAL) +# endif # endif +# endif +# ifdef HAS_SQRTL # define Perl_cos cosl # define Perl_sin sinl # define Perl_sqrt sqrtl @@ -1174,10 +1214,39 @@ typedef NVTYPE NV; # define Perl_floor floorl # define Perl_fmod fmodl # endif +/* e.g. libsunmath doesn't have modfl and frexpl as of mid-March 2000 */ +# ifdef HAS_MODFL +# define Perl_modf(x,y) modfl(x,y) +# else +# define Perl_modf(x,y) ((long double)modf((double)(x),(double*)(y))) +# endif +# ifdef HAS_FREXPL +# define Perl_frexp(x,y) frexpl(x,y) +# else +# define Perl_frexp(x,y) ((long double)frexp((double)(x),y)) +# endif +# ifdef HAS_ISNANL +# define Perl_isnan(x) isnanl(x) +# else +# ifdef HAS_ISNAN +# define Perl_isnan(x) isnan((double)(x)) +# else +# define Perl_isnan(x) ((x)!=(x)) +# endif +# endif #else # define NV_DIG DBL_DIG -# define Perl_modf modf -# define Perl_frexp frexp +# ifdef DBL_MANT_DIG +# define NV_MANT_DIG DBL_MANT_DIG +# endif +# ifdef DBL_MAX +# define NV_MAX DBL_MAX +# define NV_MIN DBL_MIN +# else +# ifdef HUGE_VAL +# define NV_MAX HUGE_VAL +# endif +# endif # define Perl_cos cos # define Perl_sin sin # define Perl_sqrt sqrt @@ -1187,19 +1256,33 @@ typedef NVTYPE NV; # define Perl_pow pow # define Perl_floor floor # define Perl_fmod fmod +# define Perl_modf(x,y) modf(x,y) +# define Perl_frexp(x,y) frexp(x,y) +# ifdef HAS_ISNAN +# define Perl_isnan(x) isnan(x) +# else +# define Perl_isnan(x) ((x)!=(x)) +# endif #endif #if !defined(Perl_atof) && defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # if !defined(Perl_atof) && defined(HAS_STRTOLD) -# define Perl_atof(s) strtold(s, (char**)NULL) +# define Perl_atof(s) (NV)strtold(s, (char**)NULL) # endif # if !defined(Perl_atof) && defined(HAS_ATOLF) -# define Perl_atof atolf +# define Perl_atof (NV)atolf +# endif +# if !defined(Perl_atof) && defined(PERL_SCNfldbl) +# define Perl_atof PERL_SCNfldbl +# define Perl_atof2(s,f) sscanf((s), "%"PERL_SCNfldbl, &(f)) # endif #endif #if !defined(Perl_atof) # define Perl_atof atof /* we assume atof being available anywhere */ #endif +#if !defined(Perl_atof2) +# define Perl_atof2(s,f) ((f) = (NV)Perl_atof(s)) +#endif /* Previously these definitions used hardcoded figures. * It is hoped these formula are more portable, although @@ -1372,28 +1455,25 @@ typedef NVTYPE NV; #ifdef UV_IS_QUAD -# ifdef UQUAD_MAX -# define PERL_UQUAD_MAX ((UV)UQUAD_MAX) -# else # define PERL_UQUAD_MAX (~(UV)0) -# endif - -# define PERL_UQUAD_MIN ((UV)0) - -# ifdef QUAD_MAX -# define PERL_QUAD_MAX ((IV)QUAD_MAX) -# else +# define PERL_UQUAD_MIN ((UV)0) # define PERL_QUAD_MAX ((IV) (PERL_UQUAD_MAX >> 1)) -# endif - -# ifdef QUAD_MIN -# define PERL_QUAD_MIN ((IV)QUAD_MIN) -# else # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) -# endif #endif +struct perl_mstats { + UV *nfree; + UV *ntotal; + IV topbucket, topbucket_ev, topbucket_odd, totfree, total, total_chain; + IV total_sbrk, sbrks, sbrk_good, sbrk_slack, start_slack, sbrked_remains; + IV minbucket; + /* Level 1 info */ + UV *bucket_mem_size; + UV *bucket_available_size; + UV nbuckets; +}; + typedef MEM_SIZE STRLEN; typedef struct op OP; @@ -1409,7 +1489,12 @@ typedef struct pvop PVOP; typedef struct loop LOOP; typedef struct interpreter PerlInterpreter; -typedef struct sv SV; +#ifdef UTS +# define STRUCT_SV perl_sv /* Amdahl's <ksync.h> has struct sv */ +#else +# define STRUCT_SV sv +#endif +typedef struct STRUCT_SV SV; typedef struct av AV; typedef struct hv HV; typedef struct cv CV; @@ -1574,6 +1659,9 @@ typedef struct ptr_tbl PTR_TBL_t; # else # if defined(MACOS_TRADITIONAL) # include "macos/macish.h" +# ifndef NO_ENVIRON_ARRAY +# define NO_ENVIRON_ARRAY +# endif # else # include "unixish.h" # endif @@ -1582,7 +1670,18 @@ typedef struct ptr_tbl PTR_TBL_t; # endif # endif # endif -#endif +#endif + +#ifndef NO_ENVIRON_ARRAY +# define USE_ENVIRON_ARRAY +#endif + +#ifdef JPL + /* E.g. JPL needs to operate on a copy of the real environment. + * JDK 1.2 and 1.3 seem to get upset if the original environment + * is diddled with. */ +# define NEED_ENVIRON_DUP_FOR_MODIFY +#endif #ifndef PERL_SYS_INIT3 # define PERL_SYS_INIT3(argvp,argcp,envp) PERL_SYS_INIT(argvp,argcp) @@ -1772,9 +1871,25 @@ typedef pthread_key_t perl_key; # endif #endif +#ifndef UVf +# ifdef CHECK_FORMAT +# define UVf UVuf +# else +# define UVf "Vu" +# endif +#endif + +#ifndef VDf +# ifdef CHECK_FORMAT +# define VDf "p" +# else +# define VDf "vd" +# endif +#endif + /* Some unistd.h's give a prototype for pause() even though HAS_PAUSE ends up undefined. This causes the #define - below to be rejected by the compmiler. Sigh. + below to be rejected by the compiler. Sigh. */ #ifdef HAS_PAUSE #define Pause pause @@ -1994,6 +2109,7 @@ Gid_t getegid (void); #ifndef Perl_error_log # define Perl_error_log (PL_stderrgv \ + && GvIOp(PL_stderrgv) \ && IoOFP(GvIOp(PL_stderrgv)) \ ? IoOFP(GvIOp(PL_stderrgv)) \ : PerlIO_stderr()) @@ -2014,9 +2130,11 @@ Gid_t getegid (void); # if defined(PERL_OBJECT) # define DEBUG_m(a) if (PL_debug & 128) a # else + /* Temporarily turn off memory debugging in case the a + * does memory allocation, either directly or indirectly. */ # define DEBUG_m(a) \ STMT_START { \ - if (PERL_GET_INTERP) { dTHX; if (PL_debug & 128) { a; } } \ + if (PERL_GET_INTERP) { dTHX; if (PL_debug & 128) {PL_debug&=~128; a; PL_debug|=128;} } \ } STMT_END # endif #define DEBUG_f(a) if (PL_debug & 256) a @@ -2032,6 +2150,7 @@ Gid_t getegid (void); # else # define DEBUG_S(a) # endif +#define DEBUG_T(a) if (PL_debug & (1<<17)) a #else #define DEB(a) #define DEBUG(a) @@ -2052,6 +2171,7 @@ Gid_t getegid (void); #define DEBUG_X(a) #define DEBUG_D(a) #define DEBUG_S(a) +#define DEBUG_T(a) #endif #define YYMAXDEPTH 300 @@ -2122,8 +2242,12 @@ char *crypt (const char*, const char*); # ifndef getenv char *getenv (const char*); # endif /* !getenv */ -# if !defined(EPOC) && !(defined(__hpux) && defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS == 64) && !defined(HAS_LSEEK_PROTO) +# if !defined(HAS_LSEEK_PROTO) && !defined(EPOC) && !defined(__hpux) +# ifdef _FILE_OFFSET_BITS +# if _FILE_OFFSET_BITS == 64 Off_t lseek (int,Off_t,int); +# endif +# endif # endif # endif /* !DONT_DECLARE_STD */ char *getlogin (void); @@ -2209,18 +2333,18 @@ typedef OP* (CPERLscope(*PPADDR_t)[]) (pTHX); # define environ (*environ_pointer) EXT char *** environ_pointer; # else -# if defined(__APPLE__) +# if defined(__APPLE__) && defined(PERL_CORE) # include <crt_externs.h> /* for the env array */ # define environ (*_NSGetEnviron()) # endif # endif #else /* VMS and some other platforms don't use the environ array */ -# if !defined(VMS) +# ifdef USE_ENVIRON_ARRAY # if !defined(DONT_DECLARE_STD) || \ (defined(__svr4__) && defined(__GNUC__) && defined(sun)) || \ defined(__sgi) || \ - defined(__DGUX) || defined(EPOC) + defined(__DGUX) extern char ** environ; /* environment variables supplied via exec */ # endif # endif @@ -2585,10 +2709,6 @@ typedef char* (CPERLscope(*re_intuit_start_t)) (pTHX_ regexp *prog, SV *sv, typedef SV* (CPERLscope(*re_intuit_string_t)) (pTHX_ regexp *prog); typedef void (CPERLscope(*regfree_t)) (pTHX_ struct regexp* r); -#ifdef USE_PURE_BISON -int Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp); -#endif - typedef void (*DESTRUCTORFUNC_NOCONTEXT_t) (void*); typedef void (*DESTRUCTORFUNC_t) (pTHXo_ void*); typedef void (*SVFUNC_t) (pTHXo_ SV*); @@ -2834,7 +2954,8 @@ EXT MGVTBL PL_vtbl_defelem = {MEMBER_TO_FPTR(Perl_magic_getdefelem),MEMBER_TO_FP EXT MGVTBL PL_vtbl_regexp = {0,0,0,0, MEMBER_TO_FPTR(Perl_magic_freeregexp)}; EXT MGVTBL PL_vtbl_regdata = {0, 0, MEMBER_TO_FPTR(Perl_magic_regdata_cnt), 0, 0}; -EXT MGVTBL PL_vtbl_regdatum = {MEMBER_TO_FPTR(Perl_magic_regdatum_get), 0, 0, 0, 0}; +EXT MGVTBL PL_vtbl_regdatum = {MEMBER_TO_FPTR(Perl_magic_regdatum_get), + MEMBER_TO_FPTR(Perl_magic_regdatum_set), 0, 0, 0}; #ifdef USE_LOCALE_COLLATE EXT MGVTBL PL_vtbl_collxfrm = {0, @@ -3062,23 +3183,29 @@ typedef struct am_table_short AMTS; #ifdef USE_LOCALE_NUMERIC #define SET_NUMERIC_STANDARD() \ - STMT_START { \ - if (! PL_numeric_standard) \ - set_numeric_standard(); \ - } STMT_END + set_numeric_standard(); #define SET_NUMERIC_LOCAL() \ - STMT_START { \ - if (! PL_numeric_local) \ - set_numeric_local(); \ - } STMT_END + set_numeric_local(); -#define IS_NUMERIC_RADIX(c) \ +#define IS_NUMERIC_RADIX(s) \ ((PL_hints & HINT_LOCALE) && \ - PL_numeric_radix && (c) == PL_numeric_radix) + PL_numeric_radix_sv && memEQ(s, SvPVX(PL_numeric_radix_sv), SvCUR(PL_numeric_radix_sv))) + +#define STORE_NUMERIC_LOCAL_SET_STANDARD() \ + bool was_local = (PL_hints & HINT_LOCALE) && PL_numeric_local; \ + if (was_local) SET_NUMERIC_STANDARD(); + +#define STORE_NUMERIC_STANDARD_SET_LOCAL() \ + bool was_standard = (PL_hints & HINT_LOCALE) && PL_numeric_standard; \ + if (was_standard) SET_NUMERIC_LOCAL(); + +#define RESTORE_NUMERIC_LOCAL() \ + if (was_local) SET_NUMERIC_LOCAL(); + +#define RESTORE_NUMERIC_STANDARD() \ + if (was_standard) SET_NUMERIC_STANDARD(); -#define RESTORE_NUMERIC_LOCAL() if ((PL_hints & HINT_LOCALE) && PL_numeric_standard) SET_NUMERIC_LOCAL() -#define RESTORE_NUMERIC_STANDARD() if ((PL_hints & HINT_LOCALE) && PL_numeric_local) SET_NUMERIC_STANDARD() #define Atof my_atof #else /* !USE_LOCALE_NUMERIC */ @@ -3086,6 +3213,8 @@ typedef struct am_table_short AMTS; #define SET_NUMERIC_STANDARD() /**/ #define SET_NUMERIC_LOCAL() /**/ #define IS_NUMERIC_RADIX(c) (0) +#define STORE_NUMERIC_LOCAL_SET_STANDARD() /**/ +#define STORE_NUMERIC_STANDARD_SET_LOCAL() /**/ #define RESTORE_NUMERIC_LOCAL() /**/ #define RESTORE_NUMERIC_STANDARD() /**/ #define Atof Perl_atof @@ -3310,6 +3439,10 @@ typedef struct am_table_short AMTS; # include <libutil.h> /* setproctitle() in some FreeBSDs */ #endif +#ifndef EXEC_ARGV_CAST +#define EXEC_ARGV_CAST(x) x +#endif + /* and finally... */ #define PERL_PATCHLEVEL_H_IMPLICIT #include "patchlevel.h" @@ -3336,6 +3469,10 @@ typedef struct am_table_short AMTS; I_SYSMMAN Mmap_t + NVef + NVff + NVgf + so that Configure picks them up. */ #endif /* Include guard */ diff --git a/contrib/perl5/pp.c b/contrib/perl5/pp.c index 58fda0e..b57419b 100644 --- a/contrib/perl5/pp.c +++ b/contrib/perl5/pp.c @@ -1,6 +1,6 @@ /* pp.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -83,10 +83,6 @@ static double UV_MAX_cxux = ((double)UV_MAX); /* variations on pp_null */ -#ifdef I_UNISTD -#include <unistd.h> -#endif - /* XXX I can't imagine anyone who doesn't have this actually _needs_ it, since pid_t is an integral type. --AD 2/20/1998 @@ -97,7 +93,7 @@ extern Pid_t getpid (void); PP(pp_stub) { - djSP; + dSP; if (GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef); RETURN; @@ -112,13 +108,18 @@ PP(pp_scalar) PP(pp_padav) { - djSP; dTARGET; + dSP; dTARGET; if (PL_op->op_private & OPpLVAL_INTRO) SAVECLEARSV(PL_curpad[PL_op->op_targ]); EXTEND(SP, 1); if (PL_op->op_flags & OPf_REF) { PUSHs(TARG); RETURN; + } else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); + PUSHs(TARG); + RETURN; } if (GIMME == G_ARRAY) { I32 maxarg = AvFILL((AV*)TARG) + 1; @@ -146,7 +147,7 @@ PP(pp_padav) PP(pp_padhv) { - djSP; dTARGET; + dSP; dTARGET; I32 gimme; XPUSHs(TARG); @@ -154,6 +155,11 @@ PP(pp_padhv) SAVECLEARSV(PL_curpad[PL_op->op_targ]); if (PL_op->op_flags & OPf_REF) RETURN; + else if (LVRET) { + if (GIMME == G_SCALAR) + Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); + RETURN; + } gimme = GIMME_V; if (gimme == G_ARRAY) { RETURNOP(do_kv()); @@ -179,7 +185,7 @@ PP(pp_padany) PP(pp_rv2gv) { - djSP; dTOPss; + dSP; dTOPss; if (SvROK(sv)) { wasref: @@ -199,7 +205,7 @@ PP(pp_rv2gv) else { if (SvTYPE(sv) != SVt_PVGV) { char *sym; - STRLEN n_a; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -237,13 +243,17 @@ PP(pp_rv2gv) report_uninit(); RETSETUNDEF; } - sym = SvPV(sv, n_a); + sym = SvPV(sv,len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV); - if (!sv) + if (!sv + && (!is_gv_magical(sym,len,0) + || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV)))) + { RETSETUNDEF; + } } else { if (PL_op->op_private & HINT_STRICT_REFS) @@ -260,7 +270,7 @@ PP(pp_rv2gv) PP(pp_rv2sv) { - djSP; dTOPss; + dSP; dTOPss; if (SvROK(sv)) { wasref: @@ -277,7 +287,7 @@ PP(pp_rv2sv) else { GV *gv = (GV*)sv; char *sym; - STRLEN n_a; + STRLEN len; if (SvTYPE(gv) != SVt_PVGV) { if (SvGMAGICAL(sv)) { @@ -293,13 +303,17 @@ PP(pp_rv2sv) report_uninit(); RETSETUNDEF; } - sym = SvPV(sv, n_a); + sym = SvPV(sv, len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV); - if (!gv) + if (!gv + && (!is_gv_magical(sym,len,0) + || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV)))) + { RETSETUNDEF; + } } else { if (PL_op->op_private & HINT_STRICT_REFS) @@ -321,7 +335,7 @@ PP(pp_rv2sv) PP(pp_av2arylen) { - djSP; + dSP; AV *av = (AV*)TOPs; SV *sv = AvARYLEN(av); if (!sv) { @@ -335,9 +349,9 @@ PP(pp_av2arylen) PP(pp_pos) { - djSP; dTARGET; dPOPss; + dSP; dTARGET; dPOPss; - if (PL_op->op_flags & OPf_MOD) { + if (PL_op->op_flags & OPf_MOD || LVRET) { if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, '.', Nullch, 0); @@ -371,7 +385,7 @@ PP(pp_pos) PP(pp_rv2cv) { - djSP; + dSP; GV *gv; HV *stash; @@ -381,8 +395,12 @@ PP(pp_rv2cv) if (cv) { if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); - if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv)) - DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + if ((PL_op->op_private & OPpLVAL_INTRO)) { + if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE))) + cv = GvCV(gv); + if (!CvLVALUE(cv)) + DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + } } else cv = (CV*)&PL_sv_undef; @@ -392,7 +410,7 @@ PP(pp_rv2cv) PP(pp_prototype) { - djSP; + dSP; CV *cv; HV *stash; GV *gv; @@ -458,7 +476,7 @@ PP(pp_prototype) PP(pp_anoncode) { - djSP; + dSP; CV* cv = (CV*)PL_curpad[PL_op->op_targ]; if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); @@ -469,14 +487,14 @@ PP(pp_anoncode) PP(pp_srefgen) { - djSP; + dSP; *SP = refto(*SP); RETURN; } PP(pp_refgen) { - djSP; dMARK; + dSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; @@ -526,7 +544,7 @@ S_refto(pTHX_ SV *sv) PP(pp_ref) { - djSP; dTARGET; + dSP; dTARGET; SV *sv; char *pv; @@ -546,7 +564,7 @@ PP(pp_ref) PP(pp_bless) { - djSP; + dSP; HV *stash; if (MAXARG == 1) @@ -571,7 +589,7 @@ PP(pp_gelem) SV *sv; SV *tmpRef; char *elem; - djSP; + dSP; STRLEN n_a; sv = POPs; @@ -632,7 +650,7 @@ PP(pp_gelem) PP(pp_study) { - djSP; dPOPss; + dSP; dPOPss; register unsigned char *s; register I32 pos; register I32 ch; @@ -694,7 +712,7 @@ PP(pp_study) PP(pp_trans) { - djSP; dTARG; + dSP; dTARG; SV *sv; if (PL_op->op_flags & OPf_STACKED) @@ -712,7 +730,7 @@ PP(pp_trans) PP(pp_schop) { - djSP; dTARGET; + dSP; dTARGET; do_chop(TARG, TOPs); SETTARG; RETURN; @@ -720,23 +738,24 @@ PP(pp_schop) PP(pp_chop) { - djSP; dMARK; dTARGET; - while (SP > MARK) - do_chop(TARG, POPs); + dSP; dMARK; dTARGET; dORIGMARK; + while (MARK < SP) + do_chop(TARG, *++MARK); + SP = ORIGMARK; PUSHTARG; RETURN; } PP(pp_schomp) { - djSP; dTARGET; + dSP; dTARGET; SETi(do_chomp(TOPs)); RETURN; } PP(pp_chomp) { - djSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; register I32 count = 0; while (SP > MARK) @@ -747,7 +766,7 @@ PP(pp_chomp) PP(pp_defined) { - djSP; + dSP; register SV* sv; sv = POPs; @@ -777,7 +796,7 @@ PP(pp_defined) PP(pp_undef) { - djSP; + dSP; SV *sv; if (!PL_op->op_private) { @@ -809,7 +828,7 @@ PP(pp_undef) case SVt_PVFM: { /* let user-undef'd sub keep its identity */ - GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv)); + GV* gv = CvGV((CV*)sv); cv_undef((CV*)sv); CvGV((CV*)sv) = gv; } @@ -844,7 +863,7 @@ PP(pp_undef) PP(pp_predec) { - djSP; + dSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && @@ -861,7 +880,7 @@ PP(pp_predec) PP(pp_postinc) { - djSP; dTARGET; + dSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); @@ -882,7 +901,7 @@ PP(pp_postinc) PP(pp_postdec) { - djSP; dTARGET; + dSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); @@ -903,7 +922,7 @@ PP(pp_postdec) PP(pp_pow) { - djSP; dATARGET; tryAMAGICbin(pow,opASSIGN); + dSP; dATARGET; tryAMAGICbin(pow,opASSIGN); { dPOPTOPnnrl; SETn( Perl_pow( left, right) ); @@ -913,7 +932,7 @@ PP(pp_pow) PP(pp_multiply) { - djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPnnrl; SETn( left * right ); @@ -923,7 +942,7 @@ PP(pp_multiply) PP(pp_divide) { - djSP; dATARGET; tryAMAGICbin(div,opASSIGN); + dSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPPOPnnrl; NV value; @@ -952,7 +971,7 @@ PP(pp_divide) PP(pp_modulo) { - djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { UV left; UV right; @@ -962,7 +981,7 @@ PP(pp_modulo) NV dright; NV dleft; - if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { + if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { IV i = SvIVX(POPs); right = (right_neg = (i < 0)) ? -i : i; } @@ -974,7 +993,7 @@ PP(pp_modulo) dright = -dright; } - if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { + if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { IV i = SvIVX(POPs); left = (left_neg = (i < 0)) ? -i : i; } @@ -1052,9 +1071,9 @@ PP(pp_modulo) PP(pp_repeat) { - djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); + dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); { - register I32 count = POPi; + register IV count = POPi; if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; I32 items = SP - MARK; @@ -1077,12 +1096,13 @@ PP(pp_repeat) SP -= items; } else { /* Note: mark already snarfed by pp_list */ - SV *tmpstr; + SV *tmpstr = POPs; STRLEN len; + bool isutf; - tmpstr = POPs; SvSetSV(TARG, tmpstr); SvPV_force(TARG, len); + isutf = DO_UTF8(TARG); if (count != 1) { if (count < 1) SvCUR_set(TARG, 0); @@ -1093,7 +1113,10 @@ PP(pp_repeat) } *SvEND(TARG) = '\0'; } - (void)SvPOK_only(TARG); + if (isutf) + (void)SvPOK_only_UTF8(TARG); + else + (void)SvPOK_only(TARG); PUSHTARG; } RETURN; @@ -1102,7 +1125,7 @@ PP(pp_repeat) PP(pp_subtract) { - djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { dPOPTOPnnrl_ul; SETn( left - right ); @@ -1112,7 +1135,7 @@ PP(pp_subtract) PP(pp_left_shift) { - djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); + dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { IV shift = POPi; if (PL_op->op_private & HINT_INTEGER) { @@ -1129,7 +1152,7 @@ PP(pp_left_shift) PP(pp_right_shift) { - djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); + dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { IV shift = POPi; if (PL_op->op_private & HINT_INTEGER) { @@ -1146,7 +1169,7 @@ PP(pp_right_shift) PP(pp_lt) { - djSP; tryAMAGICbinSET(lt,0); + dSP; tryAMAGICbinSET(lt,0); { dPOPnv; SETs(boolSV(TOPn < value)); @@ -1156,7 +1179,7 @@ PP(pp_lt) PP(pp_gt) { - djSP; tryAMAGICbinSET(gt,0); + dSP; tryAMAGICbinSET(gt,0); { dPOPnv; SETs(boolSV(TOPn > value)); @@ -1166,7 +1189,7 @@ PP(pp_gt) PP(pp_le) { - djSP; tryAMAGICbinSET(le,0); + dSP; tryAMAGICbinSET(le,0); { dPOPnv; SETs(boolSV(TOPn <= value)); @@ -1176,7 +1199,7 @@ PP(pp_le) PP(pp_ge) { - djSP; tryAMAGICbinSET(ge,0); + dSP; tryAMAGICbinSET(ge,0); { dPOPnv; SETs(boolSV(TOPn >= value)); @@ -1186,7 +1209,7 @@ PP(pp_ge) PP(pp_ne) { - djSP; tryAMAGICbinSET(ne,0); + dSP; tryAMAGICbinSET(ne,0); { dPOPnv; SETs(boolSV(TOPn != value)); @@ -1196,19 +1219,12 @@ PP(pp_ne) PP(pp_ncmp) { - djSP; dTARGET; tryAMAGICbin(ncmp,0); + dSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPnnrl; I32 value; -#ifdef __osf__ /* XXX Configure probe for isnan and isnanl needed XXX */ -#if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) -#define Perl_isnan isnanl -#else -#define Perl_isnan isnan -#endif -#endif -#ifdef __osf__ /* XXX fix in 5.6.1 --jhi */ +#ifdef Perl_isnan if (Perl_isnan(left) || Perl_isnan(right)) { SETs(&PL_sv_undef); RETURN; @@ -1233,7 +1249,7 @@ PP(pp_ncmp) PP(pp_slt) { - djSP; tryAMAGICbinSET(slt,0); + dSP; tryAMAGICbinSET(slt,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) @@ -1246,7 +1262,7 @@ PP(pp_slt) PP(pp_sgt) { - djSP; tryAMAGICbinSET(sgt,0); + dSP; tryAMAGICbinSET(sgt,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) @@ -1259,7 +1275,7 @@ PP(pp_sgt) PP(pp_sle) { - djSP; tryAMAGICbinSET(sle,0); + dSP; tryAMAGICbinSET(sle,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) @@ -1272,7 +1288,7 @@ PP(pp_sle) PP(pp_sge) { - djSP; tryAMAGICbinSET(sge,0); + dSP; tryAMAGICbinSET(sge,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) @@ -1285,7 +1301,7 @@ PP(pp_sge) PP(pp_seq) { - djSP; tryAMAGICbinSET(seq,0); + dSP; tryAMAGICbinSET(seq,0); { dPOPTOPssrl; SETs(boolSV(sv_eq(left, right))); @@ -1295,7 +1311,7 @@ PP(pp_seq) PP(pp_sne) { - djSP; tryAMAGICbinSET(sne,0); + dSP; tryAMAGICbinSET(sne,0); { dPOPTOPssrl; SETs(boolSV(!sv_eq(left, right))); @@ -1305,7 +1321,7 @@ PP(pp_sne) PP(pp_scmp) { - djSP; dTARGET; tryAMAGICbin(scmp,0); + dSP; dTARGET; tryAMAGICbin(scmp,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) @@ -1318,7 +1334,7 @@ PP(pp_scmp) PP(pp_bit_and) { - djSP; dATARGET; tryAMAGICbin(band,opASSIGN); + dSP; dATARGET; tryAMAGICbin(band,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { @@ -1341,7 +1357,7 @@ PP(pp_bit_and) PP(pp_bit_xor) { - djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); + dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { @@ -1364,7 +1380,7 @@ PP(pp_bit_xor) PP(pp_bit_or) { - djSP; dATARGET; tryAMAGICbin(bor,opASSIGN); + dSP; dATARGET; tryAMAGICbin(bor,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { @@ -1387,7 +1403,7 @@ PP(pp_bit_or) PP(pp_negate) { - djSP; dTARGET; tryAMAGICun(neg); + dSP; dTARGET; tryAMAGICun(neg); { dTOPss; if (SvGMAGICAL(sv)) @@ -1421,7 +1437,7 @@ PP(pp_negate) sv_setsv(TARG, sv); *SvPV_force(TARG, len) = *s == '-' ? '+' : '-'; } - else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) { + else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) { sv_setpvn(TARG, "-", 1); sv_catsv(TARG, sv); } @@ -1437,14 +1453,14 @@ PP(pp_negate) PP(pp_not) { - djSP; tryAMAGICunSET(not); + dSP; tryAMAGICunSET(not); *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp)); return NORMAL; } PP(pp_complement) { - djSP; dTARGET; tryAMAGICun(compl); + dSP; dTARGET; tryAMAGICun(compl); { dTOPss; if (SvNIOKp(sv)) { @@ -1458,21 +1474,72 @@ PP(pp_complement) } } else { - register char *tmps; - register long *tmpl; + register U8 *tmps; register I32 anum; STRLEN len; SvSetSV(TARG, sv); - tmps = SvPV_force(TARG, len); + tmps = (U8*)SvPV_force(TARG, len); anum = len; + if (SvUTF8(TARG)) { + /* Calculate exact length, let's not estimate. */ + STRLEN targlen = 0; + U8 *result; + U8 *send; + STRLEN l; + UV nchar = 0; + UV nwide = 0; + + send = tmps + len; + while (tmps < send) { + UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); + tmps += UTF8SKIP(tmps); + targlen += UNISKIP(~c); + nchar++; + if (c > 0xff) + nwide++; + } + + /* Now rewind strings and write them. */ + tmps -= len; + + if (nwide) { + Newz(0, result, targlen + 1, U8); + while (tmps < send) { + UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); + tmps += UTF8SKIP(tmps); + result = uv_to_utf8(result, ~c); + } + *result = '\0'; + result -= targlen; + sv_setpvn(TARG, (char*)result, targlen); + SvUTF8_on(TARG); + } + else { + Newz(0, result, nchar + 1, U8); + while (tmps < send) { + U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY); + tmps += UTF8SKIP(tmps); + *result++ = ~c; + } + *result = '\0'; + result -= nchar; + sv_setpvn(TARG, (char*)result, nchar); + } + Safefree(result); + SETs(TARG); + RETURN; + } #ifdef LIBERAL - for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) - *tmps = ~*tmps; - tmpl = (long*)tmps; - for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++) - *tmpl = ~*tmpl; - tmps = (char*)tmpl; + { + register long *tmpl; + for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) + *tmps = ~*tmps; + tmpl = (long*)tmps; + for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++) + *tmpl = ~*tmpl; + tmps = (U8*)tmpl; + } #endif for ( ; anum > 0; anum--, tmps++) *tmps = ~*tmps; @@ -1487,7 +1554,7 @@ PP(pp_complement) PP(pp_i_multiply) { - djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPiirl; SETi( left * right ); @@ -1497,7 +1564,7 @@ PP(pp_i_multiply) PP(pp_i_divide) { - djSP; dATARGET; tryAMAGICbin(div,opASSIGN); + dSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPiv; if (value == 0) @@ -1510,7 +1577,7 @@ PP(pp_i_divide) PP(pp_i_modulo) { - djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); + dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) @@ -1522,9 +1589,9 @@ PP(pp_i_modulo) PP(pp_i_add) { - djSP; dATARGET; tryAMAGICbin(add,opASSIGN); + dSP; dATARGET; tryAMAGICbin(add,opASSIGN); { - dPOPTOPiirl; + dPOPTOPiirl_ul; SETi( left + right ); RETURN; } @@ -1532,9 +1599,9 @@ PP(pp_i_add) PP(pp_i_subtract) { - djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { - dPOPTOPiirl; + dPOPTOPiirl_ul; SETi( left - right ); RETURN; } @@ -1542,7 +1609,7 @@ PP(pp_i_subtract) PP(pp_i_lt) { - djSP; tryAMAGICbinSET(lt,0); + dSP; tryAMAGICbinSET(lt,0); { dPOPTOPiirl; SETs(boolSV(left < right)); @@ -1552,7 +1619,7 @@ PP(pp_i_lt) PP(pp_i_gt) { - djSP; tryAMAGICbinSET(gt,0); + dSP; tryAMAGICbinSET(gt,0); { dPOPTOPiirl; SETs(boolSV(left > right)); @@ -1562,7 +1629,7 @@ PP(pp_i_gt) PP(pp_i_le) { - djSP; tryAMAGICbinSET(le,0); + dSP; tryAMAGICbinSET(le,0); { dPOPTOPiirl; SETs(boolSV(left <= right)); @@ -1572,7 +1639,7 @@ PP(pp_i_le) PP(pp_i_ge) { - djSP; tryAMAGICbinSET(ge,0); + dSP; tryAMAGICbinSET(ge,0); { dPOPTOPiirl; SETs(boolSV(left >= right)); @@ -1582,7 +1649,7 @@ PP(pp_i_ge) PP(pp_i_eq) { - djSP; tryAMAGICbinSET(eq,0); + dSP; tryAMAGICbinSET(eq,0); { dPOPTOPiirl; SETs(boolSV(left == right)); @@ -1592,7 +1659,7 @@ PP(pp_i_eq) PP(pp_i_ne) { - djSP; tryAMAGICbinSET(ne,0); + dSP; tryAMAGICbinSET(ne,0); { dPOPTOPiirl; SETs(boolSV(left != right)); @@ -1602,7 +1669,7 @@ PP(pp_i_ne) PP(pp_i_ncmp) { - djSP; dTARGET; tryAMAGICbin(ncmp,0); + dSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPiirl; I32 value; @@ -1620,7 +1687,7 @@ PP(pp_i_ncmp) PP(pp_i_negate) { - djSP; dTARGET; tryAMAGICun(neg); + dSP; dTARGET; tryAMAGICun(neg); SETi(-TOPi); RETURN; } @@ -1629,7 +1696,7 @@ PP(pp_i_negate) PP(pp_atan2) { - djSP; dTARGET; tryAMAGICbin(atan2,0); + dSP; dTARGET; tryAMAGICbin(atan2,0); { dPOPTOPnnrl; SETn(Perl_atan2(left, right)); @@ -1639,7 +1706,7 @@ PP(pp_atan2) PP(pp_sin) { - djSP; dTARGET; tryAMAGICun(sin); + dSP; dTARGET; tryAMAGICun(sin); { NV value; value = POPn; @@ -1651,7 +1718,7 @@ PP(pp_sin) PP(pp_cos) { - djSP; dTARGET; tryAMAGICun(cos); + dSP; dTARGET; tryAMAGICun(cos); { NV value; value = POPn; @@ -1678,7 +1745,7 @@ extern double drand48 (void); PP(pp_rand) { - djSP; dTARGET; + dSP; dTARGET; NV value; if (MAXARG < 1) value = 1.0; @@ -1697,7 +1764,7 @@ PP(pp_rand) PP(pp_srand) { - djSP; + dSP; UV anum; if (MAXARG < 1) anum = seed(); @@ -1734,7 +1801,6 @@ S_seed(pTHX) #define SEED_C3 269 #define SEED_C5 26107 - dTHR; #ifndef PERL_NO_DEV_RANDOM int fd; #endif @@ -1793,7 +1859,7 @@ S_seed(pTHX) PP(pp_exp) { - djSP; dTARGET; tryAMAGICun(exp); + dSP; dTARGET; tryAMAGICun(exp); { NV value; value = POPn; @@ -1805,12 +1871,12 @@ PP(pp_exp) PP(pp_log) { - djSP; dTARGET; tryAMAGICun(log); + dSP; dTARGET; tryAMAGICun(log); { NV value; value = POPn; if (value <= 0.0) { - RESTORE_NUMERIC_STANDARD(); + SET_NUMERIC_STANDARD(); DIE(aTHX_ "Can't take log of %g", value); } value = Perl_log(value); @@ -1821,12 +1887,12 @@ PP(pp_log) PP(pp_sqrt) { - djSP; dTARGET; tryAMAGICun(sqrt); + dSP; dTARGET; tryAMAGICun(sqrt); { NV value; value = POPn; if (value < 0.0) { - RESTORE_NUMERIC_STANDARD(); + SET_NUMERIC_STANDARD(); DIE(aTHX_ "Can't take sqrt of %g", value); } value = Perl_sqrt(value); @@ -1837,7 +1903,7 @@ PP(pp_sqrt) PP(pp_int) { - djSP; dTARGET; + dSP; dTARGET; { NV value = TOPn; IV iv; @@ -1847,11 +1913,24 @@ PP(pp_int) SETi(iv); } else { - if (value >= 0.0) - (void)Perl_modf(value, &value); + if (value >= 0.0) { +#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) + (void)Perl_modf(value, &value); +#else + double tmp = (double)value; + (void)Perl_modf(tmp, &tmp); + value = (NV)tmp; +#endif + } else { - (void)Perl_modf(-value, &value); - value = -value; +#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) + (void)Perl_modf(-value, &value); + value = -value; +#else + double tmp = (double)value; + (void)Perl_modf(-tmp, &tmp); + value = -(NV)tmp; +#endif } iv = I_V(value); if (iv == value) @@ -1865,7 +1944,7 @@ PP(pp_int) PP(pp_abs) { - djSP; dTARGET; tryAMAGICun(abs); + dSP; dTARGET; tryAMAGICun(abs); { NV value = TOPn; IV iv; @@ -1887,35 +1966,37 @@ PP(pp_abs) PP(pp_hex) { - djSP; dTARGET; + dSP; dTARGET; char *tmps; - I32 argtype; - STRLEN n_a; + STRLEN argtype; + STRLEN len; - tmps = POPpx; - XPUSHn(scan_hex(tmps, 99, &argtype)); + tmps = (SvPVx(POPs, len)); + argtype = 1; /* allow underscores */ + XPUSHn(scan_hex(tmps, len, &argtype)); RETURN; } PP(pp_oct) { - djSP; dTARGET; + dSP; dTARGET; NV value; - I32 argtype; + STRLEN argtype; char *tmps; - STRLEN n_a; + STRLEN len; - tmps = POPpx; - while (*tmps && isSPACE(*tmps)) - tmps++; + tmps = (SvPVx(POPs, len)); + while (*tmps && len && isSPACE(*tmps)) + tmps++, len--; if (*tmps == '0') - tmps++; + tmps++, len--; + argtype = 1; /* allow underscores */ if (*tmps == 'x') - value = scan_hex(++tmps, 99, &argtype); + value = scan_hex(++tmps, --len, &argtype); else if (*tmps == 'b') - value = scan_bin(++tmps, 99, &argtype); + value = scan_bin(++tmps, --len, &argtype); else - value = scan_oct(tmps, 99, &argtype); + value = scan_oct(tmps, len, &argtype); XPUSHn(value); RETURN; } @@ -1924,7 +2005,7 @@ PP(pp_oct) PP(pp_length) { - djSP; dTARGET; + dSP; dTARGET; SV *sv = TOPs; if (DO_UTF8(sv)) @@ -1936,48 +2017,61 @@ PP(pp_length) PP(pp_substr) { - djSP; dTARGET; + dSP; dTARGET; SV *sv; I32 len; STRLEN curlen; - STRLEN utfcurlen; + STRLEN utf8_curlen; I32 pos; I32 rem; I32 fail; - I32 lvalue = PL_op->op_flags & OPf_MOD; + I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; char *tmps; I32 arybase = PL_curcop->cop_arybase; + SV *repl_sv = NULL; char *repl = 0; STRLEN repl_len; + int num_args = PL_op->op_private & 7; + bool repl_need_utf8_upgrade = FALSE; + bool repl_is_utf8 = FALSE; SvTAINTED_off(TARG); /* decontaminate */ SvUTF8_off(TARG); /* decontaminate */ - if (MAXARG > 2) { - if (MAXARG > 3) { - sv = POPs; - repl = SvPV(sv, repl_len); + if (num_args > 2) { + if (num_args > 3) { + repl_sv = POPs; + repl = SvPV(repl_sv, repl_len); + repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv); } len = POPi; } pos = POPi; sv = POPs; PUTBACK; + if (repl_sv) { + if (repl_is_utf8) { + if (!DO_UTF8(sv)) + sv_utf8_upgrade(sv); + } + else if (DO_UTF8(sv)) + repl_need_utf8_upgrade = TRUE; + } tmps = SvPV(sv, curlen); if (DO_UTF8(sv)) { - utfcurlen = sv_len_utf8(sv); - if (utfcurlen == curlen) - utfcurlen = 0; + utf8_curlen = sv_len_utf8(sv); + if (utf8_curlen == curlen) + utf8_curlen = 0; else - curlen = utfcurlen; + curlen = utf8_curlen; } else - utfcurlen = 0; + utf8_curlen = 0; if (pos >= arybase) { pos -= arybase; rem = curlen-pos; fail = rem; - if (MAXARG > 2) { + if (num_args > 2) { if (len < 0) { rem += len; if (rem < 0) @@ -1989,7 +2083,7 @@ PP(pp_substr) } else { pos += curlen; - if (MAXARG < 3) + if (num_args < 3) rem = curlen; else if (len >= 0) { rem = pos+len; @@ -2014,14 +2108,29 @@ PP(pp_substr) RETPUSHUNDEF; } else { - if (utfcurlen) { + I32 upos = pos; + I32 urem = rem; + if (utf8_curlen) sv_pos_u2b(sv, &pos, &rem); - SvUTF8_on(TARG); - } tmps += pos; sv_setpvn(TARG, tmps, rem); - if (repl) + if (utf8_curlen) + SvUTF8_on(TARG); + if (repl) { + SV* repl_sv_copy = NULL; + + if (repl_need_utf8_upgrade) { + repl_sv_copy = newSVsv(repl_sv); + sv_utf8_upgrade(repl_sv_copy); + repl = SvPV(repl_sv_copy, repl_len); + repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv); + } sv_insert(sv, pos, rem, repl, repl_len); + if (repl_is_utf8) + SvUTF8_on(sv); + if (repl_sv_copy) + SvREFCNT_dec(repl_sv_copy); + } else if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { @@ -2032,7 +2141,7 @@ PP(pp_substr) "Attempt to use reference as lvalue in substr"); } if (SvOK(sv)) /* is it defined ? */ - (void)SvPOK_only(sv); + (void)SvPOK_only_UTF8(sv); else sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ } @@ -2048,8 +2157,8 @@ PP(pp_substr) SvREFCNT_dec(LvTARG(TARG)); LvTARG(TARG) = SvREFCNT_inc(sv); } - LvTARGOFF(TARG) = pos; - LvTARGLEN(TARG) = rem; + LvTARGOFF(TARG) = upos; + LvTARGLEN(TARG) = urem; } } SPAGAIN; @@ -2059,11 +2168,11 @@ PP(pp_substr) PP(pp_vec) { - djSP; dTARGET; - register I32 size = POPi; - register I32 offset = POPi; + dSP; dTARGET; + register IV size = POPi; + register IV offset = POPi; register SV *src = POPs; - I32 lvalue = PL_op->op_flags & OPf_MOD; + I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; SvTAINTED_off(TARG); /* decontaminate */ if (lvalue) { /* it's an lvalue! */ @@ -2088,7 +2197,7 @@ PP(pp_vec) PP(pp_index) { - djSP; dTARGET; + dSP; dTARGET; SV *big; SV *little; I32 offset; @@ -2124,7 +2233,7 @@ PP(pp_index) PP(pp_rindex) { - djSP; dTARGET; + dSP; dTARGET; SV *big; SV *little; STRLEN blen; @@ -2165,7 +2274,7 @@ PP(pp_rindex) PP(pp_sprintf) { - djSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; do_sprintf(TARG, SP-MARK, MARK+1); TAINT_IF(SvTAINTED(TARG)); SP = ORIGMARK; @@ -2175,26 +2284,20 @@ PP(pp_sprintf) PP(pp_ord) { - djSP; dTARGET; - UV value; - STRLEN n_a; - SV *tmpsv = POPs; - U8 *tmps = (U8*)SvPVx(tmpsv,n_a); - I32 retlen; + dSP; dTARGET; + SV *argsv = POPs; + STRLEN len; + U8 *s = (U8*)SvPVx(argsv, len); - if ((*tmps & 0x80) && DO_UTF8(tmpsv)) - value = utf8_to_uv(tmps, &retlen); - else - value = (UV)(*tmps & 255); - XPUSHu(value); + XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff)); RETURN; } PP(pp_chr) { - djSP; dTARGET; + dSP; dTARGET; char *tmps; - U32 value = POPu; + UV value = POPu; (void)SvUPGRADE(TARG,SVt_PV); @@ -2215,7 +2318,6 @@ PP(pp_chr) tmps = SvPVX(TARG); *tmps++ = value; *tmps = '\0'; - SvUTF8_off(TARG); /* decontaminate */ (void)SvPOK_only(TARG); XPUSHs(TARG); RETURN; @@ -2223,7 +2325,7 @@ PP(pp_chr) PP(pp_crypt) { - djSP; dTARGET; dPOPTOPssrl; + dSP; dTARGET; dPOPTOPssrl; STRLEN n_a; #ifdef HAS_CRYPT char *tmps = SvPV(left, n_a); @@ -2242,16 +2344,16 @@ PP(pp_crypt) PP(pp_ucfirst) { - djSP; + dSP; SV *sv = TOPs; register U8 *s; STRLEN slen; - if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { - I32 ulen; - U8 tmpbuf[UTF8_MAXLEN]; + if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) { + STRLEN ulen; + U8 tmpbuf[UTF8_MAXLEN+1]; U8 *tend; - UV uv = utf8_to_uv(s, &ulen); + UV uv = utf8_to_uv(s, slen, &ulen, 0); if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2301,16 +2403,16 @@ PP(pp_ucfirst) PP(pp_lcfirst) { - djSP; + dSP; SV *sv = TOPs; register U8 *s; STRLEN slen; - if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) { - I32 ulen; - U8 tmpbuf[UTF8_MAXLEN]; + if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) { + STRLEN ulen; + U8 tmpbuf[UTF8_MAXLEN+1]; U8 *tend; - UV uv = utf8_to_uv(s, &ulen); + UV uv = utf8_to_uv(s, slen, &ulen, 0); if (PL_op->op_private & OPpLOCALE) { TAINT; @@ -2360,14 +2462,14 @@ PP(pp_lcfirst) PP(pp_uc) { - djSP; + dSP; SV *sv = TOPs; register U8 *s; STRLEN len; if (DO_UTF8(sv)) { dTARGET; - I32 ulen; + STRLEN ulen; register U8 *d; U8 *send; @@ -2387,7 +2489,7 @@ PP(pp_uc) TAINT; SvTAINTED_on(TARG); while (s < send) { - d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen))); + d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0))); s += ulen; } } @@ -2434,14 +2536,14 @@ PP(pp_uc) PP(pp_lc) { - djSP; + dSP; SV *sv = TOPs; register U8 *s; STRLEN len; if (DO_UTF8(sv)) { dTARGET; - I32 ulen; + STRLEN ulen; register U8 *d; U8 *send; @@ -2461,7 +2563,7 @@ PP(pp_lc) TAINT; SvTAINTED_on(TARG); while (s < send) { - d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen))); + d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0))); s += ulen; } } @@ -2509,7 +2611,7 @@ PP(pp_lc) PP(pp_quotemeta) { - djSP; dTARGET; + dSP; dTARGET; SV *sv = TOPs; STRLEN len; register char *s = SvPV(sv,len); @@ -2522,7 +2624,7 @@ PP(pp_quotemeta) d = SvPVX(TARG); if (DO_UTF8(sv)) { while (len) { - if (*s & 0x80) { + if (UTF8_IS_CONTINUED(*s)) { STRLEN ulen = UTF8SKIP(s); if (ulen > len) ulen = len; @@ -2548,7 +2650,7 @@ PP(pp_quotemeta) } *d = '\0'; SvCUR_set(TARG, d - SvPVX(TARG)); - (void)SvPOK_only(TARG); + (void)SvPOK_only_UTF8(TARG); } else sv_setpvn(TARG, s, len); @@ -2562,10 +2664,10 @@ PP(pp_quotemeta) PP(pp_aslice) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; register SV** svp; register AV* av = (AV*)POPs; - register I32 lval = PL_op->op_flags & OPf_MOD; + register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); I32 arybase = PL_curcop->cop_arybase; I32 elem; @@ -2607,7 +2709,7 @@ PP(pp_aslice) PP(pp_each) { - djSP; + dSP; HV *hash = (HV*)POPs; HE *entry; I32 gimme = GIMME_V; @@ -2649,7 +2751,7 @@ PP(pp_keys) PP(pp_delete) { - djSP; + dSP; I32 gimme = GIMME_V; I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; SV *sv; @@ -2713,7 +2815,7 @@ PP(pp_delete) PP(pp_exists) { - djSP; + dSP; SV *tmpsv; HV *hv; @@ -2750,9 +2852,9 @@ PP(pp_exists) PP(pp_hslice) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; register HV *hv = (HV*)POPs; - register I32 lval = PL_op->op_flags & OPf_MOD; + register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); I32 realhv = (SvTYPE(hv) == SVt_PVHV); if (!realhv && PL_op->op_private & OPpLVAL_INTRO) @@ -2792,7 +2894,7 @@ PP(pp_hslice) PP(pp_list) { - djSP; dMARK; + dSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; /* unwanted list, return last item */ @@ -2805,7 +2907,7 @@ PP(pp_list) PP(pp_lslice) { - djSP; + dSP; SV **lastrelem = PL_stack_sp; SV **lastlelem = PL_stack_base + POPMARK; SV **firstlelem = PL_stack_base + POPMARK + 1; @@ -2860,7 +2962,7 @@ PP(pp_lslice) PP(pp_anonlist) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; I32 items = SP - MARK; SV *av = sv_2mortal((SV*)av_make(items, MARK+1)); SP = ORIGMARK; /* av_make() might realloc stack_sp */ @@ -2870,7 +2972,7 @@ PP(pp_anonlist) PP(pp_anonhash) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; HV* hv = (HV*)sv_2mortal((SV*)newHV()); while (MARK < SP) { @@ -2889,7 +2991,7 @@ PP(pp_anonhash) PP(pp_splice) { - djSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; register AV *ary = (AV*)*++MARK; register SV **src; register SV **dst; @@ -3091,7 +3193,7 @@ PP(pp_splice) PP(pp_push) { - djSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv = &PL_sv_undef; MAGIC *mg; @@ -3121,7 +3223,7 @@ PP(pp_push) PP(pp_pop) { - djSP; + dSP; AV *av = (AV*)POPs; SV *sv = av_pop(av); if (AvREAL(av)) @@ -3132,7 +3234,7 @@ PP(pp_pop) PP(pp_shift) { - djSP; + dSP; AV *av = (AV*)POPs; SV *sv = av_shift(av); EXTEND(SP, 1); @@ -3146,7 +3248,7 @@ PP(pp_shift) PP(pp_unshift) { - djSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv; register I32 i = 0; @@ -3176,7 +3278,7 @@ PP(pp_unshift) PP(pp_reverse) { - djSP; dMARK; + dSP; dMARK; register SV *tmp; SV **oldsp = SP; @@ -3208,20 +3310,17 @@ PP(pp_reverse) U8* s = (U8*)SvPVX(TARG); U8* send = (U8*)(s + len); while (s < send) { - if (*s < 0x80) { + if (UTF8_IS_ASCII(*s)) { s++; continue; } else { + if (!utf8_to_uv_simple(s, 0)) + break; up = (char*)s; s += UTF8SKIP(s); down = (char*)(s - 1); - if (s > send || !((*down & 0xc0) == 0x80)) { - if (ckWARN_d(WARN_UTF8)) - Perl_warner(aTHX_ WARN_UTF8, - "Malformed UTF-8 character"); - break; - } + /* reverse this character */ while (down > up) { tmp = *up; *up++ = *down; @@ -3237,7 +3336,7 @@ PP(pp_reverse) *up++ = *down; *down-- = tmp; } - (void)SvPOK_only(TARG); + (void)SvPOK_only_UTF8(TARG); } SP = MARK + 1; SETTARG; @@ -3287,7 +3386,7 @@ S_mul128(pTHX_ SV *sv, U8 m) PP(pp_unpack) { - djSP; + dSP; dPOPPOPssrl; I32 start_sp_offset = SP - PL_stack_base; I32 gimme = GIMME_V; @@ -3305,9 +3404,9 @@ PP(pp_unpack) register char *str; /* These must not be in registers: */ - I16 ashort; + short ashort; int aint; - I32 along; + long along; #ifdef HAS_QUAD Quad_t aquad; #endif @@ -3603,7 +3702,9 @@ PP(pp_unpack) len = strend - s; if (checksum) { while (len-- > 0 && s < strend) { - auint = utf8_to_uv((U8*)s, &along); + STRLEN alen; + auint = utf8_to_uv((U8*)s, strend - s, &alen, 0); + along = alen; s += along; if (checksum > 32) cdouble += (NV)auint; @@ -3615,7 +3716,9 @@ PP(pp_unpack) EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0 && s < strend) { - auint = utf8_to_uv((U8*)s, &along); + STRLEN alen; + auint = utf8_to_uv((U8*)s, strend - s, &alen, 0); + along = alen; s += along; sv = NEWSV(37, 0); sv_setuv(sv, (UV)auint); @@ -3856,7 +3959,6 @@ PP(pp_unpack) if (checksum) { #if LONGSIZE != SIZE32 if (natint) { - long along; while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); @@ -3870,6 +3972,9 @@ PP(pp_unpack) #endif { while (len-- > 0) { +#if LONGSIZE > SIZE32 && INTSIZE == SIZE32 + I32 along; +#endif COPY32(s, &along); #if LONGSIZE > SIZE32 if (along > 2147483647) @@ -3888,7 +3993,6 @@ PP(pp_unpack) EXTEND_MORTAL(len); #if LONGSIZE != SIZE32 if (natint) { - long along; while (len-- > 0) { COPYNN(s, &along, sizeof(long)); s += sizeof(long); @@ -3901,6 +4005,9 @@ PP(pp_unpack) #endif { while (len-- > 0) { +#if LONGSIZE > SIZE32 && INTSIZE == SIZE32 + I32 along; +#endif COPY32(s, &along); #if LONGSIZE > SIZE32 if (along > 2147483647) @@ -4022,7 +4129,7 @@ PP(pp_unpack) while ((len > 0) && (s < strend)) { auv = (auv << 7) | (*s & 0x7f); - if (!(*s++ & 0x80)) { + if (UTF8_IS_ASCII(*s++)) { bytes = 0; sv = NEWSV(40, 0); sv_setuv(sv, auv); @@ -4034,7 +4141,7 @@ PP(pp_unpack) char *t; STRLEN n_a; - sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv); + sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv); while (s < strend) { sv = mul128(sv, *s & 0x7f); if (!(*s++ & 0x80)) { @@ -4366,11 +4473,12 @@ S_div128(pTHX_ SV *pnum, bool *done) PP(pp_pack) { - djSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; register SV *cat = TARG; register I32 items; STRLEN fromlen; register char *pat = SvPVx(*++MARK, fromlen); + char *patcopy; register char *patend = pat + fromlen; register I32 len; I32 datumtype; @@ -4401,6 +4509,7 @@ PP(pp_pack) items = SP - MARK; MARK++; sv_setpvn(cat, "", 0); + patcopy = pat; while (pat < patend) { SV *lengthcode = Nullsv; #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no) @@ -4408,8 +4517,12 @@ PP(pp_pack) #ifdef PERL_NATINT_PACK natint = 0; #endif - if (isSPACE(datumtype)) + if (isSPACE(datumtype)) { + patcopy++; continue; + } + if (datumtype == 'U' && pat == patcopy+1) + SvUTF8_on(cat); if (datumtype == '#') { while (pat < patend && *pat != '\n') pat++; @@ -4446,7 +4559,8 @@ PP(pp_pack) if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*') DIE(aTHX_ "/ must be followed by a*, A* or Z*"); lengthcode = sv_2mortal(newSViv(sv_len(items > 0 - ? *MARK : &PL_sv_no))); + ? *MARK : &PL_sv_no) + + (*pat == 'Z' ? 1 : 0))); } switch(datumtype) { default: @@ -4640,7 +4754,7 @@ PP(pp_pack) while (len-- > 0) { fromstr = NEXTFROM; auint = SvUV(fromstr); - SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN); + SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1); SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint) - SvPVX(cat)); } @@ -4744,10 +4858,14 @@ PP(pp_pack) DIE(aTHX_ "Cannot compress negative numbers"); if ( -#ifdef CXUX_BROKEN_CONSTANT_CONVERT - adouble <= UV_MAX_cxux +#if UVSIZE > 4 && UVSIZE >= NVSIZE + adouble <= 0xffffffff #else +# ifdef CXUX_BROKEN_CONSTANT_CONVERT + adouble <= UV_MAX_cxux +# else adouble <= UV_MAX +# endif #endif ) { @@ -4790,8 +4908,9 @@ PP(pp_pack) do { double next = floor(adouble / 128); *--in = (unsigned char)(adouble - (next * 128)) | 0x80; - if (--in < buf) /* this cannot happen ;-) */ + if (in <= buf) /* this cannot happen ;-) */ DIE(aTHX_ "Cannot compress integer"); + in--; adouble = next; } while (adouble > 0); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ @@ -4948,19 +5067,21 @@ PP(pp_pack) PP(pp_split) { - djSP; dTARG; + dSP; dTARG; AV *ary; - register I32 limit = POPi; /* note, negative is forever */ + register IV limit = POPi; /* note, negative is forever */ SV *sv = POPs; STRLEN len; register char *s = SvPV(sv, len); + bool do_utf8 = DO_UTF8(sv); char *strend = s + len; register PMOP *pm; register REGEXP *rx; register SV *dstr; register char *m; I32 iters = 0; - I32 maxiters = (strend - s) + 10; + STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s); + I32 maxiters = slen + 10; I32 i; char *orig; I32 origlimit = limit; @@ -4978,7 +5099,7 @@ PP(pp_split) pm = (PMOP*)POPs; #endif if (!pm || !s) - DIE(aTHX_ "panic: do_split"); + DIE(aTHX_ "panic: pp_split"); rx = pm->op_pmregexp; TAINT_IF((pm->op_pmflags & PMf_LOCALE) && @@ -5054,6 +5175,8 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); s = m + 1; @@ -5074,6 +5197,8 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); s = m; } @@ -5083,11 +5208,11 @@ PP(pp_split) && !(rx->reganch & ROPT_ANCH)) { int tail = (rx->reganch & RE_INTUIT_TAIL); SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx); - char c; len = rx->minlen; - if (len == 1 && !tail) { - c = *SvPV(csv,len); + if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) { + STRLEN n_a; + char c = *SvPV(csv, n_a); while (--limit) { /*SUPPRESS 530*/ for (m = s; m < strend && *m != c; m++) ; @@ -5097,8 +5222,15 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); - s = m + 1; + /* The rx->minlen is in characters but we want to step + * s ahead by bytes. */ + if (do_utf8) + s = (char*)utf8_hop((U8*)m, len); + else + s = m + len; /* Fake \n at the end */ } } else { @@ -5112,13 +5244,20 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); - s = m + len; /* Fake \n at the end */ + /* The rx->minlen is in characters but we want to step + * s ahead by bytes. */ + if (do_utf8) + s = (char*)utf8_hop((U8*)m, len); + else + s = m + len; /* Fake \n at the end */ } } } else { - maxiters += (strend - s) * rx->nparens; + maxiters += slen * rx->nparens; while (s < strend && --limit /* && (!rx->check_substr || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend, @@ -5139,6 +5278,8 @@ PP(pp_split) sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); if (rx->nparens) { for (i = 1; i <= rx->nparens; i++) { @@ -5152,6 +5293,8 @@ PP(pp_split) dstr = NEWSV(33, 0); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); } } @@ -5166,10 +5309,13 @@ PP(pp_split) /* keep field after final delim? */ if (s < strend || (iters && origlimit)) { - dstr = NEWSV(34, strend-s); - sv_setpvn(dstr, s, strend-s); + STRLEN l = strend - s; + dstr = NEWSV(34, l); + sv_setpvn(dstr, s, l); if (make_mortal) sv_2mortal(dstr); + if (do_utf8) + (void)SvUTF8_on(dstr); XPUSHs(dstr); iters++; } @@ -5226,7 +5372,6 @@ PP(pp_split) void Perl_unlock_condpair(pTHX_ void *svv) { - dTHR; MAGIC *mg = mg_find((SV*)svv, 'm'); if (!mg) @@ -5244,28 +5389,11 @@ Perl_unlock_condpair(pTHX_ void *svv) PP(pp_lock) { - djSP; + dSP; dTOPss; SV *retsv = sv; #ifdef USE_THREADS - MAGIC *mg; - - if (SvROK(sv)) - sv = SvRV(sv); - - mg = condpair_magic(sv); - MUTEX_LOCK(MgMUTEXP(mg)); - if (MgOWNER(mg) == thr) - MUTEX_UNLOCK(MgMUTEXP(mg)); - else { - while (MgOWNER(mg)) - COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); - MgOWNER(mg) = thr; - DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n", - PTR2UV(thr), PTR2UV(sv));) - MUTEX_UNLOCK(MgMUTEXP(mg)); - SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); - } + sv_lock(sv); #endif /* USE_THREADS */ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV || SvTYPE(retsv) == SVt_PVCV) { @@ -5278,7 +5406,7 @@ PP(pp_lock) PP(pp_threadsv) { #ifdef USE_THREADS - djSP; + dSP; EXTEND(SP, 1); if (PL_op->op_private & OPpLVAL_INTRO) PUSHs(*save_threadsv(PL_op->op_targ)); diff --git a/contrib/perl5/utils/h2ph.PL b/contrib/perl5/utils/h2ph.PL index 7b15ed1..6f012dc 100644 --- a/contrib/perl5/utils/h2ph.PL +++ b/contrib/perl5/utils/h2ph.PL @@ -37,13 +37,16 @@ $Config{startperl} print OUT <<'!NO!SUBS!'; +use strict; + use Config; use File::Path qw(mkpath); use Getopt::Std; getopts('Dd:rlhaQ'); +use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q); die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a); -@inc_dirs = inc_dirs() if $opt_a; +my @inc_dirs = inc_dirs() if $opt_a; my $Exit = 0; @@ -51,7 +54,7 @@ my $Dest_dir = $opt_d || $Config{installarchlib}; die "Destination directory $Dest_dir doesn't exist or isn't a directory\n" unless -d $Dest_dir; -@isatype = split(' ',<<END); +my @isatype = split(' ',<<END); char uchar u_char short ushort u_short int uint u_int @@ -59,14 +62,18 @@ die "Destination directory $Dest_dir doesn't exist or isn't a directory\n" FILE key_t caddr_t END +my %isatype; @isatype{@isatype} = (1) x @isatype; -$inif = 0; +my $inif = 0; +my %Is_converted; @ARGV = ('-') unless @ARGV; build_preamble_if_necessary(); -while (defined ($file = next_file())) { +my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile); +my ($incl, $next); +while (defined (my $file = next_file())) { if (-l $file and -d $file) { link_if_possible($file) if ($opt_l); next; @@ -130,7 +137,7 @@ while (defined ($file = next_file())) { my $proto = '() '; if ($args ne '') { $proto = ''; - foreach $arg (split(/,\s*/,$args)) { + foreach my $arg (split(/,\s*/,$args)) { $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/; $curargs{$arg} = 1; } @@ -258,11 +265,11 @@ while (defined ($file = next_file())) { s@/\*.*?\*/@@g; s/\s+/ /g; /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/; - ($enum_subs = $3) =~ s/\s//g; - @enum_subs = split(/,/, $enum_subs); - $enum_val = -1; - for $enum (@enum_subs) { - ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/; + (my $enum_subs = $3) =~ s/\s//g; + my @enum_subs = split(/,/, $enum_subs); + my $enum_val = -1; + foreach my $enum (@enum_subs) { + my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/; $enum_value =~ s/^=//; $enum_val = (length($enum_value) ? $enum_value : $enum_val + 1); if ($opt_h) { @@ -281,12 +288,13 @@ while (defined ($file = next_file())) { } print OUT "1;\n"; - $is_converted{$file} = 1; + $Is_converted{$file} = 1; queue_includes_from($file) if ($opt_a); } exit $Exit; + sub reindent($) { my($text) = shift; $text =~ s/\n/\n /g; @@ -294,9 +302,11 @@ sub reindent($) { $text; } + sub expr { + my $joined_args; if(keys(%curargs)) { - my($joined_args) = join('|', keys(%curargs)); + $joined_args = join('|', keys(%curargs)); } while ($_ ne '') { s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator @@ -348,7 +358,7 @@ sub expr { }; # struct/union member, including arrays: s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do { - $id = $1; + my $id = $1; $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g; $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args); while($id =~ /\[\s*([^\$\&\d\]]+)\]/) { @@ -364,7 +374,7 @@ sub expr { $new .= " (\$$id)"; }; s/^([_a-zA-Z]\w*)// && do { - $id = $1; + my $id = $1; if ($id eq 'struct') { s/^\s+(\w+)//; $id .= ' ' . $1; @@ -506,7 +516,7 @@ sub queue_includes_from } if ($line =~ /^#\s*include\s+<(.*?)>/) { - push(@ARGV, $1) unless $is_converted{$1}; + push(@ARGV, $1) unless $Is_converted{$1}; } } close HEADER; @@ -576,7 +586,8 @@ sub build_preamble_if_necessary sub _extract_cc_defines { my %define; - my $allsymbols = join " ", @Config{ccsymbols, cppsymbols, cppccsymbols}; + my $allsymbols = join " ", + @Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'}; # Split compiler pre-definitions into `key=value' pairs: foreach (split /\s+/, $allsymbols) { @@ -709,8 +720,6 @@ that it can translate. It's only intended as a rough tool. You may need to dicker with the files produced. -Doesn't run with C<use strict> - You have to run this program by hand; it's not run as part of the Perl installation. diff --git a/contrib/perl5/utils/perlbug.PL b/contrib/perl5/utils/perlbug.PL index c792b7a..8a4a8dc 100644 --- a/contrib/perl5/utils/perlbug.PL +++ b/contrib/perl5/utils/perlbug.PL @@ -46,7 +46,7 @@ while (<PATCH_LEVEL>) { my $patch_desc = "'" . join("',\n '", @patches) . "'"; my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches; -close PATCH_LEVEL; +close(PATCH_LEVEL) or die "Error closing patchlevel.h: $!"; # TO DO (prehaps): store/embed $Config::config_sh into perlbug. When perlbug is # used, compare $Config::config_sh with the stored version. If they differ then @@ -92,7 +92,7 @@ BEGIN { $::HaveUtil = ($@ eq ""); }; -my $Version = "1.28"; +my $Version = "1.33"; # Changed in 1.06 to skip Mail::Send and Mail::Util if not available. # Changed in 1.07 to see more sendmail execs, and added pipe output. @@ -125,6 +125,11 @@ my $Version = "1.28"; # Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15 # Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27 # Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000 +# Changed in 1.29 Perlbug(tron): auto(-ok), short prompts RFOLEY 05-05-2000 +# Changed in 1.30 Added warnings on failure to open files MSTEVENS 13-07-2000 +# Changed in 1.31 Add checks on close().Fix my $var unless. TJENNESS 26-07-2000 +# Changed in 1.32 Use File::Spec->tmpdir TJENNESS 20-08-2000 +# Changed in 1.33 Don't require -t STDOUT for -ok. # TODO: - Allow the user to re-name the file on mail failure, and # make sure failure (transmission-wise) of Mail::Send is @@ -132,7 +137,7 @@ my $Version = "1.28"; # - Test -b option my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename, - $subject, $from, $verbose, $ed, $outfile, $Is_MacOS, $category, $severity, + $subject, $from, $verbose, $ed, $outfile, $Is_MacOS, $category, $severity, $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok); my $perl_version = $^V ? sprintf("v%vd", $^V) : $]; @@ -150,7 +155,6 @@ include a file, you can use the -f switch. EOF die "\n"; } -if (!-t STDOUT && !$outfile) { Dump(*STDOUT); exit; } Query(); Edit() unless $usefile || ($ok and not $::opt_n); @@ -159,30 +163,45 @@ Send(); exit; -sub ask_for_alternatives { +sub ask_for_alternatives { # (category|severity) my $name = shift; - my $default = shift; - my @alts = @_; + my %alts = ( + 'category' => { + 'default' => 'core', + 'ok' => 'install', + 'opts' => [qw(core docs install library utilities)], # patch, notabug + }, + 'severity' => { + 'default' => 'low', + 'ok' => 'none', + 'opts' => [qw(critical high medium low wishlist none)], # zero + }, + ); + die "Invalid alternative($name) requested\n" unless grep(/^$name$/, keys %alts); my $alt = ""; - paraprint <<EOF; + if ($ok) { + $alt = $alts{$name}{'ok'}; + } else { + my @alts = @{$alts{$name}{'opts'}}; + paraprint <<EOF; Please pick a \u$name from the following: @alts EOF - my $err = 0; - my $joined_alts = join('|', @alts); - do { - if ($err++ > 5) { - die "Invalid $name: aborting.\n"; - } - print "Please enter a \u$name [$default]: "; - $alt = <>; - chomp $alt; - if ($alt =~ /^\s*$/) { - $alt = $default; - } - } while ($alt !~ /^($joined_alts)$/i); + my $err = 0; + do { + if ($err++ > 5) { + die "Invalid $name: aborting.\n"; + } + print "Please enter a \u$name [$alts{$name}{'default'}]: "; + $alt = <>; + chomp $alt; + if ($alt =~ /^\s*$/) { + $alt = $alts{$name}{'default'}; + } + } while !((($alt) = grep(/^$alt/i, @alts))); + } lc $alt; } @@ -197,7 +216,7 @@ sub Init { MacPerl::Ask('Provide command-line args here (-h for help):') if $Is_MacOS && $MacPerl::Version =~ /App/; - if (!getopts("dhva:s:b:f:F:r:e:SCc:to:n:")) { Help(); exit; }; + if (!getopts("Adhva:s:b:f:F:r:e:SCc:to:n:")) { Help(); exit; }; # This comment is needed to notify metaconfig that we are # using the $perladmin, $cf_by, and $cf_time definitions. @@ -205,7 +224,7 @@ sub Init { # -------- Configuration --------- # perlbug address - $perlbug = 'perlbug@perl.com'; + $perlbug = 'perlbug@perl.org'; # Test address $testaddress = 'perlbug-test@perl.com'; @@ -277,8 +296,6 @@ EOF $subject = ($::opt_n ? 'Not ' : '') . "OK: perl $perl_version ${patch_tags}on" ." $::Config{'archname'} $::Config{'osvers'} $subject"; - $category = "install"; - $severity = "none"; $ok = 1; } else { Help(); @@ -469,14 +486,10 @@ EOF } # Prompt for category of bug - $category ||= ask_for_alternatives("category", "core", - qw(core docs install - library utilities)); + $category ||= ask_for_alternatives('category'); # Prompt for severity of bug - $severity ||= ask_for_alternatives("severity", "low", - qw(critical high medium - low wishlist none)); + $severity ||= ask_for_alternatives('severity'); # Generate scratch file to edit report in $filename = filename(); @@ -510,7 +523,7 @@ EOF } # Generate report - open(REP,">$filename"); + open(REP,">$filename") or die "Unable to create report file `$filename': $!\n"; my $reptype = !$ok ? "bug" : $::opt_n ? "build failure" : "success"; print REP <<EOF; @@ -527,7 +540,7 @@ EOF while (<F>) { print REP $_ } - close(F); + close(F) or die "Error closing `$file': $!"; } else { print REP <<EOF; @@ -541,17 +554,17 @@ EOF EOF } Dump(*REP); - close(REP); + close(REP) or die "Error closing report file: $!"; # read in the report template once so that # we can track whether the user does any editing. # yes, *all* whitespace is ignored. - open(REP, "<$filename"); + open(REP, "<$filename") or die "Unable to open report file `$filename': $!\n"; while (<REP>) { s/\s+//g; $REP{$_}++; } - close(REP); + close(REP) or die "Error closing report file `$filename': $!"; } # sub Query sub Dump { @@ -562,6 +575,13 @@ sub Dump { Flags: category=$category severity=$severity +EFF + if ($::opt_A) { + print OUT <<EFF; + ack=no +EFF + } + print OUT <<EFF; --- EFF print OUT "This perlbug was built using Perl $config_tag1\n", @@ -631,7 +651,8 @@ EOF } tryagain: - my $sts = system("$ed $filename") unless $Is_MacOS; + my $sts; + $sts = system("$ed $filename") unless $Is_MacOS; if ($Is_MacOS) { require ExtUtils::MakeMaker; ExtUtils::MM_MacOS::launch_file($filename); @@ -665,7 +686,7 @@ EOF # Check that we have a report that has some, eh, report in it. my $unseen = 0; - open(REP, "<$filename"); + open(REP, "<$filename") or die "Couldn't open `$filename': $!\n"; # a strange way to check whether any significant editing # have been done: check whether any new non-empty lines # have been added. Yes, the below code ignores *any* space @@ -720,22 +741,22 @@ EOF print "\nError opening $file: $!\n\n"; goto retry; } - open(REP, "<$filename"); + open(REP, "<$filename") or die "Couldn't open file `$filename': $!\n"; print FILE "To: $address\nSubject: $subject\n"; print FILE "Cc: $cc\n" if $cc; print FILE "Reply-To: $from\n" if $from; print FILE "\n"; while (<REP>) { print FILE } - close(REP); - close(FILE); + close(REP) or die "Error closing report file `$filename': $!"; + close(FILE) or die "Error closing $file: $!"; print "\nMessage saved in `$file'.\n"; exit; } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow # Display the message - open(REP, "<$filename"); + open(REP, "<$filename") or die "Couldn't open file `$filename': $!\n"; while (<REP>) { print $_ } - close(REP); + close(REP) or die "Error closing report file `$filename': $!"; } elsif ($action =~ /^se/i) { # <S>end # Send the message print "Are you certain you want to send this message?\n" @@ -756,7 +777,7 @@ EOF Edit(); } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit Cancel(); - } elsif ($action =~ /^s/) { + } elsif ($action =~ /^s/i) { paraprint <<EOF; I'm sorry, but I didn't understand that. Please type "send" or "save". EOF @@ -777,9 +798,9 @@ sub Send { $msg->add("Reply-To",$from) if $from; $fh = $msg->open; - open(REP, "<$filename"); + open(REP, "<$filename") or die "Couldn't open `$filename': $!\n"; while (<REP>) { print $fh $_ } - close(REP); + close(REP) or die "Error closing $filename: $!"; $fh->close; print "\nMessage sent.\n"; @@ -824,16 +845,16 @@ report. We apologize for the inconvenience. So you may attempt to find some way of sending your message, it has been left in the file `$filename'. EOF - open(SENDMAIL, "|$sendmail -t") || die "'|$sendmail -t' failed: $!"; + open(SENDMAIL, "|$sendmail -t -oi") || die "'|$sendmail -t -oi' failed: $!"; sendout: print SENDMAIL "To: $address\n"; print SENDMAIL "Subject: $subject\n"; print SENDMAIL "Cc: $cc\n" if $cc; print SENDMAIL "Reply-To: $from\n" if $from; print SENDMAIL "\n\n"; - open(REP, "<$filename"); + open(REP, "<$filename") or die "Couldn't open `$filename': $!\n"; while (<REP>) { print SENDMAIL $_ } - close(REP); + close(REP) or die "Error closing $filename: $!"; if (close(SENDMAIL)) { printf "\nMessage %s.\n", $outfile ? "saved" : "sent"; @@ -854,7 +875,7 @@ be needed. Usage: $0 [-v] [-a address] [-s subject] [-b body | -f inpufile ] [ -F outputfile ] [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h] -$0 [-v] [-r returnaddress] [-ok | -okay | -nok | -nokay] +$0 [-v] [-r returnaddress] [-A] [-ok | -okay | -nok | -nokay] Simplest usage: run "$0", and follow the prompts. @@ -876,9 +897,9 @@ Options: this if you don't give it here. -e Editor to use. -t Test mode. The target address defaults to `$testaddress'. - -d Data mode (the default if you redirect or pipe output.) - This prints out your configuration data, without mailing + -d Data mode. This prints out your configuration data, without mailing anything. You can use this with -v to get more complete data. + -A Don't send a bug received acknowledgement to the return address. -ok Report successful build on this system to perl porters (use alone or with -v). Only use -ok if *everything* was ok: if there were *any* problems at all, use -nok. @@ -893,12 +914,8 @@ EOF } sub filename { - my $dir = $Is_VMS ? 'sys$scratch:' - : ($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'} - : $Is_MacOS ? $ENV{'TMPDIR'} - : '/tmp'; + my $dir = File::Spec->tmpdir(); $filename = "bugrep0$$"; -# $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|; $filename++ while -e File::Spec->catfile($dir, $filename); $filename = File::Spec->catfile($dir, $filename); } @@ -930,10 +947,10 @@ B<perlbug> S<[ B<-v> ]> S<[ B<-a> I<address> ]> S<[ B<-s> I<subject> ]> S<[ B<-b> I<body> | B<-f> I<inputfile> ]> S<[ B<-F> I<outputfile> ]> S<[ B<-r> I<returnaddress> ]> S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]> -S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-h> ]> +S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-A> ]> S<[ B<-h> ]> B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]> -S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]> + S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]> =head1 DESCRIPTION @@ -951,7 +968,7 @@ will be needed. Simply run it, and follow the prompts. If you are unable to run B<perlbug> (most likely because you don't have a working setup to send mail that perlbug recognizes), you may have to -compose your own report, and email it to B<perlbug@perl.com>. You might +compose your own report, and email it to B<perlbug@perl.org>. You might find the B<-d> option useful to get summary information in that case. In any case, when reporting a bug, please make sure you have run through @@ -1029,7 +1046,7 @@ definitely be fixed. Use the C<diff> program to generate your patches (C<diff> is being maintained by the GNU folks as part of the B<diffutils> package, so you should be able to get it from any of the GNU software repositories). If you do submit a patch, the cool-dude counter at -perlbug@perl.com will register you as a savior of the world. Your +perlbug@perl.org will register you as a savior of the world. Your patch may be returned with requests for changes, or requests for more detailed explanations about your fix. @@ -1049,7 +1066,7 @@ B<perlbug> will, amongst other things, ensure your report includes crucial information about your version of perl. If C<perlbug> is unable to mail your report after you have typed it in, you may have to compose the message yourself, add the output produced by C<perlbug -d> and email -it to B<perlbug@perl.com>. If, for some reason, you cannot run +it to B<perlbug@perl.org>. If, for some reason, you cannot run C<perlbug> at all on your system, be sure to include the entire output produced by running C<perl -V> (note the uppercase V). @@ -1076,7 +1093,14 @@ version of perl comes out and your bug is still present. =item B<-a> -Address to send the report to. Defaults to `perlbug@perl.com'. +Address to send the report to. Defaults to `perlbug@perl.org'. + +=item B<-A> + +Don't send a bug received acknowledgement to the reply address. +Generally it is only a sensible to use this option if you are a +perl maintainer actively watching perl porters for your message to +arrive. =item B<-b> |