summaryrefslogtreecommitdiffstats
path: root/contrib/perl5
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/perl5')
-rwxr-xr-xcontrib/perl5/configpm101
-rw-r--r--contrib/perl5/ext/IPC/SysV/Makefile.PL4
-rw-r--r--contrib/perl5/ext/POSIX/Makefile.PL8
-rw-r--r--contrib/perl5/ext/POSIX/POSIX.xs147
-rw-r--r--contrib/perl5/hints/freebsd.sh8
-rw-r--r--contrib/perl5/lib/Cwd.pm123
-rw-r--r--contrib/perl5/lib/ExtUtils/Install.pm139
-rw-r--r--contrib/perl5/lib/ExtUtils/Liblist.pm87
-rw-r--r--contrib/perl5/lib/ExtUtils/MM_Unix.pm144
-rw-r--r--contrib/perl5/lib/ExtUtils/MakeMaker.pm165
-rw-r--r--contrib/perl5/lib/Sys/Hostname.pm6
-rw-r--r--contrib/perl5/patchlevel.h4
-rw-r--r--contrib/perl5/perl.c549
-rw-r--r--contrib/perl5/perl.h306
-rw-r--r--contrib/perl5/pp.c685
-rw-r--r--contrib/perl5/utils/h2ph.PL50
-rw-r--r--contrib/perl5/utils/perlbug.PL153
-rw-r--r--contrib/perl5/utils/splain.PL7
18 files changed, 963 insertions, 1723 deletions
diff --git a/contrib/perl5/configpm b/contrib/perl5/configpm
index 31b416b..6429a58 100755
--- a/contrib/perl5/configpm
+++ b/contrib/perl5/configpm
@@ -1,4 +1,5 @@
#!./miniperl -w
+# $FreeBSD$
my $config_pm = $ARGV[0] || 'lib/Config.pm';
my $glossary = $ARGV[1] || 'Porting/Glossary';
@@ -17,7 +18,7 @@ my $glossary = $ARGV[1] || 'Porting/Glossary';
open CONFIG, ">$config_pm" or die "Can't open $config_pm: $!\n";
-$myver = sprintf "v%vd", $^V;
+$myver = "v5.6.0"; # XXX - Yuck - allow bootstrapping. MarkM
print CONFIG <<'ENDOFBEG_NOQ', <<"ENDOFBEG";
package Config;
@@ -128,84 +129,41 @@ sub FETCH {
# Search for it in the big string
my($value, $start, $marker, $quote_type);
-
+ $marker = "$_[1]=";
$quote_type = "'";
- # 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);
+ # 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);
+
# 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 '"';
- # So we can say "if $Config{'foo'}".
- $value = undef if $value eq 'undef';
+ $value = undef if $value eq 'undef'; # So we can say "if $Config{'foo'}".
$_[0]->{$_[1]} = $value; # cache it
return $value;
}
@@ -234,8 +192,7 @@ 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]=\"" or
- $_[1] =~ /^(?:(?:cc|ld)flags|libs(?:wanted)?)_nolargefiles$/;
+ substr($config_sh, 0, length($_[1])+2) eq "$_[1]=\"";
}
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 f994950..a4de7a9 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.3 1997/03/04 09:21:12 gbarr Exp $
+# $Id: Makefile.PL,v 1.1.1.2 1999/05/02 14:20:37 markm Exp $
require 5.002;
use ExtUtils::MakeMaker;
@@ -31,7 +31,7 @@ WriteMakefile(
'clean' => {FILES => join(" ",
map { "$_ */$_ */*/$_" }
- qw(*% *.html *.b[ac]k *.old))
+ qw(*% *.html *.b[ac]k *.old *.orig))
},
'macro' => { INSTALLDIRS => 'perl' },
);
diff --git a/contrib/perl5/ext/POSIX/Makefile.PL b/contrib/perl5/ext/POSIX/Makefile.PL
index 73bb02d..c035d75 100644
--- a/contrib/perl5/ext/POSIX/Makefile.PL
+++ b/contrib/perl5/ext/POSIX/Makefile.PL
@@ -1,8 +1,14 @@
+# $FreeBSD$
use ExtUtils::MakeMaker;
use Config;
my @libs;
if ($^O ne 'MSWin32') {
- @libs = ('LIBS' => ["-lm -lposix -lcposix"]);
+ if ($Config{archname} =~ /RM\d\d\d-svr4/) {
+ @libs = ('LIBS' => ["-lm -lc -lposix -lcposix"]);
+ }
+ else {
+ @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 7ffd494..1dd4ae3 100644
--- a/contrib/perl5/ext/POSIX/POSIX.xs
+++ b/contrib/perl5/ext/POSIX/POSIX.xs
@@ -1,3 +1,4 @@
+/* $FreeBSD$ */
#ifdef WIN32
#define _POSIX_
#endif
@@ -55,9 +56,6 @@
#ifdef I_UNISTD
#include <unistd.h>
#endif
-#ifdef MACOS_TRADITIONAL
-#undef fdopen
-#endif
#include <fcntl.h>
#if defined(__VMS) && !defined(__POSIX_SOURCE)
@@ -83,7 +81,7 @@
/* The non-POSIX CRTL times() has void return type, so we just get the
current time directly */
- clock_t vms_times(struct tms *bufptr) {
+ clock_t vms_times(struct tms *PL_bufptr) {
dTHX;
clock_t retval;
/* Get wall time and convert to 10 ms intervals to
@@ -104,7 +102,7 @@
_ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder));
# endif
/* Fill in the struct tms using the CRTL routine . . .*/
- times((tbuffer_t *)bufptr);
+ times((tbuffer_t *)PL_bufptr);
return (clock_t) retval;
}
# define times(t) vms_times(t)
@@ -142,12 +140,10 @@
# 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
-# if defined(OS2) || defined(MACOS_TRADITIONAL)
+# ifdef OS2
# define mkfifo(a,b) not_here("mkfifo")
# else /* !( defined OS2 ) */
# ifndef mkfifo
@@ -156,17 +152,12 @@
# endif
# endif /* !HAS_MKFIFO */
-# 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>
+# include <grp.h>
+# include <sys/times.h>
+# ifdef HAS_UNAME
+# include <sys/utsname.h>
# endif
+# include <sys/wait.h>
# ifdef I_UTIME
# include <utime.h>
# endif
@@ -539,12 +530,12 @@ mini_mktime(struct tm *ptm)
}
#ifdef HAS_LONG_DOUBLE
-# if LONG_DOUBLESIZE > NVSIZE
+# if LONG_DOUBLESIZE > DOUBLESIZE
# 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
@@ -564,7 +555,11 @@ not_here(char *s)
}
static
-NV
+#if defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE)
+long double
+#else
+double
+#endif
constant(char *name, int arg)
{
errno = 0;
@@ -1523,11 +1518,6 @@ 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
@@ -2302,9 +2292,9 @@ constant(char *name, int arg)
#else
goto not_there;
#endif
- if (strEQ(name, "STDERR_FILENO"))
-#ifdef STDERR_FILENO
- return STDERR_FILENO;
+ if (strEQ(name, "STRERR_FILENO"))
+#ifdef STRERR_FILENO
+ return STRERR_FILENO;
#else
goto not_there;
#endif
@@ -3016,7 +3006,7 @@ setcc(termios_ref, ccix, cc)
MODULE = POSIX PACKAGE = POSIX
-NV
+double
constant(name,arg)
char * name
int arg
@@ -3172,7 +3162,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,
@@ -3305,73 +3295,73 @@ setlocale(category, locale = 0)
RETVAL
-NV
+double
acos(x)
- NV x
+ double x
-NV
+double
asin(x)
- NV x
+ double x
-NV
+double
atan(x)
- NV x
+ double x
-NV
+double
ceil(x)
- NV x
+ double x
-NV
+double
cosh(x)
- NV x
+ double x
-NV
+double
floor(x)
- NV x
+ double x
-NV
+double
fmod(x,y)
- NV x
- NV y
+ double x
+ double y
void
frexp(x)
- NV x
+ double x
PPCODE:
int expvar;
/* (We already know stack is long enough.) */
PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar))));
PUSHs(sv_2mortal(newSViv(expvar)));
-NV
+double
ldexp(x,exp)
- NV x
+ double x
int exp
-NV
+double
log10(x)
- NV x
+ double x
void
modf(x)
- NV x
+ double x
PPCODE:
- NV intvar;
+ double intvar;
/* (We already know stack is long enough.) */
- PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar))));
+ PUSHs(sv_2mortal(newSVnv(modf(x,&intvar))));
PUSHs(sv_2mortal(newSVnv(intvar)));
-NV
+double
sinh(x)
- NV x
+ double x
-NV
+double
tan(x)
- NV x
+ double x
-NV
+double
tanh(x)
- NV x
+ double x
SysRet
sigaction(sig, action, oldaction = 0)
@@ -3417,8 +3407,9 @@ sigaction(sig, action, oldaction = 0)
/* Set up any desired mask. */
svp = hv_fetch(action, "MASK", 4, FALSE);
if (svp && sv_isa(*svp, "POSIX::SigSet")) {
- IV tmp = SvIV((SV*)SvRV(*svp));
- sigset = INT2PTR(sigset_t*, tmp);
+ unsigned long tmp;
+ tmp = (unsigned long)SvNV((SV*)SvRV(*svp));
+ sigset = (sigset_t*) tmp;
act.sa_mask = *sigset;
}
else
@@ -3443,8 +3434,9 @@ sigaction(sig, action, oldaction = 0)
/* Get back the mask. */
svp = hv_fetch(oldaction, "MASK", 4, TRUE);
if (sv_isa(*svp, "POSIX::SigSet")) {
- IV tmp = SvIV((SV*)SvRV(*svp));
- sigset = INT2PTR(sigset_t*, tmp);
+ unsigned long tmp;
+ tmp = (unsigned long)SvNV((SV*)SvRV(*svp));
+ sigset = (sigset_t*) tmp;
}
else {
New(0, sigset, 1, sigset_t);
@@ -3515,7 +3507,7 @@ SysRet
nice(incr)
int incr
-void
+int
pipe()
PPCODE:
int fds[2];
@@ -3558,7 +3550,7 @@ tcsetpgrp(fd, pgrp_id)
int fd
pid_t pgrp_id
-void
+int
uname()
PPCODE:
#ifdef HAS_UNAME
@@ -3692,7 +3684,7 @@ strtoul(str, base = 0)
PUSHs(&PL_sv_undef);
}
-void
+SV *
strxfrm(src)
SV * src
CODE:
@@ -3827,10 +3819,7 @@ mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0)
OUTPUT:
RETVAL
-#XXX: if $xsubpp::WantOptimize is always the default
-# sv_setpv(TARG, ...) could be used rather than
-# ST(0) = sv_2mortal(newSVpv(...))
-void
+char *
strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
char * fmt
int sec
@@ -3847,6 +3836,11 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
char tmpbuf[128];
struct tm mytm;
int len;
+#ifdef __FreeBSD__
+ long sgmtoff;
+ int sisdst;
+ char *szone;
+#endif
init_tm(&mytm); /* XXX workaround - see init_tm() above */
mytm.tm_sec = sec;
mytm.tm_min = min;
@@ -3857,7 +3851,18 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
mytm.tm_wday = wday;
mytm.tm_yday = yday;
mytm.tm_isdst = isdst;
+#ifdef __FreeBSD__
+ sgmtoff = mytm.tm_gmtoff;
+ sisdst = mytm.tm_isdst;
+ szone = mytm.tm_zone;
+ /* to prevent mess with shifted hours/days/etc. */
+ (void) timegm(&mytm);
+ mytm.tm_gmtoff = sgmtoff;
+ mytm.tm_isdst = sisdst;
+ mytm.tm_zone = szone;
+#else
mini_mktime(&mytm);
+#endif
len = strftime(tmpbuf, sizeof tmpbuf, fmt, &mytm);
/*
** The following is needed to handle to the situation where
diff --git a/contrib/perl5/hints/freebsd.sh b/contrib/perl5/hints/freebsd.sh
index 8eb6ac4..734409a 100644
--- a/contrib/perl5/hints/freebsd.sh
+++ b/contrib/perl5/hints/freebsd.sh
@@ -1,3 +1,4 @@
+# $FreeBSD$
# Original based on info from
# Carl M. Fongheiser <cmf@ins.infonet.net>
# Date: Thu, 28 Jul 1994 19:17:05 -0500 (CDT)
@@ -86,6 +87,8 @@ 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 / /'`
@@ -177,7 +180,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.org otherwise.
+Feel free to tell perlbug@perl.com otherwise.
EOM
exit 1
;;
@@ -187,8 +190,7 @@ EOM
POSIX threads are not supported well by FreeBSD $osvers.
Please consider upgrading to at least FreeBSD 2.2.8,
-or preferably to the most recent -RELEASE or -STABLE
-version (see http://www.freebsd.org/releases/).
+or preferably to 3.something.
(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 9c7b33d..9c078c6 100644
--- a/contrib/perl5/lib/Cwd.pm
+++ b/contrib/perl5/lib/Cwd.pm
@@ -1,9 +1,10 @@
+# $FreeBSD$
package Cwd;
require 5.000;
=head1 NAME
-Cwd - get pathname of current working directory
+getcwd - get pathname of current working directory
=head1 SYNOPSIS
@@ -14,9 +15,6 @@ Cwd - get pathname of current working directory
$dir = getcwd;
use Cwd;
- $dir = fastcwd;
-
- use Cwd;
$dir = fastgetcwd;
use Cwd 'chdir';
@@ -31,21 +29,16 @@ Cwd - 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
@@ -56,17 +49,16 @@ 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 fastgetcwd() function is provided as a synonym for cwd().
+The fast_abs_path() function looks the same as abs_path(), but runs faster.
+And like fastcwd() is more dangerous.
-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().
+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 fast_abs_path() function looks the same as abs_path() but runs
-faster and, like fastcwd(), is more dangerous.
+It is recommended that cwd (or another *cwd() function) is used in
+I<all> code to ensure portability.
If you ask to override your chdir() built-in function, then your PWD
environment variable will be kept up to date. (See
@@ -75,42 +67,31 @@ kept up to date if all packages which use chdir import it from Cwd.
=cut
-use strict;
+## use strict;
use Carp;
-our $VERSION = '2.04';
+$VERSION = '2.02';
-use base qw/ Exporter /;
-our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
-our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
+@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 = `pwd`;
- # `pwd` may fail e.g. if the disk is full
- chomp($cwd) if defined $cwd;
+ my $cwd;
+ chop($cwd = `/bin/pwd`);
$cwd;
}
# Since some ports may predefine cwd internally (e.g., NT)
# we take care not to override an existing definition for 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;
- }
-}
+*cwd = \&_backtick_pwd unless defined &cwd;
-# set a reasonable (and very safe) default for fastgetcwd, in case it
-# isn't redefined later (20001212 rspier)
-*fastgetcwd = \&cwd;
# By Brandon S. Allbery
#
@@ -176,7 +157,7 @@ sub fastcwd {
my $chdir_init = 0;
sub chdir_init {
- if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
+ if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos') {
my($dd,$di) = stat('.');
my($pd,$pi) = stat($ENV{'PWD'});
if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
@@ -184,12 +165,10 @@ sub chdir_init {
}
}
else {
- my $wd = cwd();
- $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
- $ENV{'PWD'} = $wd;
+ $ENV{'PWD'} = cwd();
}
# Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
- if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
+ if ($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) {
@@ -200,27 +179,11 @@ sub chdir_init {
}
sub chdir {
- my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
- $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
+ my $newdir = shift || ''; # allow for no arg (chdir to HOME dir)
+ $newdir =~ s|///*|/|g;
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'}
- }
- elsif ($^O eq 'MacOS') {
- return $ENV{'PWD'} = cwd();
- }
- elsif ($^O eq 'MSWin32') {
- $ENV{'PWD'} = $newpwd;
- return 1;
- }
+ if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
if ($newdir =~ m#^/#s) {
$ENV{'PWD'} = $newdir;
@@ -301,7 +264,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:$!";
@@ -370,17 +333,12 @@ 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
@@ -429,19 +387,6 @@ sub _epoc_cwd {
*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 c496aa0..aa6c764 100644
--- a/contrib/perl5/lib/ExtUtils/Install.pm
+++ b/contrib/perl5/lib/ExtUtils/Install.pm
@@ -1,9 +1,11 @@
+# $FreeBSD$
package ExtUtils::Install;
use 5.005_64;
our(@ISA, @EXPORT, $VERSION);
$VERSION = substr q$Revision: 1.28 $, 10;
# $Date: 1998/01/25 07:08:24 $
+# $FreeBSD$
use Exporter;
use Carp ();
@@ -16,28 +18,6 @@ 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;
@@ -77,9 +57,8 @@ sub install {
opendir DIR, $source_dir_or_file or next;
for (readdir DIR) {
next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
- my $targetdir = install_rooted_dir($hash{$source_dir_or_file});
- if (-w $targetdir ||
- mkpath($targetdir)) {
+ if (-w $hash{$source_dir_or_file} ||
+ mkpath($hash{$source_dir_or_file})) {
last;
} else {
warn "Warning: You do not have permissions to " .
@@ -89,8 +68,7 @@ sub install {
}
closedir DIR;
}
- my $tmpfile = install_rooted_file($pack{"read"});
- $packlist->read($tmpfile) if (-f $tmpfile);
+ $packlist->read($pack{"read"}) if (-f $pack{"read"});
my $cwd = cwd();
my($source);
@@ -101,16 +79,17 @@ sub install {
#install locations. AFS users may call this a bug. We'll have
#to reconsider how to add the means to satisfy AFS users also.
+ # FreeBSD also doesn't like this (much). At install time, the
+ # ctime should change, even if the file does not.
+
#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 = install_rooted_dir($hash{$source});
-
+ my $targetroot = $hash{$source};
if ($source eq "blib/lib" and
exists $hash{"blib/arch"} and
directory_not_empty("blib/arch")) {
- $targetroot = install_rooted_dir($hash{"blib/arch"});
+ $targetroot = $hash{"blib/arch"};
print "Files found in blib/arch: installing files in blib/lib into architecture dependent library tree\n";
}
chdir($source) or next;
@@ -119,9 +98,8 @@ sub install {
$atime,$mtime,$ctime,$blksize,$blocks) = stat;
return unless -f _;
return if $_ eq ".exists";
- my $targetdir = MY->catdir($targetroot, $File::Find::dir);
- my $origfile = $_;
- my $targetfile = MY->catfile($targetdir, $_);
+ my $targetdir = MY->catdir($targetroot,$File::Find::dir);
+ my $targetfile = MY->catfile($targetdir,$_);
my $diff = 0;
if ( -f $targetfile && -s _ == $size) {
@@ -131,6 +109,8 @@ sub install {
print "$_ differs\n" if $verbose>1;
$diff++;
}
+ my $diff = 1; # Nasty, lowdown, rotten, scumsucking
+ # hack to make FreeBSD _really_ install.
if ($diff){
if (-f $targetfile){
@@ -156,16 +136,16 @@ sub install {
} else {
inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
}
- $packlist->{$origfile}++;
+ $packlist->{$targetfile}++;
}, ".");
chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
}
if ($pack{'write'}) {
- $dir = install_rooted_dir(dirname($pack{'write'}));
+ $dir = dirname($pack{'write'});
mkpath($dir,0,0755);
print "Writing $pack{'write'}\n";
- $packlist->write(install_rooted_file($pack{'write'}));
+ $packlist->write($pack{'write'});
}
}
@@ -262,22 +242,8 @@ 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,$pm_filter) = @_;
+ my($fromto,$autodir) = @_;
use File::Basename qw(dirname);
use File::Copy qw(copy);
@@ -300,37 +266,23 @@ sub pm_to_blib {
mkpath($autodir,0,0755);
foreach (keys %$fromto) {
- 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->{$_} && -M $fromto->{$_} < -M $_;
+ unless (compare($_,$fromto->{$_})){
+ print "Skip $fromto->{$_} (unchanged)\n";
next;
}
- if (-f $dest){
- forceunlink($dest);
+ if (-f $fromto->{$_}){
+ forceunlink($fromto->{$_});
} else {
- 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";
+ mkpath(dirname($fromto->{$_}),0,0755);
}
+ copy($_,$fromto->{$_});
my($mode,$atime,$mtime) = (stat)[2,8,9];
- utime($atime,$mtime+$Is_VMS,$dest);
- chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$dest);
- next unless /\.pm$/;
- autosplit($dest,$autodir);
+ utime($atime,$mtime+$Is_VMS,$fromto->{$_});
+ chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_});
+ print "cp $_ $fromto->{$_}\n";
+ next unless /\.pm\z/;
+ autosplit($fromto->{$_},$autodir);
}
}
@@ -344,20 +296,18 @@ sub add {
}
sub DESTROY {
- 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";
+ 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";
}
1;
@@ -420,11 +370,6 @@ 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. 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).
+directory.
=cut
diff --git a/contrib/perl5/lib/ExtUtils/Liblist.pm b/contrib/perl5/lib/ExtUtils/Liblist.pm
index 5e2f91d..6da7395 100644
--- a/contrib/perl5/lib/ExtUtils/Liblist.pm
+++ b/contrib/perl5/lib/ExtUtils/Liblist.pm
@@ -1,30 +1,10 @@
+# $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.26 $, 10;
+our $VERSION = substr q$Revision: 1.25 $, 10;
use Config;
use Cwd 'cwd';
@@ -37,19 +17,19 @@ sub ext {
}
sub _unix_os2_ext {
- my($self,$potential_libs, $verbose, $give_libs) = @_;
- if ($^O =~ 'os2' and $Config{perllibs}) {
+ my($self,$potential_libs, $verbose) = @_;
+ if ($^O =~ 'os2' and $Config{libs}) {
# 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{perllibs};
+ $potential_libs .= $Config{libs};
}
- return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs;
+ return ("", "", "", "") unless $potential_libs;
warn "Potential libraries are '$potential_libs':\n" if $verbose;
my($so) = $Config{'so'};
- my($libs) = $Config{'perllibs'};
+ my($libs) = $Config{'libs'};
my $Config_libext = $Config{lib_ext} || ".a";
@@ -60,7 +40,6 @@ 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;
@@ -154,7 +133,6 @@ 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++;
@@ -202,29 +180,28 @@ sub _unix_os2_ext {
."No library found for -l$thislib\n"
unless $found_lib>0;
}
- return ('','','','', ($give_libs ? \@libs : ())) unless $found;
- ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path), ($give_libs ? \@libs : ()));
+ return ('','','','') unless $found;
+ ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path));
}
sub _win32_ext {
require Text::ParseWords;
- my($self, $potential_libs, $verbose, $give_libs) = @_;
+ my($self, $potential_libs, $verbose) = @_;
# If user did not supply a list, we punt.
# (caller should probably use the list in $Config{libs})
- return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs;
+ return ("", "", "", "") 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{'perllibs'};
+ my $libs = $Config{'libs'};
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
@@ -254,10 +231,6 @@ 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 = $_;
@@ -322,7 +295,6 @@ sub _win32_ext {
$found++;
$found_lib++;
push(@extralibs, $fullname);
- push @libs, $fullname unless $libs_seen{$fullname}++;
last;
}
@@ -344,11 +316,10 @@ sub _win32_ext {
}
- return ('','','','', ($give_libs ? \@libs : ())) unless $found;
+ return ('','','','') 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)
@@ -357,18 +328,18 @@ sub _win32_ext {
$lib =~ s,/,\\,g;
warn "Result: $lib\n" if $verbose;
- wantarray ? ($lib, '', $lib, '', ($give_libs ? \@libs : ())) : $lib;
+ wantarray ? ($lib, '', $lib, '') : $lib;
}
sub _vms_ext {
- my($self, $potential_libs,$verbose,$give_libs) = @_;
+ my($self, $potential_libs,$verbose) = @_;
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{'perllibs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'});
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
@@ -391,7 +362,7 @@ sub _vms_ext {
unless ($potential_libs) {
warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose;
- return ('', '', $crtlstr, '', ($give_libs ? [] : ()));
+ return ('', '', $crtlstr, '');
}
my(@dirs,@libs,$dir,$lib,%found,@fndlibs,$ldlib);
@@ -400,7 +371,6 @@ 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',
@@ -505,7 +475,6 @@ 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;
}
}
@@ -520,7 +489,7 @@ sub _vms_ext {
$ldlib = $crtlstr ? "$lib $crtlstr" : $lib;
warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose;
- wantarray ? ($lib, '', $ldlib, '', ($give_libs ? \@flibs : ())) : $lib;
+ wantarray ? ($lib, '', $ldlib, '') : $lib;
}
1;
@@ -535,22 +504,20 @@ ExtUtils::Liblist - determine libraries to use and how to use them
C<require ExtUtils::Liblist;>
-C<ExtUtils::Liblist::ext($self, $potential_libs, $verbose, $need_names);>
+C<ExtUtils::Liblist::ext($self, $potential_libs, $verbose);>
=head1 DESCRIPTION
This utility takes a list of libraries in the form C<-llib1 -llib2
--llib3> and returns lines suitable for inclusion in an extension
+-llib3> and prints out 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 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.
+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.
Dependent libraries can be linked in one of three ways:
@@ -658,7 +625,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{perllibs}> (see Config.pm)
+Otherwise, the libraries specified by C<$Config{libs}> (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>.
@@ -702,7 +669,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{perllibs}> (this should be only needed very rarely).
+libraries found in C<$Config{libs}> (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
@@ -712,7 +679,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{perllibs}>.
+enable searching for default libraries specified by C<$Config{libs}>.
=item *
diff --git a/contrib/perl5/lib/ExtUtils/MM_Unix.pm b/contrib/perl5/lib/ExtUtils/MM_Unix.pm
index c11333d..891c533 100644
--- a/contrib/perl5/lib/ExtUtils/MM_Unix.pm
+++ b/contrib/perl5/lib/ExtUtils/MM_Unix.pm
@@ -1,3 +1,4 @@
+# $FreeBSD$
package ExtUtils::MM_Unix;
use Exporter ();
@@ -208,7 +209,6 @@ 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 +306,8 @@ sub cflags {
$libperl ||= $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ;
$libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/;
- @cflags{qw(cc ccflags optimize shellflags)}
- = @Config{qw(cc ccflags optimize shellflags)};
+ @cflags{qw(cc ccflags optimize large split shellflags)}
+ = @Config{qw(cc ccflags optimize large split shellflags)};
my($optdebug) = "";
$cflags{shellflags} ||= '';
@@ -342,12 +342,16 @@ 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){
@@ -365,7 +369,7 @@ sub cflags {
$cflags{optimize} = $optdebug;
}
- for (qw(ccflags optimize perltype)) {
+ for (qw(ccflags optimize perltype large split)) {
$cflags{$_} =~ s/^\s+//;
$cflags{$_} =~ s/\s+/ /g;
$cflags{$_} =~ s/\s+$//;
@@ -408,6 +412,8 @@ sub cflags {
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
+LARGE = $self->{LARGE}
+SPLIT = $self->{SPLIT}
MPOLLUTE = $pollute
};
@@ -452,7 +458,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
]);
@@ -478,7 +484,7 @@ sub const_cccmd {
return '' unless $self->needs_linking();
return $self->{CONST_CCCMD} =
q{CCCMD = $(CC) -c $(INC) $(CCFLAGS) $(OPTIMIZE) \\
- $(PERLTYPE) $(MPOLLUTE) $(DEFINE_VERSION) \\
+ $(PERLTYPE) $(LARGE) $(SPLIT) $(MPOLLUTE) $(DEFINE_VERSION) \\
$(XS_DEFINE_VERSION)};
}
@@ -581,7 +587,7 @@ MM_VERSION = $ExtUtils::MakeMaker::VERSION
for $tmp (qw/
FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT
- LDFROM LINKTYPE PM_FILTER
+ LDFROM LINKTYPE
/ ) {
next unless defined $self->{$tmp};
push @m, "$tmp = $self->{$tmp}\n";
@@ -675,10 +681,6 @@ 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{
@@ -811,7 +813,7 @@ DIST_DEFAULT = $dist_default
=item dist_basics (o)
-Defines the targets distclean, distcheck, skipcheck, manifest, veryclean.
+Defines the targets distclean, distcheck, skipcheck, manifest.
=cut
@@ -839,11 +841,6 @@ manifest :
$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=mkmanifest \\
-e mkmanifest
};
-
- push @m, q{
-veryclean : realclean
- $(RM_F) *~ *.orig */*~ */*.orig
-};
join "", @m;
}
@@ -1066,7 +1063,7 @@ ARMAYBE = '.$armaybe.'
OTHERLDFLAGS = '.$otherldflags.'
INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
-$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP)
+$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
');
if ($armaybe ne ':'){
$ldfrom = 'tmp$(LIB_EXT)';
@@ -1075,20 +1072,18 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists
}
$ldfrom = "-all $ldfrom -none" if ($^O eq 'dec_osf');
- # 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});
+ # 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');
- # 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) $@
-');
+ # The IRIX linker also doesn't use LD_RUN_PATH
+ $ldrun = qq{-rpath "$self->{LD_RUN_PATH}"}
+ if ($^O eq 'irix' && $self->{LD_RUN_PATH});
- 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,' $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom.
+ ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)');
push @m, '
$(CHMOD) $(PERM_RWX) $@
';
@@ -1153,9 +1148,9 @@ in these dirs:
@$dirs
";
}
- foreach $name (@$names){
- foreach $dir (@$dirs){
- next unless defined $dir; # $self->{PERL_SRC} may be undefined
+ foreach $dir (@$dirs){
+ next unless defined $dir; # $self->{PERL_SRC} may be undefined
+ foreach $name (@$names){
my ($abs, $val);
if ($self->file_name_is_absolute($name)) { # /foo/bar
$abs = $name;
@@ -1255,6 +1250,11 @@ 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,15 +1262,7 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
print FIXOUT $shb, <FIXIN>;
close FIXIN;
close FIXOUT;
-
- # 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;
-
+ # can't rename open files on some DOSISH platforms
unless ( rename($file, "$file.bak") ) {
warn "Can't rename $file to $file.bak: $!";
next;
@@ -1285,7 +1277,6 @@ 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 ':';;
@@ -1362,7 +1353,7 @@ sub htmlifypods {
if (defined $self->{PERL_SRC}) {
$pod2html_exe = $self->catfile($self->{PERL_SRC},'pod','pod2html');
} else {
- $pod2html_exe = $self->catfile($Config{scriptdirexp},'pod2html');
+ $pod2html_exe = $self->catfile($Config{bin},'pod2html');
}
unless ($pod2html_exe = $self->perl_script($pod2html_exe)) {
# No pod2html but some HTMLxxxPODS to be installed
@@ -1663,7 +1654,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()),$self->catdir($self->updir(),$self->updir(),$self->updir(),$self->updir())){
+ foreach $dir ($self->updir(),$self->catdir($self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir())){
if (
-f $self->catfile($dir,"config.sh")
&&
@@ -1846,11 +1837,12 @@ usually solves this kind of problem.
# of /prefix/{lib,man}
$replace_prefix = qq[\$\(PREFIX\)];
+ $search_prefix = $self->catdir($configure_prefix,"local");
for $install_variable (qw/
INSTALLBIN
INSTALLSCRIPT
/) {
- $self->prefixify($install_variable,$configure_prefix,$replace_prefix);
+ $self->prefixify($install_variable,$search_prefix,$replace_prefix);
}
my $funkylibdir = $self->catdir($configure_prefix,"lib","perl5");
$funkylibdir = '' unless -d $funkylibdir;
@@ -2377,7 +2369,7 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
# The front matter of the linkcommand...
$linkcmd = join ' ', "\$(CC)",
- grep($_, @Config{qw(ldflags ccdlflags)});
+ grep($_, @Config{qw(large split ldflags ccdlflags)});
$linkcmd =~ s/\s+/ /g;
$linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,;
@@ -2460,7 +2452,7 @@ MAP_PERLINC = @{$perlinc || []}
MAP_STATIC = ",
join(" \\\n\t", reverse sort keys %static), "
-MAP_PRELIBS = $Config::Config{perllibs} $Config::Config{cryptlib}
+MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
";
if (defined $libperl) {
@@ -2468,7 +2460,6 @@ MAP_PRELIBS = $Config::Config{perllibs} $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}";
@@ -2506,9 +2497,14 @@ 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'
@@ -2612,7 +2608,7 @@ sub manifypods {
if (defined $self->{PERL_SRC}) {
$pod2man_exe = $self->catfile($self->{PERL_SRC},'pod','pod2man');
} else {
- $pod2man_exe = $self->catfile($Config{scriptdirexp},'pod2man');
+ $pod2man_exe = $self->catfile($Config{bin},'pod2man');
}
unless ($pod2man_exe = $self->perl_script($pod2man_exe)) {
# Maybe a build by uninstalled Perl?
@@ -3044,7 +3040,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{','$(PM_FILTER)')"
+ -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{')"
}.$self->{NOECHO}.q{$(TOUCH) $@
};
}
@@ -3116,7 +3112,6 @@ 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
@@ -3156,22 +3151,8 @@ realclean purge :: clean
push(@m, " $self->{RM_F} \$(INST_DYNAMIC) \$(INST_BOOT)\n");
push(@m, " $self->{RM_F} \$(INST_STATIC)\n");
}
- # 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;
- }
+ push(@m, " $self->{RM_F} " . join(" ", values %{$self->{PM}}) . "\n")
+ if keys %{$self->{PM}};
my(@otherfiles) = ($self->{MAKEFILE},
"$self->{MAKEFILE}.old"); # Makefiles last
push(@otherfiles, $attribs{FILES}) if $attribs{FILES};
@@ -3190,11 +3171,9 @@ 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;
- } elsif ($Is_Dos) {
- $man =~ s,/+,__,g;
+ $man =~ s,/+,.,g;
} else {
- $man =~ s,/+,::,g;
+ $man =~ s,/+,::,g;
}
$man;
}
@@ -3513,13 +3492,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=0
+VERBINST=1
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<", $$arg=shift, "|", $$arg, ">";' \
+-e 'print "=head2 ", scalar(localtime), ": C<", shift, ">", " L<", shift, ">";' \
-e 'print "=over 4";' \
-e 'while (defined($$key = shift) and defined($$val = shift)){print "=item *";print "C<$$key: $$val>";}' \
-e 'print "=back";'
@@ -3814,21 +3793,6 @@ 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 8bf76c7..b29dcf6 100644
--- a/contrib/perl5/lib/ExtUtils/MakeMaker.pm
+++ b/contrib/perl5/lib/ExtUtils/MakeMaker.pm
@@ -1,3 +1,5 @@
+# $FreeBSD$
+
BEGIN {require 5.002;} # MakeMaker 5.17 was the last MakeMaker that was compatible with perl5.001m
package ExtUtils::MakeMaker;
@@ -44,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::Kid ExtUtils::MakeMaker];
+@MM::ISA = qw[ExtUtils::MM_Unix ExtUtils::Liblist ExtUtils::MakeMaker];
#
# Setup dummy package:
@@ -60,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::Kid;
+package ExtUtils::Liblist;
package ExtUtils::MakeMaker;
#
@@ -82,7 +84,7 @@ if ($Is_OS2) {
require ExtUtils::MM_OS2;
}
if ($Is_Mac) {
- require ExtUtils::MM_MacOS;
+ require ExtUtils::MM_Mac;
}
if ($Is_Win32) {
require ExtUtils::MM_Win32;
@@ -189,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 HTMLSCRIPTPODS IMPORTS
+ HTMLLIBPODS HTMLSCRIPTPOD IMPORTS
INC INCLUDE_EXT INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLHTMLPRIVLIBDIR
INSTALLHTMLSCRIPTDIR INSTALLHTMLSITELIBDIR INSTALLMAN1DIR
INSTALLMAN3DIR INSTALLPRIVLIB INSTALLSCRIPT INSTALLSITEARCH
@@ -200,14 +202,10 @@ 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 PM_FILTER PMLIBDIRS POLLUTE PPM_INSTALL_EXEC
- PPM_INSTALL_SCRIPT PREFIX
+ PL_FILES PM 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
@@ -243,6 +241,7 @@ 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[
@@ -286,7 +285,7 @@ sub full_setup {
INST_BIN 1 INST_EXE 1 INST_LIB 1 INST_ARCHLIB 1 INST_SCRIPT 1
MAP_TARGET 1 INST_HTMLLIBDIR 1 INST_HTMLSCRIPTDIR 1
- INST_MAN1DIR 1 INST_MAN3DIR 1 PERL_SRC 1 PERL 1 FULLPERL 1
+ INST_MAN1DIR 1 INST_MAN3DIR 1 PERL_SRC 1
);
@@ -985,39 +984,23 @@ be
perl Makefile.PL LIB=~/lib
This will install the module's architecture-independent files into
-~/lib, the architecture-dependent files into ~/lib/$archname.
+~/lib, the architecture-dependent files into ~/lib/$archname/auto.
Another way to specify many INSTALL directories with a single
parameter is PREFIX.
perl Makefile.PL PREFIX=~
-This will replace the string specified by C<$Config{prefix}> in all
-C<$Config{install*}> values.
+This will replace the string specified by $Config{prefix} in all
+$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:
-
-=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
+by perl by default, nor by make. Conflicts between parameters LIB,
+PREFIX and the various INSTALL* arguments are resolved so that
+XXX
If the user has superuser privileges, and is not working on AFS
-or relatives, then the defaults for
+(Andrew File System) or relatives, then the defaults for
INSTALLPRIVLIB, INSTALLARCHLIB, INSTALLSCRIPT, etc. will be appropriate,
and this incantation will be the best:
@@ -1164,6 +1147,11 @@ 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.
@@ -1174,11 +1162,6 @@ 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
@@ -1428,6 +1411,11 @@ 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
@@ -1436,11 +1424,6 @@ 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
@@ -1456,6 +1439,34 @@ 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
@@ -1464,12 +1475,8 @@ specify ld flags)
=item LIB
-LIB should only be set at C<perl Makefile.PL> time but is allowed as a
-MakeMaker argument. It has the effect of
+LIB can only be set at C<perl Makefile.PL> time. 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
@@ -1573,8 +1580,6 @@ 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
@@ -1591,40 +1596,12 @@ to $(CC).
=item PERL_ARCHLIB
-Same as below, but for architecture dependent files.
+Same as above 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
@@ -1673,31 +1650,6 @@ 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
@@ -1775,7 +1727,6 @@ 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:
@@ -1783,8 +1734,6 @@ 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
@@ -1839,8 +1788,6 @@ 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/lib/Sys/Hostname.pm b/contrib/perl5/lib/Sys/Hostname.pm
index 95f9a99..f8e9095 100644
--- a/contrib/perl5/lib/Sys/Hostname.pm
+++ b/contrib/perl5/lib/Sys/Hostname.pm
@@ -93,14 +93,20 @@ sub hostname {
# method 3 - trusty old hostname command
|| eval {
+ $pathstack = $ENV{'PATH'};
+ $ENV{'PATH'} = "/bin:/usr/bin";
local $SIG{__DIE__};
$host = `(hostname) 2>/dev/null`; # bsdish
+ $ENV{'PATH'} = $pathstack;
}
# method 4 - sysV uname command (may truncate)
|| eval {
+ $pathstack = $ENV{'PATH'};
+ $ENV{'PATH'} = "/bin:/usr/bin";
local $SIG{__DIE__};
$host = `uname -n 2>/dev/null`; ## sysVish
+ $ENV{'PATH'} = $pathstack;
}
# method 5 - Apollo pre-SR10
diff --git a/contrib/perl5/patchlevel.h b/contrib/perl5/patchlevel.h
index 6f98d1c..1d65002 100644
--- a/contrib/perl5/patchlevel.h
+++ b/contrib/perl5/patchlevel.h
@@ -2,10 +2,11 @@
/* do not adjust the whitespace! Configure expects the numbers to be
* exactly on the third column */
+/* $FreeBSD$ */
#define PERL_REVISION 5 /* age */
#define PERL_VERSION 6 /* epoch */
-#define PERL_SUBVERSION 1 /* generation */
+#define PERL_SUBVERSION 0 /* generation */
/* The following numbers describe the earliest compatible version of
Perl ("compatibility" here being defined as sufficient binary/API
@@ -70,6 +71,7 @@
#if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
static char *local_patches[] = {
NULL
+ ,"SUIDMAIL - fixes for suidperl security"
,NULL
};
diff --git a/contrib/perl5/perl.c b/contrib/perl5/perl.c
index 9596b6a..a84bf85 100644
--- a/contrib/perl5/perl.c
+++ b/contrib/perl5/perl.c
@@ -1,10 +1,11 @@
/* perl.c
*
- * Copyright (c) 1987-2001 Larry Wall
+ * Copyright (c) 1987-2000 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.
*
+ * $FreeBSD$
*/
/*
@@ -180,8 +181,6 @@ 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 */
@@ -274,15 +273,10 @@ 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;
}
@@ -298,7 +292,9 @@ 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;
@@ -375,7 +371,6 @@ 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 */
@@ -437,21 +432,6 @@ 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) {
@@ -576,7 +556,6 @@ 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 */
@@ -617,14 +596,9 @@ perl_destruct(pTHXx)
if (!specialWARN(PL_compiling.cop_warnings))
SvREFCNT_dec(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = Nullsv;
-#ifdef USE_ITHREADS
- Safefree(CopFILE(&PL_compiling));
- CopFILE(&PL_compiling) = Nullch;
- Safefree(CopSTASHPV(&PL_compiling));
-#else
+#ifndef USE_ITHREADS
SvREFCNT_dec(CopFILEGV(&PL_compiling));
- CopFILEGV(&PL_compiling) = Nullgv;
- /* cop_stash is not refcounted */
+ CopFILEGV_set(&PL_compiling, Nullgv);
#endif
/* Prepare to destruct main symbol table. */
@@ -658,13 +632,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 */
-
- /* the 2 is for PL_fdpid and PL_strtab */
- while (PL_sv_count > 2 && sv_clean_all())
- ;
-
+ while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
+ last_sv_count = PL_sv_count;
+ sv_clean_all();
+ }
SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
SvFLAGS(PL_fdpid) |= SVt_PVAV;
SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
@@ -674,10 +648,6 @@ 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,
@@ -709,11 +679,6 @@ 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;
@@ -732,6 +697,9 @@ 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)
@@ -739,9 +707,6 @@ 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 ? */
@@ -751,7 +716,6 @@ 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);
@@ -764,8 +728,6 @@ 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) {
@@ -833,6 +795,7 @@ 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;
@@ -855,7 +818,7 @@ setuid perl scripts securely.\n");
PL_origargv = argv;
PL_origargc = argc;
-#ifdef USE_ENVIRON_ARRAY
+#ifndef VMS /* VMS doesn't have environ array */
PL_origenviron = environ;
#endif
@@ -934,6 +897,7 @@ 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;
@@ -1001,11 +965,6 @@ 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) {
@@ -1176,7 +1135,6 @@ print \" \\@INC:\\n @INC\\n\";");
PL_tainting = TRUE;
else {
while (s && *s) {
- char *d;
while (isSPACE(*s))
s++;
if (*s == '-') {
@@ -1184,18 +1142,11 @@ 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);
- while (++s && *s) {
- if (isSPACE(*s)) {
- *s++ = '\0';
- break;
- }
- }
- moreswitches(d);
+ s = moreswitches(s);
}
}
}
@@ -1235,11 +1186,7 @@ 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);
@@ -1279,16 +1226,12 @@ 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__) || defined(EPOC)
+#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
init_os_extras();
#endif
#ifdef USE_SOCKS
-# ifdef HAS_SOCKS5_INIT
- socks5_init(argv[0]);
-# else
SOCKSinit(argv[0]);
-# endif
#endif
init_predump_symbols();
@@ -1304,16 +1247,6 @@ 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);
@@ -1322,7 +1255,6 @@ print \" \\@INC:\\n @INC\\n\";");
PL_origfilename);
}
}
-#endif
CopLINE_set(PL_curcop, 0);
PL_curstash = PL_defstash;
PL_preprocess = FALSE;
@@ -1368,6 +1300,7 @@ Tells a Perl interpreter to run. See L<perlembed>.
int
perl_run(pTHXx)
{
+ dTHR;
I32 oldscope;
int ret = 0;
dJMPENV;
@@ -1435,6 +1368,8 @@ 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"));
@@ -1445,11 +1380,7 @@ 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)
@@ -1493,8 +1424,10 @@ 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)
+ if (tmp != NOT_IN_PAD) {
+ dTHR;
return THREADSV(tmp);
+ }
}
#endif /* USE_THREADS */
gv = gv_fetchpv(name, create, SVt_PV);
@@ -1633,7 +1566,18 @@ Perl_call_method(pTHX_ const char *methname, I32 flags)
/* name of the subroutine */
/* See G_* flags in cop.h */
{
- return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
+ 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);
}
/* May be called with any of a CV, a GV, or an SV containing the name. */
@@ -1648,11 +1592,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;
@@ -1690,14 +1634,6 @@ 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);
@@ -1705,7 +1641,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
CATCH_SET(oldcatch);
}
else {
- myop.op_other = (OP*)&myop;
+ cLOGOP->op_other = PL_op;
PL_markstack_ptr--;
/* we're trying to emulate pp_entertry() here */
{
@@ -1715,7 +1651,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
ENTER;
SAVETMPS;
- push_return(Nullop);
+ push_return(PL_op->op_next);
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. */
@@ -1814,11 +1750,13 @@ 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); /* this doesn't do a POPMARK */
+ PL_op = Perl_pp_entereval(aTHX);
else
- PL_op = Perl_pp_entersub(aTHX); /* this does */
+ PL_op = Perl_pp_entersub(aTHX);
}
if (PL_op)
CALLRUNOPS(aTHX);
@@ -1940,6 +1878,7 @@ 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);
@@ -2000,7 +1939,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 CHECK blocks)",
+"-c check syntax only (runs BEGIN and END 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)",
@@ -2028,11 +1967,9 @@ NULL
};
char **p = usage_msg;
- PerlIO_printf(PerlIO_stdout(),
- "\nUsage: %s [switches] [--] [programfile] [arguments]",
- name);
+ printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
while (*p)
- PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
+ printf("\n %s", *p++);
}
/* This routine handles any switches that can be given during run */
@@ -2040,13 +1977,13 @@ NULL
char *
Perl_moreswitches(pTHX_ char *s)
{
- STRLEN numlen;
+ I32 numlen;
U32 rschar;
switch (*s) {
case '0':
{
- numlen = 0; /* disallow underscores */
+ dTHR;
rschar = (U32)scan_oct(s, 4, &numlen);
SvREFCNT_dec(PL_nrs);
if (rschar & ~((U8)~0))
@@ -2079,25 +2016,9 @@ Perl_moreswitches(pTHX_ char *s)
case 'd':
forbid_setid("-d");
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, "})");
- }
+ if (*s == ':' || *s == '=') {
+ my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
s += strlen(s);
- my_setenv("PERL5DB", SvPV(sv, PL_na));
}
if (!PL_perldb) {
PL_perldb = PERLDB_ALL;
@@ -2109,7 +2030,7 @@ Perl_moreswitches(pTHX_ char *s)
#ifdef DEBUGGING
forbid_setid("-D");
if (isALPHA(s[1])) {
- static char debopts[] = "psltocPmfrxuLHXDST";
+ static char debopts[] = "psltocPmfrxuLHXDS";
char *d;
for (s++; *s && (d = strchr(debopts,*s)); s++)
@@ -2121,6 +2042,7 @@ 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");
@@ -2177,11 +2099,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;
@@ -2214,9 +2136,6 @@ 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);
@@ -2249,9 +2168,6 @@ 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;
@@ -2260,81 +2176,59 @@ Perl_moreswitches(pTHX_ char *s)
s++;
return s;
case 'v':
- PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
- PL_patchlevel, ARCHNAME));
+ printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
+ PL_patchlevel, ARCHNAME));
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
- 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" : "");
+ printf("\n(with %d registered patch%s, see perl -V for more detail)",
+ (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
#endif
- 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
+ printf("\n\nCopyright 1987-2000, Larry Wall\n");
#ifdef MSDOS
- PerlIO_printf(PerlIO_stdout(),
- "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
+ printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
#endif
#ifdef DJGPP
- PerlIO_printf(PerlIO_stdout(),
- "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
- "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
+ printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
+ printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
#endif
#ifdef OS2
- 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");
+ 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");
#endif
#ifdef atarist
- PerlIO_printf(PerlIO_stdout(),
- "atariST series port, ++jrb bammi@cadence.com\n");
+ printf("atariST series port, ++jrb bammi@cadence.com\n");
#endif
#ifdef __BEOS__
- PerlIO_printf(PerlIO_stdout(),
- "BeOS port Copyright Tom Spindler, 1997-1999\n");
+ printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
#endif
#ifdef MPE
- PerlIO_printf(PerlIO_stdout(),
- "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
+ printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
#endif
#ifdef OEMVS
- PerlIO_printf(PerlIO_stdout(),
- "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
+ printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
#endif
#ifdef __VOS__
- PerlIO_printf(PerlIO_stdout(),
- "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
+ printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
#endif
#ifdef __OPEN_VM
- PerlIO_printf(PerlIO_stdout(),
- "VM/ESA port by Neale Ferguson, 1998-1999\n");
+ printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
#endif
#ifdef POSIX_BC
- PerlIO_printf(PerlIO_stdout(),
- "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
+ printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
#endif
#ifdef __MINT__
- PerlIO_printf(PerlIO_stdout(),
- "MiNT port by Guido Flohr, 1997-1999\n");
+ printf("MiNT port by Guido Flohr, 1997-1999\n");
#endif
#ifdef EPOC
- PerlIO_printf(PerlIO_stdout(),
- "EPOC port by Olaf Flebbe, 1999-2000\n");
+ printf("EPOC port by Olaf Flebbe, 1999-2000\n");
#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
#endif
- PerlIO_printf(PerlIO_stdout(),
- "\n\
+ printf("\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 source kit.\n\n\
+GNU General Public License, which may be found in the Perl 5.0 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");
@@ -2496,6 +2390,7 @@ 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
@@ -2531,7 +2426,6 @@ 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);
}
@@ -2539,6 +2433,8 @@ 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) {
@@ -2561,11 +2457,6 @@ 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 = "";
@@ -2588,7 +2479,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
sv_catpvn(sv, "-I", 2);
sv_catpv(sv,PRIVLIB_EXP);
-#if defined(MSDOS) || defined(WIN32)
+#ifdef MSDOS
Perl_sv_setpvf(aTHX_ cmd, "\
sed %s -e \"/^[^#]/b\" \
-e \"/^#[ ]*include[ ]/b\" \
@@ -2687,7 +2578,7 @@ sed %s -e \"/^[^#]/b\" \
PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION), PL_origargv);
- Perl_croak(aTHX_ "Can't do setuid\n");
+ Perl_croak(aTHX_ "Can't do setuid; ensure that the setuid bit is set on suidperl\n");
}
#endif
#endif
@@ -2718,85 +2609,72 @@ S_fd_on_nosuid_fs(pTHX_ int fd)
* an irrelevant filesystem while trying to reach the right one.
*/
-#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
+# ifdef HAS_FSTATVFS
struct statvfs stfs;
-
check_okay = fstatvfs(fd, &stfs) == 0;
on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
-# 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
+# else
+# ifdef PERL_MOUNT_NOSUID
+# if defined(HAS_FSTATFS) && \
+ defined(HAS_STRUCT_STATFS) && \
+ defined(HAS_STRUCT_STATFS_F_FLAGS)
struct statfs stfs;
-
check_okay = fstatfs(fd, &stfs) == 0;
on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
-# 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
+# else
+# if defined(HAS_FSTAT) && \
+ defined(HAS_USTAT) && \
+ defined(HAS_GETMNT) && \
+ defined(HAS_STRUCT_FS_DATA) && \
+ defined(NOSTAT_ONE)
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 */
-
-# 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;
+ 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;
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 */
+ fclose(mtab);
+# endif /* getmntent+hasmntopt */
+# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
+# endif /* statvfs */
if (!check_okay)
Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
@@ -2832,6 +2710,7 @@ 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 */
@@ -2941,7 +2820,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION), PL_origargv);
#endif
- Perl_croak(aTHX_ "Can't do setuid\n");
+ Perl_croak(aTHX_ "Can't do setuid; ensure that the setuid bit is set on suidperl\n");
}
if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
@@ -3024,11 +2903,12 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION), PL_origargv);/* try again */
- Perl_croak(aTHX_ "Can't do setuid\n");
+ Perl_croak(aTHX_ "Can't do setuid; ensure that the setuid bit is set on suidperl\n");
#endif /* IAMSUID */
#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)
||
@@ -3051,29 +2931,9 @@ 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;
@@ -3118,6 +2978,7 @@ S_forbid_setid(pTHX_ char *s)
void
Perl_init_debugger(pTHX)
{
+ dTHR;
HV *ostash = PL_curstash;
PL_curstash = PL_debstash;
@@ -3185,6 +3046,7 @@ 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) {
@@ -3221,6 +3083,7 @@ S_init_lexer(pTHX)
STATIC void
S_init_predump_symbols(pTHX)
{
+ dTHR;
GV *tmpgv;
IO *io;
@@ -3252,19 +3115,17 @@ S_init_predump_symbols(pTHX)
PL_statname = NEWSV(66,0); /* last filename we did stat on */
- if (PL_osname)
- Safefree(PL_osname);
- PL_osname = savepv(OSNAME);
+ if (!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) {
@@ -3293,17 +3154,12 @@ 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(aTHX));
+ sv_setpv(GvSV(tmpgv), os2_execname());
#else
sv_setpv(GvSV(tmpgv),PL_origargv[0]);
#endif
@@ -3315,15 +3171,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)
- (void)sv_utf8_decode(sv);
+ sv_utf8_upgrade(sv);
}
}
if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
HV *hv;
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
- hv_magic(hv, Nullgv, 'E');
-#ifdef USE_ENVIRON_ARRAY
+ hv_magic(hv, PL_envgv, 'E');
+#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have 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
@@ -3333,26 +3189,6 @@ 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;
@@ -3363,16 +3199,12 @@ 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
}
-#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 */
+#endif
#ifdef DYNAMIC_ENV_FETCH
HvNAME(hv) = savepv(ENV_HV_NAME);
#endif
@@ -3417,27 +3249,6 @@ 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
@@ -3487,26 +3298,17 @@ 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) || defined(EPOC)
+#if defined(DOSISH)
# define PERLLIB_SEP ';'
#else
# if defined(VMS)
# define PERLLIB_SEP '|'
# else
-# if defined(MACOS_TRADITIONAL)
-# define PERLLIB_SEP ','
-# else
-# define PERLLIB_SEP ':'
-# endif
+# define PERLLIB_SEP ':'
# endif
#endif
#ifndef PERLLIB_MANGLE
@@ -3546,12 +3348,6 @@ 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
@@ -3579,17 +3375,8 @@ 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_ARCH_FMT_PATH PERL_ARCH_FMT,
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s",
libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION, ARCHNAME);
@@ -3598,7 +3385,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_ARCH_FMT_PATH, libdir,
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
@@ -3606,7 +3393,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 PERL_ARCH_FMT, libdir, ARCHNAME);
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(PL_incgv), newSVsv(subdir));
@@ -3616,7 +3403,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 PERL_ARCH_FMT, libdir, *incver);
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(PL_incgv), newSVsv(subdir));
@@ -3681,9 +3468,8 @@ S_init_main_thread(pTHX)
PERL_SET_THX(thr);
/*
- * These must come after the thread self setting
- * because sv_setpvn does SvTAINT and the taint
- * fields thread selfness being set.
+ * These must come after the SET_THR because sv_setpvn does
+ * SvTAINT and the taint fields require dTHR.
*/
PL_toptarget = NEWSV(0,0);
sv_upgrade(PL_toptarget, SVt_PVFM);
@@ -3711,6 +3497,7 @@ 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;
@@ -3720,14 +3507,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
while (AvFILL(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
- 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);
- }
+ SAVEFREESV(cv);
#ifdef PERL_FLEXIBLE_EXCEPTIONS
CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
#else
@@ -3815,6 +3595,8 @@ 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) {
@@ -3863,6 +3645,7 @@ 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 1f187bd..1105563 100644
--- a/contrib/perl5/perl.h
+++ b/contrib/perl5/perl.h
@@ -1,10 +1,11 @@
/* perl.h
*
- * Copyright (c) 1987-2001, Larry Wall
+ * Copyright (c) 1987-2000, 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.
*
+ * $FreeBSD$
*/
#ifndef H_PERL
#define H_PERL 1
@@ -164,8 +165,8 @@ class CPerlObj;
#define aTHXo_ this,
#define PERL_OBJECT_THIS aTHXo
#define PERL_OBJECT_THIS_ aTHXo_
-#define dTHXoa(a) pTHXo = (CPerlObj*)a
-#define dTHXo pTHXo = PERL_GET_THX
+#define dTHXoa(a) pTHXo = a
+#define dTHXo dTHXoa(PERL_GET_THX)
#define pTHXx void
#define pTHXx_
@@ -179,17 +180,16 @@ class CPerlObj;
struct perl_thread;
# define pTHX register struct perl_thread *thr
# define aTHX thr
-# define dTHR dNOOP /* only backward compatibility */
-# define dTHXa(a) pTHX = (struct perl_thread*)a
+# define dTHR dNOOP
# else
# ifndef MULTIPLICITY
# define MULTIPLICITY
# endif
# define pTHX register PerlInterpreter *my_perl
# define aTHX my_perl
-# define dTHXa(a) pTHX = (PerlInterpreter*)a
# endif
-# define dTHX pTHX = PERL_GET_THX
+# define dTHXa(a) pTHX = a
+# define dTHX dTHXa(PERL_GET_THX)
# define pTHX_ pTHX,
# define aTHX_ aTHX,
# define pTHX_1 2
@@ -243,7 +243,6 @@ struct perl_thread;
# define aTHXo aTHX
# define aTHXo_ aTHX_
# define dTHXo dTHX
-# define dTHXoa(x) dTHXa(x)
#endif
#ifndef pTHXx
@@ -299,7 +298,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) WITH_THX(s)
+#define WITH_THR(s) STMT_START { dTHR; s; } STMT_END
/*
* SOFT_CAST can be used for args to prototyped functions to retain some
@@ -488,16 +487,21 @@ 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
@@ -544,6 +548,17 @@ 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
@@ -704,50 +719,10 @@ typedef struct perl_mstats perl_mstats_t;
#endif
#include <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 */
+#ifdef HAS_SOCKET
+# ifdef I_NET_ERRNO
+# include <net/errno.h>
# 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
@@ -1097,16 +1072,8 @@ 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
@@ -1187,22 +1154,16 @@ typedef NVTYPE NV;
# include <sunmath.h>
# endif
# define NV_DIG LDBL_DIG
-# 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
+# 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)))
# else
-# ifdef HUGE_VAL
-# define NV_MAX ((NV)HUGE_VAL)
-# endif
+# define Perl_modf modfl
+# define Perl_frexp frexpl
# endif
-# endif
-# ifdef HAS_SQRTL
# define Perl_cos cosl
# define Perl_sin sinl
# define Perl_sqrt sqrtl
@@ -1213,39 +1174,10 @@ 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
-# 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_modf modf
+# define Perl_frexp frexp
# define Perl_cos cos
# define Perl_sin sin
# define Perl_sqrt sqrt
@@ -1255,33 +1187,19 @@ 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) (NV)strtold(s, (char**)NULL)
+# define Perl_atof(s) strtold(s, (char**)NULL)
# endif
# if !defined(Perl_atof) && defined(HAS_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))
+# define Perl_atof atolf
# 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
@@ -1454,25 +1372,28 @@ typedef NVTYPE NV;
#ifdef UV_IS_QUAD
+# ifdef UQUAD_MAX
+# define PERL_UQUAD_MAX ((UV)UQUAD_MAX)
+# else
# define PERL_UQUAD_MAX (~(UV)0)
-# define PERL_UQUAD_MIN ((UV)0)
+# endif
+
+# define PERL_UQUAD_MIN ((UV)0)
+
+# ifdef QUAD_MAX
+# define PERL_QUAD_MAX ((IV)QUAD_MAX)
+# else
# 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;
@@ -1488,12 +1409,7 @@ typedef struct pvop PVOP;
typedef struct loop LOOP;
typedef struct interpreter PerlInterpreter;
-#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 sv SV;
typedef struct av AV;
typedef struct hv HV;
typedef struct cv CV;
@@ -1658,9 +1574,6 @@ 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
@@ -1669,18 +1582,7 @@ typedef struct ptr_tbl PTR_TBL_t;
# 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
+#endif
#ifndef PERL_SYS_INIT3
# define PERL_SYS_INIT3(argvp,argcp,envp) PERL_SYS_INIT(argvp,argcp)
@@ -1870,25 +1772,9 @@ 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 compiler. Sigh.
+ below to be rejected by the compmiler. Sigh.
*/
#ifdef HAS_PAUSE
#define Pause pause
@@ -2108,7 +1994,6 @@ 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())
@@ -2129,11 +2014,9 @@ 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) {PL_debug&=~128; a; PL_debug|=128;} } \
+ if (PERL_GET_INTERP) { dTHX; if (PL_debug & 128) { a; } } \
} STMT_END
# endif
#define DEBUG_f(a) if (PL_debug & 256) a
@@ -2149,7 +2032,6 @@ 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)
@@ -2170,7 +2052,6 @@ Gid_t getegid (void);
#define DEBUG_X(a)
#define DEBUG_D(a)
#define DEBUG_S(a)
-#define DEBUG_T(a)
#endif
#define YYMAXDEPTH 300
@@ -2241,12 +2122,8 @@ char *crypt (const char*, const char*);
# ifndef getenv
char *getenv (const char*);
# endif /* !getenv */
-# if !defined(HAS_LSEEK_PROTO) && !defined(EPOC) && !defined(__hpux)
-# ifdef _FILE_OFFSET_BITS
-# if _FILE_OFFSET_BITS == 64
+# if !defined(EPOC) && !(defined(__hpux) && defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS == 64) && !defined(HAS_LSEEK_PROTO)
Off_t lseek (int,Off_t,int);
-# endif
-# endif
# endif
# endif /* !DONT_DECLARE_STD */
char *getlogin (void);
@@ -2332,18 +2209,18 @@ typedef OP* (CPERLscope(*PPADDR_t)[]) (pTHX);
# define environ (*environ_pointer)
EXT char *** environ_pointer;
# else
-# if defined(__APPLE__) && defined(PERL_CORE)
+# if defined(__APPLE__)
# 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 */
-# ifdef USE_ENVIRON_ARRAY
+# if !defined(VMS)
# if !defined(DONT_DECLARE_STD) || \
(defined(__svr4__) && defined(__GNUC__) && defined(sun)) || \
defined(__sgi) || \
- defined(__DGUX)
+ defined(__DGUX) || defined(EPOC)
extern char ** environ; /* environment variables supplied via exec */
# endif
# endif
@@ -2708,6 +2585,10 @@ 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*);
@@ -2953,8 +2834,7 @@ 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),
- MEMBER_TO_FPTR(Perl_magic_regdatum_set), 0, 0, 0};
+EXT MGVTBL PL_vtbl_regdatum = {MEMBER_TO_FPTR(Perl_magic_regdatum_get), 0, 0, 0, 0};
#ifdef USE_LOCALE_COLLATE
EXT MGVTBL PL_vtbl_collxfrm = {0,
@@ -3182,29 +3062,23 @@ typedef struct am_table_short AMTS;
#ifdef USE_LOCALE_NUMERIC
#define SET_NUMERIC_STANDARD() \
- set_numeric_standard();
+ STMT_START { \
+ if (! PL_numeric_standard) \
+ set_numeric_standard(); \
+ } STMT_END
#define SET_NUMERIC_LOCAL() \
- set_numeric_local();
+ STMT_START { \
+ if (! PL_numeric_local) \
+ set_numeric_local(); \
+ } STMT_END
-#define IS_NUMERIC_RADIX(s) \
+#define IS_NUMERIC_RADIX(c) \
((PL_hints & HINT_LOCALE) && \
- 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();
+ PL_numeric_radix && (c) == PL_numeric_radix)
+#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 */
@@ -3212,8 +3086,6 @@ 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
@@ -3438,10 +3310,6 @@ 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"
@@ -3468,10 +3336,6 @@ 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 cc9a053..58fda0e 100644
--- a/contrib/perl5/pp.c
+++ b/contrib/perl5/pp.c
@@ -1,10 +1,11 @@
/* pp.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (c) 1991-2000, 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.
*
+ * $FreeBSD$
*/
/*
@@ -82,6 +83,10 @@ 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
@@ -92,7 +97,7 @@ extern Pid_t getpid (void);
PP(pp_stub)
{
- dSP;
+ djSP;
if (GIMME_V == G_SCALAR)
XPUSHs(&PL_sv_undef);
RETURN;
@@ -107,18 +112,13 @@ PP(pp_scalar)
PP(pp_padav)
{
- dSP; dTARGET;
+ djSP; 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 +146,7 @@ PP(pp_padav)
PP(pp_padhv)
{
- dSP; dTARGET;
+ djSP; dTARGET;
I32 gimme;
XPUSHs(TARG);
@@ -154,11 +154,6 @@ 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());
@@ -184,7 +179,7 @@ PP(pp_padany)
PP(pp_rv2gv)
{
- dSP; dTOPss;
+ djSP; dTOPss;
if (SvROK(sv)) {
wasref:
@@ -204,7 +199,7 @@ PP(pp_rv2gv)
else {
if (SvTYPE(sv) != SVt_PVGV) {
char *sym;
- STRLEN len;
+ STRLEN n_a;
if (SvGMAGICAL(sv)) {
mg_get(sv);
@@ -242,17 +237,13 @@ PP(pp_rv2gv)
report_uninit();
RETSETUNDEF;
}
- sym = SvPV(sv,len);
+ sym = SvPV(sv, n_a);
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
- if (!sv
- && (!is_gv_magical(sym,len,0)
- || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
- {
+ if (!sv)
RETSETUNDEF;
- }
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
@@ -269,7 +260,7 @@ PP(pp_rv2gv)
PP(pp_rv2sv)
{
- dSP; dTOPss;
+ djSP; dTOPss;
if (SvROK(sv)) {
wasref:
@@ -286,7 +277,7 @@ PP(pp_rv2sv)
else {
GV *gv = (GV*)sv;
char *sym;
- STRLEN len;
+ STRLEN n_a;
if (SvTYPE(gv) != SVt_PVGV) {
if (SvGMAGICAL(sv)) {
@@ -302,17 +293,13 @@ PP(pp_rv2sv)
report_uninit();
RETSETUNDEF;
}
- sym = SvPV(sv, len);
+ sym = SvPV(sv, n_a);
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
- if (!gv
- && (!is_gv_magical(sym,len,0)
- || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
- {
+ if (!gv)
RETSETUNDEF;
- }
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
@@ -334,7 +321,7 @@ PP(pp_rv2sv)
PP(pp_av2arylen)
{
- dSP;
+ djSP;
AV *av = (AV*)TOPs;
SV *sv = AvARYLEN(av);
if (!sv) {
@@ -348,9 +335,9 @@ PP(pp_av2arylen)
PP(pp_pos)
{
- dSP; dTARGET; dPOPss;
+ djSP; dTARGET; dPOPss;
- if (PL_op->op_flags & OPf_MOD || LVRET) {
+ if (PL_op->op_flags & OPf_MOD) {
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
sv_magic(TARG, Nullsv, '.', Nullch, 0);
@@ -384,7 +371,7 @@ PP(pp_pos)
PP(pp_rv2cv)
{
- dSP;
+ djSP;
GV *gv;
HV *stash;
@@ -394,12 +381,8 @@ PP(pp_rv2cv)
if (cv) {
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
- 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");
- }
+ if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
+ DIE(aTHX_ "Can't modify non-lvalue subroutine call");
}
else
cv = (CV*)&PL_sv_undef;
@@ -409,7 +392,7 @@ PP(pp_rv2cv)
PP(pp_prototype)
{
- dSP;
+ djSP;
CV *cv;
HV *stash;
GV *gv;
@@ -475,7 +458,7 @@ PP(pp_prototype)
PP(pp_anoncode)
{
- dSP;
+ djSP;
CV* cv = (CV*)PL_curpad[PL_op->op_targ];
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
@@ -486,14 +469,14 @@ PP(pp_anoncode)
PP(pp_srefgen)
{
- dSP;
+ djSP;
*SP = refto(*SP);
RETURN;
}
PP(pp_refgen)
{
- dSP; dMARK;
+ djSP; dMARK;
if (GIMME != G_ARRAY) {
if (++MARK <= SP)
*MARK = *SP;
@@ -543,7 +526,7 @@ S_refto(pTHX_ SV *sv)
PP(pp_ref)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *sv;
char *pv;
@@ -563,7 +546,7 @@ PP(pp_ref)
PP(pp_bless)
{
- dSP;
+ djSP;
HV *stash;
if (MAXARG == 1)
@@ -588,7 +571,7 @@ PP(pp_gelem)
SV *sv;
SV *tmpRef;
char *elem;
- dSP;
+ djSP;
STRLEN n_a;
sv = POPs;
@@ -649,7 +632,7 @@ PP(pp_gelem)
PP(pp_study)
{
- dSP; dPOPss;
+ djSP; dPOPss;
register unsigned char *s;
register I32 pos;
register I32 ch;
@@ -711,7 +694,7 @@ PP(pp_study)
PP(pp_trans)
{
- dSP; dTARG;
+ djSP; dTARG;
SV *sv;
if (PL_op->op_flags & OPf_STACKED)
@@ -729,7 +712,7 @@ PP(pp_trans)
PP(pp_schop)
{
- dSP; dTARGET;
+ djSP; dTARGET;
do_chop(TARG, TOPs);
SETTARG;
RETURN;
@@ -737,24 +720,23 @@ PP(pp_schop)
PP(pp_chop)
{
- dSP; dMARK; dTARGET; dORIGMARK;
- while (MARK < SP)
- do_chop(TARG, *++MARK);
- SP = ORIGMARK;
+ djSP; dMARK; dTARGET;
+ while (SP > MARK)
+ do_chop(TARG, POPs);
PUSHTARG;
RETURN;
}
PP(pp_schomp)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SETi(do_chomp(TOPs));
RETURN;
}
PP(pp_chomp)
{
- dSP; dMARK; dTARGET;
+ djSP; dMARK; dTARGET;
register I32 count = 0;
while (SP > MARK)
@@ -765,7 +747,7 @@ PP(pp_chomp)
PP(pp_defined)
{
- dSP;
+ djSP;
register SV* sv;
sv = POPs;
@@ -795,7 +777,7 @@ PP(pp_defined)
PP(pp_undef)
{
- dSP;
+ djSP;
SV *sv;
if (!PL_op->op_private) {
@@ -827,7 +809,7 @@ PP(pp_undef)
case SVt_PVFM:
{
/* let user-undef'd sub keep its identity */
- GV* gv = CvGV((CV*)sv);
+ GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
cv_undef((CV*)sv);
CvGV((CV*)sv) = gv;
}
@@ -862,7 +844,7 @@ PP(pp_undef)
PP(pp_predec)
{
- dSP;
+ djSP;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
DIE(aTHX_ PL_no_modify);
if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
@@ -879,7 +861,7 @@ PP(pp_predec)
PP(pp_postinc)
{
- dSP; dTARGET;
+ djSP; dTARGET;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
DIE(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
@@ -900,7 +882,7 @@ PP(pp_postinc)
PP(pp_postdec)
{
- dSP; dTARGET;
+ djSP; dTARGET;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
DIE(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
@@ -921,7 +903,7 @@ PP(pp_postdec)
PP(pp_pow)
{
- dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
{
dPOPTOPnnrl;
SETn( Perl_pow( left, right) );
@@ -931,7 +913,7 @@ PP(pp_pow)
PP(pp_multiply)
{
- dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
{
dPOPTOPnnrl;
SETn( left * right );
@@ -941,7 +923,7 @@ PP(pp_multiply)
PP(pp_divide)
{
- dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
dPOPPOPnnrl;
NV value;
@@ -970,7 +952,7 @@ PP(pp_divide)
PP(pp_modulo)
{
- dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
{
UV left;
UV right;
@@ -980,7 +962,7 @@ PP(pp_modulo)
NV dright;
NV dleft;
- if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
IV i = SvIVX(POPs);
right = (right_neg = (i < 0)) ? -i : i;
}
@@ -992,7 +974,7 @@ PP(pp_modulo)
dright = -dright;
}
- if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
+ if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
IV i = SvIVX(POPs);
left = (left_neg = (i < 0)) ? -i : i;
}
@@ -1070,9 +1052,9 @@ PP(pp_modulo)
PP(pp_repeat)
{
- dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
{
- register IV count = POPi;
+ register I32 count = POPi;
if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
dMARK;
I32 items = SP - MARK;
@@ -1095,13 +1077,12 @@ PP(pp_repeat)
SP -= items;
}
else { /* Note: mark already snarfed by pp_list */
- SV *tmpstr = POPs;
+ SV *tmpstr;
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);
@@ -1112,10 +1093,7 @@ PP(pp_repeat)
}
*SvEND(TARG) = '\0';
}
- if (isutf)
- (void)SvPOK_only_UTF8(TARG);
- else
- (void)SvPOK_only(TARG);
+ (void)SvPOK_only(TARG);
PUSHTARG;
}
RETURN;
@@ -1124,7 +1102,7 @@ PP(pp_repeat)
PP(pp_subtract)
{
- dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
{
dPOPTOPnnrl_ul;
SETn( left - right );
@@ -1134,7 +1112,7 @@ PP(pp_subtract)
PP(pp_left_shift)
{
- dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
{
IV shift = POPi;
if (PL_op->op_private & HINT_INTEGER) {
@@ -1151,7 +1129,7 @@ PP(pp_left_shift)
PP(pp_right_shift)
{
- dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
{
IV shift = POPi;
if (PL_op->op_private & HINT_INTEGER) {
@@ -1168,7 +1146,7 @@ PP(pp_right_shift)
PP(pp_lt)
{
- dSP; tryAMAGICbinSET(lt,0);
+ djSP; tryAMAGICbinSET(lt,0);
{
dPOPnv;
SETs(boolSV(TOPn < value));
@@ -1178,7 +1156,7 @@ PP(pp_lt)
PP(pp_gt)
{
- dSP; tryAMAGICbinSET(gt,0);
+ djSP; tryAMAGICbinSET(gt,0);
{
dPOPnv;
SETs(boolSV(TOPn > value));
@@ -1188,7 +1166,7 @@ PP(pp_gt)
PP(pp_le)
{
- dSP; tryAMAGICbinSET(le,0);
+ djSP; tryAMAGICbinSET(le,0);
{
dPOPnv;
SETs(boolSV(TOPn <= value));
@@ -1198,7 +1176,7 @@ PP(pp_le)
PP(pp_ge)
{
- dSP; tryAMAGICbinSET(ge,0);
+ djSP; tryAMAGICbinSET(ge,0);
{
dPOPnv;
SETs(boolSV(TOPn >= value));
@@ -1208,7 +1186,7 @@ PP(pp_ge)
PP(pp_ne)
{
- dSP; tryAMAGICbinSET(ne,0);
+ djSP; tryAMAGICbinSET(ne,0);
{
dPOPnv;
SETs(boolSV(TOPn != value));
@@ -1218,12 +1196,19 @@ PP(pp_ne)
PP(pp_ncmp)
{
- dSP; dTARGET; tryAMAGICbin(ncmp,0);
+ djSP; 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 Perl_isnan
+#ifdef __osf__ /* XXX fix in 5.6.1 --jhi */
if (Perl_isnan(left) || Perl_isnan(right)) {
SETs(&PL_sv_undef);
RETURN;
@@ -1248,7 +1233,7 @@ PP(pp_ncmp)
PP(pp_slt)
{
- dSP; tryAMAGICbinSET(slt,0);
+ djSP; tryAMAGICbinSET(slt,0);
{
dPOPTOPssrl;
int cmp = ((PL_op->op_private & OPpLOCALE)
@@ -1261,7 +1246,7 @@ PP(pp_slt)
PP(pp_sgt)
{
- dSP; tryAMAGICbinSET(sgt,0);
+ djSP; tryAMAGICbinSET(sgt,0);
{
dPOPTOPssrl;
int cmp = ((PL_op->op_private & OPpLOCALE)
@@ -1274,7 +1259,7 @@ PP(pp_sgt)
PP(pp_sle)
{
- dSP; tryAMAGICbinSET(sle,0);
+ djSP; tryAMAGICbinSET(sle,0);
{
dPOPTOPssrl;
int cmp = ((PL_op->op_private & OPpLOCALE)
@@ -1287,7 +1272,7 @@ PP(pp_sle)
PP(pp_sge)
{
- dSP; tryAMAGICbinSET(sge,0);
+ djSP; tryAMAGICbinSET(sge,0);
{
dPOPTOPssrl;
int cmp = ((PL_op->op_private & OPpLOCALE)
@@ -1300,7 +1285,7 @@ PP(pp_sge)
PP(pp_seq)
{
- dSP; tryAMAGICbinSET(seq,0);
+ djSP; tryAMAGICbinSET(seq,0);
{
dPOPTOPssrl;
SETs(boolSV(sv_eq(left, right)));
@@ -1310,7 +1295,7 @@ PP(pp_seq)
PP(pp_sne)
{
- dSP; tryAMAGICbinSET(sne,0);
+ djSP; tryAMAGICbinSET(sne,0);
{
dPOPTOPssrl;
SETs(boolSV(!sv_eq(left, right)));
@@ -1320,7 +1305,7 @@ PP(pp_sne)
PP(pp_scmp)
{
- dSP; dTARGET; tryAMAGICbin(scmp,0);
+ djSP; dTARGET; tryAMAGICbin(scmp,0);
{
dPOPTOPssrl;
int cmp = ((PL_op->op_private & OPpLOCALE)
@@ -1333,7 +1318,7 @@ PP(pp_scmp)
PP(pp_bit_and)
{
- dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
@@ -1356,7 +1341,7 @@ PP(pp_bit_and)
PP(pp_bit_xor)
{
- dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
@@ -1379,7 +1364,7 @@ PP(pp_bit_xor)
PP(pp_bit_or)
{
- dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
@@ -1402,7 +1387,7 @@ PP(pp_bit_or)
PP(pp_negate)
{
- dSP; dTARGET; tryAMAGICun(neg);
+ djSP; dTARGET; tryAMAGICun(neg);
{
dTOPss;
if (SvGMAGICAL(sv))
@@ -1436,7 +1421,7 @@ PP(pp_negate)
sv_setsv(TARG, sv);
*SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
}
- else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
+ else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
sv_setpvn(TARG, "-", 1);
sv_catsv(TARG, sv);
}
@@ -1452,14 +1437,14 @@ PP(pp_negate)
PP(pp_not)
{
- dSP; tryAMAGICunSET(not);
+ djSP; tryAMAGICunSET(not);
*PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
return NORMAL;
}
PP(pp_complement)
{
- dSP; dTARGET; tryAMAGICun(compl);
+ djSP; dTARGET; tryAMAGICun(compl);
{
dTOPss;
if (SvNIOKp(sv)) {
@@ -1473,72 +1458,21 @@ PP(pp_complement)
}
}
else {
- register U8 *tmps;
+ register char *tmps;
+ register long *tmpl;
register I32 anum;
STRLEN len;
SvSetSV(TARG, sv);
- tmps = (U8*)SvPV_force(TARG, len);
+ tmps = 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
- {
- 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;
- }
+ 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;
#endif
for ( ; anum > 0; anum--, tmps++)
*tmps = ~*tmps;
@@ -1553,7 +1487,7 @@ PP(pp_complement)
PP(pp_i_multiply)
{
- dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
{
dPOPTOPiirl;
SETi( left * right );
@@ -1563,7 +1497,7 @@ PP(pp_i_multiply)
PP(pp_i_divide)
{
- dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
dPOPiv;
if (value == 0)
@@ -1576,7 +1510,7 @@ PP(pp_i_divide)
PP(pp_i_modulo)
{
- dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
{
dPOPTOPiirl;
if (!right)
@@ -1588,9 +1522,9 @@ PP(pp_i_modulo)
PP(pp_i_add)
{
- dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
{
- dPOPTOPiirl_ul;
+ dPOPTOPiirl;
SETi( left + right );
RETURN;
}
@@ -1598,9 +1532,9 @@ PP(pp_i_add)
PP(pp_i_subtract)
{
- dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
{
- dPOPTOPiirl_ul;
+ dPOPTOPiirl;
SETi( left - right );
RETURN;
}
@@ -1608,7 +1542,7 @@ PP(pp_i_subtract)
PP(pp_i_lt)
{
- dSP; tryAMAGICbinSET(lt,0);
+ djSP; tryAMAGICbinSET(lt,0);
{
dPOPTOPiirl;
SETs(boolSV(left < right));
@@ -1618,7 +1552,7 @@ PP(pp_i_lt)
PP(pp_i_gt)
{
- dSP; tryAMAGICbinSET(gt,0);
+ djSP; tryAMAGICbinSET(gt,0);
{
dPOPTOPiirl;
SETs(boolSV(left > right));
@@ -1628,7 +1562,7 @@ PP(pp_i_gt)
PP(pp_i_le)
{
- dSP; tryAMAGICbinSET(le,0);
+ djSP; tryAMAGICbinSET(le,0);
{
dPOPTOPiirl;
SETs(boolSV(left <= right));
@@ -1638,7 +1572,7 @@ PP(pp_i_le)
PP(pp_i_ge)
{
- dSP; tryAMAGICbinSET(ge,0);
+ djSP; tryAMAGICbinSET(ge,0);
{
dPOPTOPiirl;
SETs(boolSV(left >= right));
@@ -1648,7 +1582,7 @@ PP(pp_i_ge)
PP(pp_i_eq)
{
- dSP; tryAMAGICbinSET(eq,0);
+ djSP; tryAMAGICbinSET(eq,0);
{
dPOPTOPiirl;
SETs(boolSV(left == right));
@@ -1658,7 +1592,7 @@ PP(pp_i_eq)
PP(pp_i_ne)
{
- dSP; tryAMAGICbinSET(ne,0);
+ djSP; tryAMAGICbinSET(ne,0);
{
dPOPTOPiirl;
SETs(boolSV(left != right));
@@ -1668,7 +1602,7 @@ PP(pp_i_ne)
PP(pp_i_ncmp)
{
- dSP; dTARGET; tryAMAGICbin(ncmp,0);
+ djSP; dTARGET; tryAMAGICbin(ncmp,0);
{
dPOPTOPiirl;
I32 value;
@@ -1686,7 +1620,7 @@ PP(pp_i_ncmp)
PP(pp_i_negate)
{
- dSP; dTARGET; tryAMAGICun(neg);
+ djSP; dTARGET; tryAMAGICun(neg);
SETi(-TOPi);
RETURN;
}
@@ -1695,7 +1629,7 @@ PP(pp_i_negate)
PP(pp_atan2)
{
- dSP; dTARGET; tryAMAGICbin(atan2,0);
+ djSP; dTARGET; tryAMAGICbin(atan2,0);
{
dPOPTOPnnrl;
SETn(Perl_atan2(left, right));
@@ -1705,7 +1639,7 @@ PP(pp_atan2)
PP(pp_sin)
{
- dSP; dTARGET; tryAMAGICun(sin);
+ djSP; dTARGET; tryAMAGICun(sin);
{
NV value;
value = POPn;
@@ -1717,7 +1651,7 @@ PP(pp_sin)
PP(pp_cos)
{
- dSP; dTARGET; tryAMAGICun(cos);
+ djSP; dTARGET; tryAMAGICun(cos);
{
NV value;
value = POPn;
@@ -1744,7 +1678,7 @@ extern double drand48 (void);
PP(pp_rand)
{
- dSP; dTARGET;
+ djSP; dTARGET;
NV value;
if (MAXARG < 1)
value = 1.0;
@@ -1763,7 +1697,7 @@ PP(pp_rand)
PP(pp_srand)
{
- dSP;
+ djSP;
UV anum;
if (MAXARG < 1)
anum = seed();
@@ -1800,6 +1734,7 @@ S_seed(pTHX)
#define SEED_C3 269
#define SEED_C5 26107
+ dTHR;
#ifndef PERL_NO_DEV_RANDOM
int fd;
#endif
@@ -1858,7 +1793,7 @@ S_seed(pTHX)
PP(pp_exp)
{
- dSP; dTARGET; tryAMAGICun(exp);
+ djSP; dTARGET; tryAMAGICun(exp);
{
NV value;
value = POPn;
@@ -1870,12 +1805,12 @@ PP(pp_exp)
PP(pp_log)
{
- dSP; dTARGET; tryAMAGICun(log);
+ djSP; dTARGET; tryAMAGICun(log);
{
NV value;
value = POPn;
if (value <= 0.0) {
- SET_NUMERIC_STANDARD();
+ RESTORE_NUMERIC_STANDARD();
DIE(aTHX_ "Can't take log of %g", value);
}
value = Perl_log(value);
@@ -1886,12 +1821,12 @@ PP(pp_log)
PP(pp_sqrt)
{
- dSP; dTARGET; tryAMAGICun(sqrt);
+ djSP; dTARGET; tryAMAGICun(sqrt);
{
NV value;
value = POPn;
if (value < 0.0) {
- SET_NUMERIC_STANDARD();
+ RESTORE_NUMERIC_STANDARD();
DIE(aTHX_ "Can't take sqrt of %g", value);
}
value = Perl_sqrt(value);
@@ -1902,7 +1837,7 @@ PP(pp_sqrt)
PP(pp_int)
{
- dSP; dTARGET;
+ djSP; dTARGET;
{
NV value = TOPn;
IV iv;
@@ -1912,24 +1847,11 @@ PP(pp_int)
SETi(iv);
}
else {
- 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
- }
+ if (value >= 0.0)
+ (void)Perl_modf(value, &value);
else {
-#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
+ (void)Perl_modf(-value, &value);
+ value = -value;
}
iv = I_V(value);
if (iv == value)
@@ -1943,7 +1865,7 @@ PP(pp_int)
PP(pp_abs)
{
- dSP; dTARGET; tryAMAGICun(abs);
+ djSP; dTARGET; tryAMAGICun(abs);
{
NV value = TOPn;
IV iv;
@@ -1965,37 +1887,35 @@ PP(pp_abs)
PP(pp_hex)
{
- dSP; dTARGET;
+ djSP; dTARGET;
char *tmps;
- STRLEN argtype;
- STRLEN len;
+ I32 argtype;
+ STRLEN n_a;
- tmps = (SvPVx(POPs, len));
- argtype = 1; /* allow underscores */
- XPUSHn(scan_hex(tmps, len, &argtype));
+ tmps = POPpx;
+ XPUSHn(scan_hex(tmps, 99, &argtype));
RETURN;
}
PP(pp_oct)
{
- dSP; dTARGET;
+ djSP; dTARGET;
NV value;
- STRLEN argtype;
+ I32 argtype;
char *tmps;
- STRLEN len;
+ STRLEN n_a;
- tmps = (SvPVx(POPs, len));
- while (*tmps && len && isSPACE(*tmps))
- tmps++, len--;
+ tmps = POPpx;
+ while (*tmps && isSPACE(*tmps))
+ tmps++;
if (*tmps == '0')
- tmps++, len--;
- argtype = 1; /* allow underscores */
+ tmps++;
if (*tmps == 'x')
- value = scan_hex(++tmps, --len, &argtype);
+ value = scan_hex(++tmps, 99, &argtype);
else if (*tmps == 'b')
- value = scan_bin(++tmps, --len, &argtype);
+ value = scan_bin(++tmps, 99, &argtype);
else
- value = scan_oct(tmps, len, &argtype);
+ value = scan_oct(tmps, 99, &argtype);
XPUSHn(value);
RETURN;
}
@@ -2004,7 +1924,7 @@ PP(pp_oct)
PP(pp_length)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *sv = TOPs;
if (DO_UTF8(sv))
@@ -2016,61 +1936,48 @@ PP(pp_length)
PP(pp_substr)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *sv;
I32 len;
STRLEN curlen;
- STRLEN utf8_curlen;
+ STRLEN utfcurlen;
I32 pos;
I32 rem;
I32 fail;
- I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
+ I32 lvalue = PL_op->op_flags & OPf_MOD;
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 (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);
+ if (MAXARG > 2) {
+ if (MAXARG > 3) {
+ sv = POPs;
+ repl = SvPV(sv, repl_len);
}
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)) {
- utf8_curlen = sv_len_utf8(sv);
- if (utf8_curlen == curlen)
- utf8_curlen = 0;
+ utfcurlen = sv_len_utf8(sv);
+ if (utfcurlen == curlen)
+ utfcurlen = 0;
else
- curlen = utf8_curlen;
+ curlen = utfcurlen;
}
else
- utf8_curlen = 0;
+ utfcurlen = 0;
if (pos >= arybase) {
pos -= arybase;
rem = curlen-pos;
fail = rem;
- if (num_args > 2) {
+ if (MAXARG > 2) {
if (len < 0) {
rem += len;
if (rem < 0)
@@ -2082,7 +1989,7 @@ PP(pp_substr)
}
else {
pos += curlen;
- if (num_args < 3)
+ if (MAXARG < 3)
rem = curlen;
else if (len >= 0) {
rem = pos+len;
@@ -2107,29 +2014,14 @@ PP(pp_substr)
RETPUSHUNDEF;
}
else {
- I32 upos = pos;
- I32 urem = rem;
- if (utf8_curlen)
+ if (utfcurlen) {
sv_pos_u2b(sv, &pos, &rem);
+ SvUTF8_on(TARG);
+ }
tmps += pos;
sv_setpvn(TARG, tmps, rem);
- 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);
- }
+ if (repl)
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)) {
@@ -2140,7 +2032,7 @@ PP(pp_substr)
"Attempt to use reference as lvalue in substr");
}
if (SvOK(sv)) /* is it defined ? */
- (void)SvPOK_only_UTF8(sv);
+ (void)SvPOK_only(sv);
else
sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
}
@@ -2156,8 +2048,8 @@ PP(pp_substr)
SvREFCNT_dec(LvTARG(TARG));
LvTARG(TARG) = SvREFCNT_inc(sv);
}
- LvTARGOFF(TARG) = upos;
- LvTARGLEN(TARG) = urem;
+ LvTARGOFF(TARG) = pos;
+ LvTARGLEN(TARG) = rem;
}
}
SPAGAIN;
@@ -2167,11 +2059,11 @@ PP(pp_substr)
PP(pp_vec)
{
- dSP; dTARGET;
- register IV size = POPi;
- register IV offset = POPi;
+ djSP; dTARGET;
+ register I32 size = POPi;
+ register I32 offset = POPi;
register SV *src = POPs;
- I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
+ I32 lvalue = PL_op->op_flags & OPf_MOD;
SvTAINTED_off(TARG); /* decontaminate */
if (lvalue) { /* it's an lvalue! */
@@ -2196,7 +2088,7 @@ PP(pp_vec)
PP(pp_index)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *big;
SV *little;
I32 offset;
@@ -2232,7 +2124,7 @@ PP(pp_index)
PP(pp_rindex)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *big;
SV *little;
STRLEN blen;
@@ -2273,7 +2165,7 @@ PP(pp_rindex)
PP(pp_sprintf)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ djSP; dMARK; dORIGMARK; dTARGET;
do_sprintf(TARG, SP-MARK, MARK+1);
TAINT_IF(SvTAINTED(TARG));
SP = ORIGMARK;
@@ -2283,20 +2175,26 @@ PP(pp_sprintf)
PP(pp_ord)
{
- dSP; dTARGET;
- SV *argsv = POPs;
- STRLEN len;
- U8 *s = (U8*)SvPVx(argsv, len);
+ djSP; dTARGET;
+ UV value;
+ STRLEN n_a;
+ SV *tmpsv = POPs;
+ U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
+ I32 retlen;
- XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff));
+ if ((*tmps & 0x80) && DO_UTF8(tmpsv))
+ value = utf8_to_uv(tmps, &retlen);
+ else
+ value = (UV)(*tmps & 255);
+ XPUSHu(value);
RETURN;
}
PP(pp_chr)
{
- dSP; dTARGET;
+ djSP; dTARGET;
char *tmps;
- UV value = POPu;
+ U32 value = POPu;
(void)SvUPGRADE(TARG,SVt_PV);
@@ -2317,6 +2215,7 @@ PP(pp_chr)
tmps = SvPVX(TARG);
*tmps++ = value;
*tmps = '\0';
+ SvUTF8_off(TARG); /* decontaminate */
(void)SvPOK_only(TARG);
XPUSHs(TARG);
RETURN;
@@ -2324,7 +2223,7 @@ PP(pp_chr)
PP(pp_crypt)
{
- dSP; dTARGET; dPOPTOPssrl;
+ djSP; dTARGET; dPOPTOPssrl;
STRLEN n_a;
#ifdef HAS_CRYPT
char *tmps = SvPV(left, n_a);
@@ -2343,16 +2242,16 @@ PP(pp_crypt)
PP(pp_ucfirst)
{
- dSP;
+ djSP;
SV *sv = TOPs;
register U8 *s;
STRLEN slen;
- if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
- STRLEN ulen;
- U8 tmpbuf[UTF8_MAXLEN+1];
+ if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
+ I32 ulen;
+ U8 tmpbuf[UTF8_MAXLEN];
U8 *tend;
- UV uv = utf8_to_uv(s, slen, &ulen, 0);
+ UV uv = utf8_to_uv(s, &ulen);
if (PL_op->op_private & OPpLOCALE) {
TAINT;
@@ -2402,16 +2301,16 @@ PP(pp_ucfirst)
PP(pp_lcfirst)
{
- dSP;
+ djSP;
SV *sv = TOPs;
register U8 *s;
STRLEN slen;
- if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
- STRLEN ulen;
- U8 tmpbuf[UTF8_MAXLEN+1];
+ if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
+ I32 ulen;
+ U8 tmpbuf[UTF8_MAXLEN];
U8 *tend;
- UV uv = utf8_to_uv(s, slen, &ulen, 0);
+ UV uv = utf8_to_uv(s, &ulen);
if (PL_op->op_private & OPpLOCALE) {
TAINT;
@@ -2461,14 +2360,14 @@ PP(pp_lcfirst)
PP(pp_uc)
{
- dSP;
+ djSP;
SV *sv = TOPs;
register U8 *s;
STRLEN len;
if (DO_UTF8(sv)) {
dTARGET;
- STRLEN ulen;
+ I32 ulen;
register U8 *d;
U8 *send;
@@ -2488,7 +2387,7 @@ PP(pp_uc)
TAINT;
SvTAINTED_on(TARG);
while (s < send) {
- d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
+ d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
s += ulen;
}
}
@@ -2535,14 +2434,14 @@ PP(pp_uc)
PP(pp_lc)
{
- dSP;
+ djSP;
SV *sv = TOPs;
register U8 *s;
STRLEN len;
if (DO_UTF8(sv)) {
dTARGET;
- STRLEN ulen;
+ I32 ulen;
register U8 *d;
U8 *send;
@@ -2562,7 +2461,7 @@ PP(pp_lc)
TAINT;
SvTAINTED_on(TARG);
while (s < send) {
- d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
+ d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
s += ulen;
}
}
@@ -2610,7 +2509,7 @@ PP(pp_lc)
PP(pp_quotemeta)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *sv = TOPs;
STRLEN len;
register char *s = SvPV(sv,len);
@@ -2623,7 +2522,7 @@ PP(pp_quotemeta)
d = SvPVX(TARG);
if (DO_UTF8(sv)) {
while (len) {
- if (UTF8_IS_CONTINUED(*s)) {
+ if (*s & 0x80) {
STRLEN ulen = UTF8SKIP(s);
if (ulen > len)
ulen = len;
@@ -2649,7 +2548,7 @@ PP(pp_quotemeta)
}
*d = '\0';
SvCUR_set(TARG, d - SvPVX(TARG));
- (void)SvPOK_only_UTF8(TARG);
+ (void)SvPOK_only(TARG);
}
else
sv_setpvn(TARG, s, len);
@@ -2663,10 +2562,10 @@ PP(pp_quotemeta)
PP(pp_aslice)
{
- dSP; dMARK; dORIGMARK;
+ djSP; dMARK; dORIGMARK;
register SV** svp;
register AV* av = (AV*)POPs;
- register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
+ register I32 lval = PL_op->op_flags & OPf_MOD;
I32 arybase = PL_curcop->cop_arybase;
I32 elem;
@@ -2708,7 +2607,7 @@ PP(pp_aslice)
PP(pp_each)
{
- dSP;
+ djSP;
HV *hash = (HV*)POPs;
HE *entry;
I32 gimme = GIMME_V;
@@ -2750,7 +2649,7 @@ PP(pp_keys)
PP(pp_delete)
{
- dSP;
+ djSP;
I32 gimme = GIMME_V;
I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
SV *sv;
@@ -2814,7 +2713,7 @@ PP(pp_delete)
PP(pp_exists)
{
- dSP;
+ djSP;
SV *tmpsv;
HV *hv;
@@ -2851,9 +2750,9 @@ PP(pp_exists)
PP(pp_hslice)
{
- dSP; dMARK; dORIGMARK;
+ djSP; dMARK; dORIGMARK;
register HV *hv = (HV*)POPs;
- register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
+ register I32 lval = PL_op->op_flags & OPf_MOD;
I32 realhv = (SvTYPE(hv) == SVt_PVHV);
if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
@@ -2893,7 +2792,7 @@ PP(pp_hslice)
PP(pp_list)
{
- dSP; dMARK;
+ djSP; dMARK;
if (GIMME != G_ARRAY) {
if (++MARK <= SP)
*MARK = *SP; /* unwanted list, return last item */
@@ -2906,7 +2805,7 @@ PP(pp_list)
PP(pp_lslice)
{
- dSP;
+ djSP;
SV **lastrelem = PL_stack_sp;
SV **lastlelem = PL_stack_base + POPMARK;
SV **firstlelem = PL_stack_base + POPMARK + 1;
@@ -2961,7 +2860,7 @@ PP(pp_lslice)
PP(pp_anonlist)
{
- dSP; dMARK; dORIGMARK;
+ djSP; dMARK; dORIGMARK;
I32 items = SP - MARK;
SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
SP = ORIGMARK; /* av_make() might realloc stack_sp */
@@ -2971,7 +2870,7 @@ PP(pp_anonlist)
PP(pp_anonhash)
{
- dSP; dMARK; dORIGMARK;
+ djSP; dMARK; dORIGMARK;
HV* hv = (HV*)sv_2mortal((SV*)newHV());
while (MARK < SP) {
@@ -2990,7 +2889,7 @@ PP(pp_anonhash)
PP(pp_splice)
{
- dSP; dMARK; dORIGMARK;
+ djSP; dMARK; dORIGMARK;
register AV *ary = (AV*)*++MARK;
register SV **src;
register SV **dst;
@@ -3192,7 +3091,7 @@ PP(pp_splice)
PP(pp_push)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ djSP; dMARK; dORIGMARK; dTARGET;
register AV *ary = (AV*)*++MARK;
register SV *sv = &PL_sv_undef;
MAGIC *mg;
@@ -3222,7 +3121,7 @@ PP(pp_push)
PP(pp_pop)
{
- dSP;
+ djSP;
AV *av = (AV*)POPs;
SV *sv = av_pop(av);
if (AvREAL(av))
@@ -3233,7 +3132,7 @@ PP(pp_pop)
PP(pp_shift)
{
- dSP;
+ djSP;
AV *av = (AV*)POPs;
SV *sv = av_shift(av);
EXTEND(SP, 1);
@@ -3247,7 +3146,7 @@ PP(pp_shift)
PP(pp_unshift)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ djSP; dMARK; dORIGMARK; dTARGET;
register AV *ary = (AV*)*++MARK;
register SV *sv;
register I32 i = 0;
@@ -3277,7 +3176,7 @@ PP(pp_unshift)
PP(pp_reverse)
{
- dSP; dMARK;
+ djSP; dMARK;
register SV *tmp;
SV **oldsp = SP;
@@ -3309,17 +3208,20 @@ PP(pp_reverse)
U8* s = (U8*)SvPVX(TARG);
U8* send = (U8*)(s + len);
while (s < send) {
- if (UTF8_IS_ASCII(*s)) {
+ if (*s < 0x80) {
s++;
continue;
}
else {
- if (!utf8_to_uv_simple(s, 0))
- break;
up = (char*)s;
s += UTF8SKIP(s);
down = (char*)(s - 1);
- /* reverse this character */
+ if (s > send || !((*down & 0xc0) == 0x80)) {
+ if (ckWARN_d(WARN_UTF8))
+ Perl_warner(aTHX_ WARN_UTF8,
+ "Malformed UTF-8 character");
+ break;
+ }
while (down > up) {
tmp = *up;
*up++ = *down;
@@ -3335,7 +3237,7 @@ PP(pp_reverse)
*up++ = *down;
*down-- = tmp;
}
- (void)SvPOK_only_UTF8(TARG);
+ (void)SvPOK_only(TARG);
}
SP = MARK + 1;
SETTARG;
@@ -3385,7 +3287,7 @@ S_mul128(pTHX_ SV *sv, U8 m)
PP(pp_unpack)
{
- dSP;
+ djSP;
dPOPPOPssrl;
I32 start_sp_offset = SP - PL_stack_base;
I32 gimme = GIMME_V;
@@ -3403,9 +3305,9 @@ PP(pp_unpack)
register char *str;
/* These must not be in registers: */
- short ashort;
+ I16 ashort;
int aint;
- long along;
+ I32 along;
#ifdef HAS_QUAD
Quad_t aquad;
#endif
@@ -3701,9 +3603,7 @@ PP(pp_unpack)
len = strend - s;
if (checksum) {
while (len-- > 0 && s < strend) {
- STRLEN alen;
- auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
- along = alen;
+ auint = utf8_to_uv((U8*)s, &along);
s += along;
if (checksum > 32)
cdouble += (NV)auint;
@@ -3715,9 +3615,7 @@ PP(pp_unpack)
EXTEND(SP, len);
EXTEND_MORTAL(len);
while (len-- > 0 && s < strend) {
- STRLEN alen;
- auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
- along = alen;
+ auint = utf8_to_uv((U8*)s, &along);
s += along;
sv = NEWSV(37, 0);
sv_setuv(sv, (UV)auint);
@@ -3958,6 +3856,7 @@ PP(pp_unpack)
if (checksum) {
#if LONGSIZE != SIZE32
if (natint) {
+ long along;
while (len-- > 0) {
COPYNN(s, &along, sizeof(long));
s += sizeof(long);
@@ -3971,9 +3870,6 @@ PP(pp_unpack)
#endif
{
while (len-- > 0) {
-#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
- I32 along;
-#endif
COPY32(s, &along);
#if LONGSIZE > SIZE32
if (along > 2147483647)
@@ -3992,6 +3888,7 @@ PP(pp_unpack)
EXTEND_MORTAL(len);
#if LONGSIZE != SIZE32
if (natint) {
+ long along;
while (len-- > 0) {
COPYNN(s, &along, sizeof(long));
s += sizeof(long);
@@ -4004,9 +3901,6 @@ PP(pp_unpack)
#endif
{
while (len-- > 0) {
-#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
- I32 along;
-#endif
COPY32(s, &along);
#if LONGSIZE > SIZE32
if (along > 2147483647)
@@ -4128,7 +4022,7 @@ PP(pp_unpack)
while ((len > 0) && (s < strend)) {
auv = (auv << 7) | (*s & 0x7f);
- if (UTF8_IS_ASCII(*s++)) {
+ if (!(*s++ & 0x80)) {
bytes = 0;
sv = NEWSV(40, 0);
sv_setuv(sv, auv);
@@ -4140,7 +4034,7 @@ PP(pp_unpack)
char *t;
STRLEN n_a;
- sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
+ sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
while (s < strend) {
sv = mul128(sv, *s & 0x7f);
if (!(*s++ & 0x80)) {
@@ -4472,12 +4366,11 @@ S_div128(pTHX_ SV *pnum, bool *done)
PP(pp_pack)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ djSP; 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;
@@ -4508,7 +4401,6 @@ 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)
@@ -4516,12 +4408,8 @@ PP(pp_pack)
#ifdef PERL_NATINT_PACK
natint = 0;
#endif
- if (isSPACE(datumtype)) {
- patcopy++;
+ if (isSPACE(datumtype))
continue;
- }
- if (datumtype == 'U' && pat == patcopy+1)
- SvUTF8_on(cat);
if (datumtype == '#') {
while (pat < patend && *pat != '\n')
pat++;
@@ -4558,8 +4446,7 @@ 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)
- + (*pat == 'Z' ? 1 : 0)));
+ ? *MARK : &PL_sv_no)));
}
switch(datumtype) {
default:
@@ -4753,7 +4640,7 @@ PP(pp_pack)
while (len-- > 0) {
fromstr = NEXTFROM;
auint = SvUV(fromstr);
- SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
+ SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
- SvPVX(cat));
}
@@ -4857,14 +4744,10 @@ PP(pp_pack)
DIE(aTHX_ "Cannot compress negative numbers");
if (
-#if UVSIZE > 4 && UVSIZE >= NVSIZE
- adouble <= 0xffffffff
-#else
-# ifdef CXUX_BROKEN_CONSTANT_CONVERT
+#ifdef CXUX_BROKEN_CONSTANT_CONVERT
adouble <= UV_MAX_cxux
-# else
+#else
adouble <= UV_MAX
-# endif
#endif
)
{
@@ -4907,9 +4790,8 @@ 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 */
@@ -5066,21 +4948,19 @@ PP(pp_pack)
PP(pp_split)
{
- dSP; dTARG;
+ djSP; dTARG;
AV *ary;
- register IV limit = POPi; /* note, negative is forever */
+ register I32 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;
- STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
- I32 maxiters = slen + 10;
+ I32 maxiters = (strend - s) + 10;
I32 i;
char *orig;
I32 origlimit = limit;
@@ -5098,7 +4978,7 @@ PP(pp_split)
pm = (PMOP*)POPs;
#endif
if (!pm || !s)
- DIE(aTHX_ "panic: pp_split");
+ DIE(aTHX_ "panic: do_split");
rx = pm->op_pmregexp;
TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
@@ -5174,8 +5054,6 @@ 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;
@@ -5196,8 +5074,6 @@ 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;
}
@@ -5207,11 +5083,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 && !(rx->reganch & ROPT_UTF8) && !tail) {
- STRLEN n_a;
- char c = *SvPV(csv, n_a);
+ if (len == 1 && !tail) {
+ c = *SvPV(csv,len);
while (--limit) {
/*SUPPRESS 530*/
for (m = s; m < strend && *m != c; m++) ;
@@ -5221,15 +5097,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);
- /* 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 */
+ s = m + 1;
}
}
else {
@@ -5243,20 +5112,13 @@ PP(pp_split)
sv_setpvn(dstr, s, m-s);
if (make_mortal)
sv_2mortal(dstr);
- if (do_utf8)
- (void)SvUTF8_on(dstr);
XPUSHs(dstr);
- /* 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 */
+ s = m + len; /* Fake \n at the end */
}
}
}
else {
- maxiters += slen * rx->nparens;
+ maxiters += (strend - s) * rx->nparens;
while (s < strend && --limit
/* && (!rx->check_substr
|| ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
@@ -5277,8 +5139,6 @@ 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++) {
@@ -5292,8 +5152,6 @@ PP(pp_split)
dstr = NEWSV(33, 0);
if (make_mortal)
sv_2mortal(dstr);
- if (do_utf8)
- (void)SvUTF8_on(dstr);
XPUSHs(dstr);
}
}
@@ -5308,13 +5166,10 @@ PP(pp_split)
/* keep field after final delim? */
if (s < strend || (iters && origlimit)) {
- STRLEN l = strend - s;
- dstr = NEWSV(34, l);
- sv_setpvn(dstr, s, l);
+ dstr = NEWSV(34, strend-s);
+ sv_setpvn(dstr, s, strend-s);
if (make_mortal)
sv_2mortal(dstr);
- if (do_utf8)
- (void)SvUTF8_on(dstr);
XPUSHs(dstr);
iters++;
}
@@ -5371,6 +5226,7 @@ PP(pp_split)
void
Perl_unlock_condpair(pTHX_ void *svv)
{
+ dTHR;
MAGIC *mg = mg_find((SV*)svv, 'm');
if (!mg)
@@ -5388,11 +5244,28 @@ Perl_unlock_condpair(pTHX_ void *svv)
PP(pp_lock)
{
- dSP;
+ djSP;
dTOPss;
SV *retsv = sv;
#ifdef USE_THREADS
- sv_lock(sv);
+ 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);
+ }
#endif /* USE_THREADS */
if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
|| SvTYPE(retsv) == SVt_PVCV) {
@@ -5405,7 +5278,7 @@ PP(pp_lock)
PP(pp_threadsv)
{
#ifdef USE_THREADS
- dSP;
+ djSP;
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 855a899..7b15ed1 100644
--- a/contrib/perl5/utils/h2ph.PL
+++ b/contrib/perl5/utils/h2ph.PL
@@ -1,4 +1,5 @@
#!/usr/local/bin/perl
+# $FreeBSD$
use Config;
use File::Basename qw(basename dirname);
@@ -36,24 +37,21 @@ $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);
-my @inc_dirs = inc_dirs() if $opt_a;
+@inc_dirs = inc_dirs() if $opt_a;
my $Exit = 0;
-my $Dest_dir = $opt_d || $Config{installsitearch};
+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;
-my @isatype = split(' ',<<END);
+@isatype = split(' ',<<END);
char uchar u_char
short ushort u_short
int uint u_int
@@ -61,18 +59,14 @@ my @isatype = split(' ',<<END);
FILE key_t caddr_t
END
-my %isatype;
@isatype{@isatype} = (1) x @isatype;
-my $inif = 0;
-my %Is_converted;
+$inif = 0;
@ARGV = ('-') unless @ARGV;
build_preamble_if_necessary();
-my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile);
-my ($incl, $next);
-while (defined (my $file = next_file())) {
+while (defined ($file = next_file())) {
if (-l $file and -d $file) {
link_if_possible($file) if ($opt_l);
next;
@@ -136,7 +130,7 @@ while (defined (my $file = next_file())) {
my $proto = '() ';
if ($args ne '') {
$proto = '';
- foreach my $arg (split(/,\s*/,$args)) {
+ foreach $arg (split(/,\s*/,$args)) {
$arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
$curargs{$arg} = 1;
}
@@ -264,11 +258,11 @@ while (defined (my $file = next_file())) {
s@/\*.*?\*/@@g;
s/\s+/ /g;
/^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/;
- (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_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*)(=.+)?$/;
$enum_value =~ s/^=//;
$enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
if ($opt_h) {
@@ -287,13 +281,12 @@ while (defined (my $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;
@@ -301,11 +294,9 @@ sub reindent($) {
$text;
}
-
sub expr {
- my $joined_args;
if(keys(%curargs)) {
- $joined_args = join('|', keys(%curargs));
+ my($joined_args) = join('|', keys(%curargs));
}
while ($_ ne '') {
s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
@@ -357,7 +348,7 @@ sub expr {
};
# struct/union member, including arrays:
s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
- my $id = $1;
+ $id = $1;
$id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
$id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args);
while($id =~ /\[\s*([^\$\&\d\]]+)\]/) {
@@ -373,7 +364,7 @@ sub expr {
$new .= " (\$$id)";
};
s/^([_a-zA-Z]\w*)// && do {
- my $id = $1;
+ $id = $1;
if ($id eq 'struct') {
s/^\s+(\w+)//;
$id .= ' ' . $1;
@@ -515,7 +506,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;
@@ -585,8 +576,7 @@ 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) {
@@ -640,7 +630,7 @@ If run with no arguments, filters standard input to standard output.
=item -d destination_dir
Put the resulting B<.ph> files beneath B<destination_dir>, instead of
-beneath the default Perl library location (C<$Config{'installsitsearch'}>).
+beneath the default Perl library location (C<$Config{'installarchlib'}>).
=item -r
@@ -719,6 +709,8 @@ 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 d323913..c792b7a 100644
--- a/contrib/perl5/utils/perlbug.PL
+++ b/contrib/perl5/utils/perlbug.PL
@@ -1,4 +1,5 @@
#!/usr/local/bin/perl
+# $FreeBSD$
use Config;
use File::Basename qw(&basename &dirname);
@@ -24,7 +25,7 @@ open OUT, ">$file" or die "Can't create $file: $!";
# extract patchlevel.h information
-open PATCH_LEVEL, "<" . catfile(updir, "patchlevel.h")
+open PATCH_LEVEL, "<" . catfile(updir, "patchlevel.h") or open PATCH_LEVEL, "<patchlevel.h"
or die "Can't open patchlevel.h: $!";
my $patchlevel_date = (stat PATCH_LEVEL)[9];
@@ -45,7 +46,7 @@ while (<PATCH_LEVEL>) {
my $patch_desc = "'" . join("',\n '", @patches) . "'";
my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches;
-close(PATCH_LEVEL) or die "Error closing patchlevel.h: $!";
+close PATCH_LEVEL;
# 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
@@ -91,7 +92,7 @@ BEGIN {
$::HaveUtil = ($@ eq "");
};
-my $Version = "1.33";
+my $Version = "1.28";
# 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.
@@ -124,11 +125,6 @@ my $Version = "1.33";
# 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
@@ -136,7 +132,7 @@ my $Version = "1.33";
# - 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) : $];
@@ -154,6 +150,7 @@ 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);
@@ -162,45 +159,30 @@ Send();
exit;
-sub ask_for_alternatives { # (category|severity)
+sub ask_for_alternatives {
my $name = shift;
- 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 $default = shift;
+ my @alts = @_;
my $alt = "";
- if ($ok) {
- $alt = $alts{$name}{'ok'};
- } else {
- my @alts = @{$alts{$name}{'opts'}};
- paraprint <<EOF;
+ paraprint <<EOF;
Please pick a \u$name from the following:
@alts
EOF
- 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)));
- }
+ 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);
lc $alt;
}
@@ -215,7 +197,7 @@ sub Init {
MacPerl::Ask('Provide command-line args here (-h for help):')
if $Is_MacOS && $MacPerl::Version =~ /App/;
- if (!getopts("Adhva:s:b:f:F:r:e:SCc:to:n:")) { Help(); exit; };
+ if (!getopts("dhva: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.
@@ -223,7 +205,7 @@ sub Init {
# -------- Configuration ---------
# perlbug address
- $perlbug = 'perlbug@perl.org';
+ $perlbug = 'perlbug@perl.com';
# Test address
$testaddress = 'perlbug-test@perl.com';
@@ -295,6 +277,8 @@ 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();
@@ -485,10 +469,14 @@ EOF
}
# Prompt for category of bug
- $category ||= ask_for_alternatives('category');
+ $category ||= ask_for_alternatives("category", "core",
+ qw(core docs install
+ library utilities));
# Prompt for severity of bug
- $severity ||= ask_for_alternatives('severity');
+ $severity ||= ask_for_alternatives("severity", "low",
+ qw(critical high medium
+ low wishlist none));
# Generate scratch file to edit report in
$filename = filename();
@@ -522,7 +510,7 @@ EOF
}
# Generate report
- open(REP,">$filename") or die "Unable to create report file `$filename': $!\n";
+ open(REP,">$filename");
my $reptype = !$ok ? "bug" : $::opt_n ? "build failure" : "success";
print REP <<EOF;
@@ -539,7 +527,7 @@ EOF
while (<F>) {
print REP $_
}
- close(F) or die "Error closing `$file': $!";
+ close(F);
} else {
print REP <<EOF;
@@ -553,17 +541,17 @@ EOF
EOF
}
Dump(*REP);
- close(REP) or die "Error closing report file: $!";
+ close(REP);
# 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") or die "Unable to open report file `$filename': $!\n";
+ open(REP, "<$filename");
while (<REP>) {
s/\s+//g;
$REP{$_}++;
}
- close(REP) or die "Error closing report file `$filename': $!";
+ close(REP);
} # sub Query
sub Dump {
@@ -574,13 +562,6 @@ 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",
@@ -650,8 +631,7 @@ EOF
}
tryagain:
- my $sts;
- $sts = system("$ed $filename") unless $Is_MacOS;
+ my $sts = system("$ed $filename") unless $Is_MacOS;
if ($Is_MacOS) {
require ExtUtils::MakeMaker;
ExtUtils::MM_MacOS::launch_file($filename);
@@ -685,7 +665,7 @@ EOF
# Check that we have a report that has some, eh, report in it.
my $unseen = 0;
- open(REP, "<$filename") or die "Couldn't open `$filename': $!\n";
+ open(REP, "<$filename");
# 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
@@ -740,22 +720,22 @@ EOF
print "\nError opening $file: $!\n\n";
goto retry;
}
- open(REP, "<$filename") or die "Couldn't open file `$filename': $!\n";
+ open(REP, "<$filename");
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) or die "Error closing report file `$filename': $!";
- close(FILE) or die "Error closing $file: $!";
+ close(REP);
+ close(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") or die "Couldn't open file `$filename': $!\n";
+ open(REP, "<$filename");
while (<REP>) { print $_ }
- close(REP) or die "Error closing report file `$filename': $!";
+ close(REP);
} elsif ($action =~ /^se/i) { # <S>end
# Send the message
print "Are you certain you want to send this message?\n"
@@ -776,7 +756,7 @@ EOF
Edit();
} elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit
Cancel();
- } elsif ($action =~ /^s/i) {
+ } elsif ($action =~ /^s/) {
paraprint <<EOF;
I'm sorry, but I didn't understand that. Please type "send" or "save".
EOF
@@ -797,9 +777,9 @@ sub Send {
$msg->add("Reply-To",$from) if $from;
$fh = $msg->open;
- open(REP, "<$filename") or die "Couldn't open `$filename': $!\n";
+ open(REP, "<$filename");
while (<REP>) { print $fh $_ }
- close(REP) or die "Error closing $filename: $!";
+ close(REP);
$fh->close;
print "\nMessage sent.\n";
@@ -844,16 +824,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 -oi") || die "'|$sendmail -t -oi' failed: $!";
+ open(SENDMAIL, "|$sendmail -t") || die "'|$sendmail -t' 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") or die "Couldn't open `$filename': $!\n";
+ open(REP, "<$filename");
while (<REP>) { print SENDMAIL $_ }
- close(REP) or die "Error closing $filename: $!";
+ close(REP);
if (close(SENDMAIL)) {
printf "\nMessage %s.\n", $outfile ? "saved" : "sent";
@@ -874,7 +854,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] [-A] [-ok | -okay | -nok | -nokay]
+$0 [-v] [-r returnaddress] [-ok | -okay | -nok | -nokay]
Simplest usage: run "$0", and follow the prompts.
@@ -896,9 +876,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. This prints out your configuration data, without mailing
+ -d Data mode (the default if you redirect or pipe output.)
+ 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.
@@ -913,8 +893,12 @@ EOF
}
sub filename {
- my $dir = File::Spec->tmpdir();
+ my $dir = $Is_VMS ? 'sys$scratch:'
+ : ($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'}
+ : $Is_MacOS ? $ENV{'TMPDIR'}
+ : '/tmp';
$filename = "bugrep0$$";
+# $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|;
$filename++ while -e File::Spec->catfile($dir, $filename);
$filename = File::Spec->catfile($dir, $filename);
}
@@ -946,10 +930,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<-A> ]> S<[ B<-h> ]>
+S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-h> ]>
B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]>
- S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]>
+S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]>
=head1 DESCRIPTION
@@ -967,7 +951,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.org>. You might
+compose your own report, and email it to B<perlbug@perl.com>. 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
@@ -1045,7 +1029,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.org will register you as a savior of the world. Your
+perlbug@perl.com 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.
@@ -1065,7 +1049,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.org>. If, for some reason, you cannot run
+it to B<perlbug@perl.com>. 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).
@@ -1092,14 +1076,7 @@ version of perl comes out and your bug is still present.
=item B<-a>
-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.
+Address to send the report to. Defaults to `perlbug@perl.com'.
=item B<-b>
diff --git a/contrib/perl5/utils/splain.PL b/contrib/perl5/utils/splain.PL
index a638dba..0a71544 100644
--- a/contrib/perl5/utils/splain.PL
+++ b/contrib/perl5/utils/splain.PL
@@ -21,7 +21,12 @@ $file .= '.com' if $^O eq 'VMS';
# Open input file before creating output file.
$IN = '../lib/diagnostics.pm';
-open IN or die "Can't open $IN: $!\n";
+$in = open IN;
+if (!$in) {
+ $inmsg = "Can't open $IN: $!\n";
+ $IN = 'diagnostics.pm';
+ $in = open IN or die $inmsg, "Can't open $IN: $!\n";
+}
# Create output file.
open OUT,">$file" or die "Can't create $file: $!";
OpenPOWER on IntegriCloud