summaryrefslogtreecommitdiffstats
path: root/contrib/perl5/ext
diff options
context:
space:
mode:
authormarkm <markm@FreeBSD.org>1999-05-02 14:33:17 +0000
committermarkm <markm@FreeBSD.org>1999-05-02 14:33:17 +0000
commit77644ee620b6a79cf8c538abaf7cd301a875528d (patch)
treeb4adabf341898a4378f4b7f8c7fb65f3f7c77769 /contrib/perl5/ext
parent4fcbc3669aa997848e15198cc9fb856287a6788c (diff)
downloadFreeBSD-src-77644ee620b6a79cf8c538abaf7cd301a875528d.zip
FreeBSD-src-77644ee620b6a79cf8c538abaf7cd301a875528d.tar.gz
Maintenance releace 3 of perl5.005. Includes support for threads.
Diffstat (limited to 'contrib/perl5/ext')
-rw-r--r--contrib/perl5/ext/B/B.pm10
-rw-r--r--contrib/perl5/ext/B/B.xs14
-rw-r--r--contrib/perl5/ext/B/B/Assembler.pm4
-rw-r--r--contrib/perl5/ext/B/B/C.pm81
-rw-r--r--contrib/perl5/ext/B/B/CC.pm27
-rw-r--r--contrib/perl5/ext/B/B/Disassembler.pm2
-rw-r--r--contrib/perl5/ext/B/Makefile.PL2
-rw-r--r--contrib/perl5/ext/B/README4
-rw-r--r--contrib/perl5/ext/DB_File/Changes29
-rw-r--r--contrib/perl5/ext/DB_File/DB_File.pm168
-rw-r--r--contrib/perl5/ext/DB_File/DB_File.xs128
-rw-r--r--contrib/perl5/ext/DB_File/Makefile.PL2
-rw-r--r--contrib/perl5/ext/DB_File/dbinfo2
-rw-r--r--contrib/perl5/ext/DB_File/hints/dynixptx.pl3
-rw-r--r--contrib/perl5/ext/DB_File/typemap6
-rw-r--r--contrib/perl5/ext/Data/Dumper/Changes18
-rw-r--r--contrib/perl5/ext/Data/Dumper/Dumper.pm171
-rw-r--r--contrib/perl5/ext/Data/Dumper/Dumper.xs253
-rw-r--r--contrib/perl5/ext/Data/Dumper/Makefile.PL2
-rw-r--r--contrib/perl5/ext/Data/Dumper/Todo2
-rw-r--r--contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL3
-rw-r--r--contrib/perl5/ext/DynaLoader/Makefile.PL2
-rw-r--r--contrib/perl5/ext/DynaLoader/dl_beos.xs115
-rw-r--r--contrib/perl5/ext/DynaLoader/dl_cygwin32.xs10
-rw-r--r--contrib/perl5/ext/DynaLoader/dl_mpeix.xs11
-rw-r--r--contrib/perl5/ext/DynaLoader/dl_next.xs3
-rw-r--r--contrib/perl5/ext/DynaLoader/dl_vms.xs2
-rw-r--r--contrib/perl5/ext/Errno/Errno_pm.PL66
-rw-r--r--contrib/perl5/ext/Errno/Makefile.PL3
-rw-r--r--contrib/perl5/ext/Fcntl/Makefile.PL2
-rw-r--r--contrib/perl5/ext/GDBM_File/Makefile.PL2
-rw-r--r--contrib/perl5/ext/GDBM_File/hints/sco.pl2
-rw-r--r--contrib/perl5/ext/IO/IO.xs3
-rw-r--r--contrib/perl5/ext/IO/Makefile.PL2
-rw-r--r--contrib/perl5/ext/IO/lib/IO/Pipe.pm10
-rw-r--r--contrib/perl5/ext/IO/lib/IO/Seekable.pm2
-rw-r--r--contrib/perl5/ext/IO/lib/IO/Socket.pm2
-rw-r--r--contrib/perl5/ext/IPC/SysV/Makefile.PL1
-rw-r--r--contrib/perl5/ext/IPC/SysV/Msg.pm4
-rw-r--r--contrib/perl5/ext/IPC/SysV/SysV.xs54
-rw-r--r--contrib/perl5/ext/NDBM_File/Makefile.PL2
-rw-r--r--contrib/perl5/ext/ODBM_File/Makefile.PL2
-rw-r--r--contrib/perl5/ext/Opcode/Makefile.PL2
-rw-r--r--contrib/perl5/ext/Opcode/Opcode.xs3
-rw-r--r--contrib/perl5/ext/Opcode/Safe.pm4
-rw-r--r--contrib/perl5/ext/Opcode/ops.pm2
-rw-r--r--contrib/perl5/ext/POSIX/Makefile.PL2
-rw-r--r--contrib/perl5/ext/POSIX/POSIX.pm110
-rw-r--r--contrib/perl5/ext/POSIX/POSIX.pod7
-rw-r--r--contrib/perl5/ext/POSIX/POSIX.xs73
-rw-r--r--contrib/perl5/ext/POSIX/hints/dynixptx.pl4
-rw-r--r--contrib/perl5/ext/POSIX/hints/mint.pl2
-rw-r--r--contrib/perl5/ext/SDBM_File/Makefile.PL2
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/sdbm.c1
-rw-r--r--contrib/perl5/ext/Socket/Makefile.PL2
-rw-r--r--contrib/perl5/ext/Socket/Socket.pm20
-rw-r--r--contrib/perl5/ext/Socket/Socket.xs112
-rw-r--r--contrib/perl5/ext/Thread/Makefile.PL2
-rw-r--r--contrib/perl5/ext/Thread/Thread.xs37
-rw-r--r--contrib/perl5/ext/Thread/create.t11
-rw-r--r--contrib/perl5/ext/attrs/Makefile.PL2
-rw-r--r--contrib/perl5/ext/attrs/attrs.xs6
-rw-r--r--contrib/perl5/ext/re/Makefile.PL2
-rw-r--r--contrib/perl5/ext/re/re.pm6
64 files changed, 1227 insertions, 416 deletions
diff --git a/contrib/perl5/ext/B/B.pm b/contrib/perl5/ext/B/B.pm
index d5137d4..75dcfb3 100644
--- a/contrib/perl5/ext/B/B.pm
+++ b/contrib/perl5/ext/B/B.pm
@@ -13,7 +13,7 @@ require Exporter;
class peekop cast_I32 cstring cchar hash threadsv_names
main_root main_start main_cv svref_2object
walkoptree walkoptree_slow walkoptree_exec walksymtable
- parents comppadlist sv_undef compile_stats timing_info);
+ parents comppadlist sv_undef compile_stats timing_info init_av);
use strict;
@B::SV::ISA = 'B::OBJECT';
@@ -530,6 +530,8 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>).
=item XSUBANY
+=item CvFLAGS
+
=back
=head2 B::HV METHODS
@@ -576,7 +578,7 @@ This returns the function name as a string (e.g. pp_add, pp_rv2av).
=item desc
-This returns the op description from the global C op_desc array
+This returns the op description from the global C PL_op_desc array
(e.g. "addition" "array deref").
=item targ
@@ -720,6 +722,10 @@ get an initial "handle" on an internal object.
Return the (faked) CV corresponding to the main part of the Perl
program.
+=item init_av
+
+Returns the AV object (i.e. in class B::AV) representing INIT blocks.
+
=item main_root
Returns the root op (i.e. an object in the appropriate B::OP-derived
diff --git a/contrib/perl5/ext/B/B.xs b/contrib/perl5/ext/B/B.xs
index 8dbc915..6610ae8 100644
--- a/contrib/perl5/ext/B/B.xs
+++ b/contrib/perl5/ext/B/B.xs
@@ -267,7 +267,8 @@ static SV *
cchar(SV *sv)
{
SV *sstr = newSVpv("'", 0);
- char *s = SvPV(sv, PL_na);
+ STRLEN n_a;
+ char *s = SvPV(sv, n_a);
if (*s == '\'')
sv_catpv(sstr, "\\'");
@@ -437,6 +438,7 @@ BOOT:
INIT_SPECIALSV_LIST;
#define B_main_cv() PL_main_cv
+#define B_init_av() PL_initav
#define B_main_root() PL_main_root
#define B_main_start() PL_main_start
#define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
@@ -444,6 +446,9 @@ BOOT:
#define B_sv_yes() &PL_sv_yes
#define B_sv_no() &PL_sv_no
+B::AV
+B_init_av()
+
B::CV
B_main_cv()
@@ -1164,6 +1169,13 @@ CvXSUBANY(cv)
CODE:
ST(0) = sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
+MODULE = B PACKAGE = B::CV
+
+U8
+CvFLAGS(cv)
+ B::CV cv
+
+
MODULE = B PACKAGE = B::HV PREFIX = Hv
STRLEN
diff --git a/contrib/perl5/ext/B/B/Assembler.pm b/contrib/perl5/ext/B/B/Assembler.pm
index defcbdf..06e00ad 100644
--- a/contrib/perl5/ext/B/B/Assembler.pm
+++ b/contrib/perl5/ext/B/B/Assembler.pm
@@ -53,6 +53,8 @@ sub B::Asmdata::PUT_U16 { pack("n", $_[0]) }
sub B::Asmdata::PUT_U32 { pack("N", $_[0]) }
sub B::Asmdata::PUT_I32 { pack("N", $_[0]) }
sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here
+sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
+sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
sub B::Asmdata::PUT_strconst {
my $arg = shift;
@@ -78,7 +80,7 @@ sub B::Asmdata::PUT_PV {
error "bad string argument: $arg" unless defined($arg);
return pack("N", length($arg)) . $arg;
}
-sub B::Asmdata::PUT_comment {
+sub B::Asmdata::PUT_comment_t {
my $arg = shift;
$arg = uncstring($arg);
error "bad string argument: $arg" unless defined($arg);
diff --git a/contrib/perl5/ext/B/B/C.pm b/contrib/perl5/ext/B/B/C.pm
index 0b7d6eb..e695cc2 100644
--- a/contrib/perl5/ext/B/B/C.pm
+++ b/contrib/perl5/ext/B/B/C.pm
@@ -13,7 +13,7 @@ use Exporter ();
use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
class cstring cchar svref_2object compile_stats comppadlist hash
- threadsv_names);
+ threadsv_names main_cv init_av);
use B::Asmdata qw(@specialsv_name);
use FileHandle;
@@ -44,7 +44,7 @@ my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect,
$gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
$pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
$xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
- $xrvsect, $xpvbmsect, $xpviosect);
+ $xrvsect, $xpvbmsect, $xpviosect, $bootstrap);
sub walk_and_save_optree;
my $saveoptree_callback = \&walk_and_save_optree;
@@ -596,10 +596,15 @@ sub B::CV::save {
warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
$cvstashname, $cvname); # debug
}
- $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0",
+ $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0x%x",
$xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
$cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
- $$padlist, ${$cv->OUTSIDE}));
+ $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
+
+ if (${$cv->OUTSIDE} == ${main_cv()}){
+ $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
+ }
+
if ($$gv) {
$gv->save;
$init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
@@ -691,7 +696,7 @@ sub B::GV::save {
}
my $gvfilegv = $gv->FILEGV;
if ($$gvfilegv) {
- $init->add(sprintf("GvFILEGV($sym) = s\\_%x;",$$gvfilegv));
+ $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
# warn "GV::save GvFILEGV(*$name)\n"; # debug
$gvfilegv->save;
}
@@ -847,6 +852,7 @@ sub output_all {
$cvopsect, $loopsect, $copsect, $svsect, $xpvsect,
$xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
$xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
+ $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n");
$symsect->output(\*STDOUT, "#define %s\n");
print "\n";
output_declarations();
@@ -1046,30 +1052,61 @@ sub save_object {
foreach $sv (@_) {
svref_2object($sv)->save;
}
-}
+}
+
+sub Dummy_BootStrap { }
sub B::GV::savecv {
my $gv = shift;
my $cv = $gv->CV;
my $name = $gv->NAME;
- if ($$cv && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) {
+ if ($$cv) {
+ if ($name eq "bootstrap" && $cv->XSUB) {
+ my $file = $cv->FILEGV->SV->PV;
+ $bootstrap->add($file);
+ my $name = $gv->STASH->NAME.'::'.$name;
+ no strict 'refs';
+ *{$name} = \&Dummy_BootStrap;
+ $cv = $gv->CV;
+ }
if ($debug_cv) {
warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
$gv->STASH->NAME, $name, $$cv, $$gv);
}
+ my $package=$gv->STASH->NAME;
+ # This seems to undo all the ->isa and prefix stuff we do below
+ # so disable again for now
+ if (0 && ! grep(/^$package$/,@unused_sub_packages)){
+ warn sprintf("omitting cv in superclass %s", $gv->STASH->NAME)
+ if $debug_cv;
+ return ;
+ }
$gv->save;
}
+ elsif ($name eq 'ISA')
+ {
+ $gv->save;
+ }
+
}
+
+
sub save_unused_subs {
my %search_pack;
map { $search_pack{$_} = 1 } @_;
+ @unused_sub_packages=@_;
no strict qw(vars refs);
walksymtable(\%{"main::"}, "savecv", sub {
my $package = shift;
$package =~ s/::$//;
+ return 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
#warn "Considering $package\n";#debug
return 1 if exists $search_pack{$package};
+ #sub try for a partial match
+ if (grep(/^$package\:\:/,@unused_sub_packages)){
+ return 1;
+ }
#warn " (nothing explicit)\n";#debug
# Omit the packages which we use (and which cause grief
# because of fancy "goto &$AUTOLOAD" stuff).
@@ -1079,10 +1116,21 @@ sub save_unused_subs {
|| $package eq "SelectSaver") {
return 0;
}
- my $m;
- foreach $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) {
+ foreach my $u (keys %search_pack) {
+ if ($package =~ /^${u}::/) {
+ warn "$package starts with $u\n";
+ return 1
+ }
+ if ($package->isa($u)) {
+ warn "$package isa $u\n";
+ return 1
+ }
+ return 1 if $package->isa($u);
+ }
+ foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) {
if (defined(&{$package."::$m"})) {
warn "$package has method $m: -u$package assumed\n";#debug
+ push @unused_sub_package, $package;
return 1;
}
}
@@ -1091,14 +1139,25 @@ sub save_unused_subs {
}
sub save_main {
+ warn "Walking tree\n";
+ my $curpad_nam = (comppadlist->ARRAY)[0]->save;
my $curpad_sym = (comppadlist->ARRAY)[1]->save;
+ my $init_av = init_av->save;
+ my $inc_hv = svref_2object(\%INC)->save;
+ my $inc_av = svref_2object(\@INC)->save;
walkoptree(main_root, "save");
warn "done main optree, walking symtable for extras\n" if $debug_cv;
save_unused_subs(@unused_sub_packages);
$init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
sprintf("PL_main_start = s\\_%x;", ${main_start()}),
- "PL_curpad = AvARRAY($curpad_sym);");
+ "PL_curpad = AvARRAY($curpad_sym);",
+ "PL_initav = $init_av;",
+ "GvHV(PL_incgv) = $inc_hv;",
+ "GvAV(PL_incgv) = $inc_av;",
+ "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
+ "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
+ warn "Writing output\n";
output_boilerplate();
print "\n";
output_all("perl_init");
@@ -1118,7 +1177,7 @@ sub init_sections {
xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
xrv => \$xrvsect, xpvbm => \$xpvbmsect,
- xpvio => \$xpviosect);
+ xpvio => \$xpviosect, bootstrap => \$bootstrap);
my ($name, $sectref);
while (($name, $sectref) = splice(@sections, 0, 2)) {
$$sectref = new B::Section $name, \%symtable, 0;
diff --git a/contrib/perl5/ext/B/B/CC.pm b/contrib/perl5/ext/B/B/CC.pm
index 9991d8e..d200d70 100644
--- a/contrib/perl5/ext/B/B/CC.pm
+++ b/contrib/perl5/ext/B/B/CC.pm
@@ -878,7 +878,7 @@ sub pp_sassign {
}
runtime("SvSETMAGIC(TOPs);");
} else {
- my $dst = pop @stack;
+ my $dst = $stack[-1];
my $type = $dst->{type};
runtime("sv = POPs;");
runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
@@ -946,13 +946,25 @@ sub pp_entersub {
write_back_lexicals(REGISTER|TEMPORARY);
write_back_stack();
my $sym = doop($op);
- runtime("if (PL_op != ($sym)->op_next) PL_op = (*PL_op->op_ppaddr)(ARGS);");
- runtime("SPAGAIN;");
+ runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
+ runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
+ runtime("SPAGAIN;}");
$know_op = 0;
invalidate_lexicals(REGISTER|TEMPORARY);
return $op->next;
}
+sub pp_goto{
+
+ my $op = shift;
+ my $ppname = $op->ppaddr;
+ write_back_lexicals() unless $skip_lexicals{$ppname};
+ write_back_stack() unless $skip_stack{$ppname};
+ my $sym=doop($op);
+ runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
+ invalidate_lexicals() unless $skip_invalidate{$ppname};
+ return $op->next;
+}
sub pp_enterwrite {
my $op = shift;
pp_entersub($op);
@@ -1051,7 +1063,7 @@ sub pp_return {
write_back_lexicals(REGISTER|TEMPORARY);
write_back_stack();
doop($op);
- runtime("PUTBACK;", "return 0;");
+ runtime("PUTBACK;", "return (PL_op)?PL_op->op_next:0;");
$know_op = 0;
return $op->next;
}
@@ -1344,7 +1356,7 @@ sub cc {
$need_freetmps = 0;
}
if (!$$op) {
- runtime("PUTBACK;", "return 0;");
+ runtime("PUTBACK;","return (PL_op)?PL_op->op_next:0;");
} elsif ($done{$$op}) {
runtime(sprintf("goto %s;", label($op)));
}
@@ -1375,6 +1387,7 @@ sub cc_obj {
sub cc_main {
my @comppadlist = comppadlist->ARRAY;
+ my $curpad_nam = $comppadlist[0]->save;
my $curpad_sym = $comppadlist[1]->save;
my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
save_unused_subs(@unused_sub_packages);
@@ -1384,7 +1397,9 @@ sub cc_main {
if (!defined($module)) {
$init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
"PL_main_start = $start;",
- "PL_curpad = AvARRAY($curpad_sym);");
+ "PL_curpad = AvARRAY($curpad_sym);",
+ "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
+ "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
}
output_boilerplate();
print "\n";
diff --git a/contrib/perl5/ext/B/B/Disassembler.pm b/contrib/perl5/ext/B/B/Disassembler.pm
index f26441d..4a008a3 100644
--- a/contrib/perl5/ext/B/B/Disassembler.pm
+++ b/contrib/perl5/ext/B/B/Disassembler.pm
@@ -77,7 +77,7 @@ sub GET_PV {
}
}
-sub GET_comment {
+sub GET_comment_t {
my $fh = shift;
my ($str, $c);
while (defined($c = $fh->getc) && $c ne "\n") {
diff --git a/contrib/perl5/ext/B/Makefile.PL b/contrib/perl5/ext/B/Makefile.PL
index cdcc4ed..80e5e1b 100644
--- a/contrib/perl5/ext/B/Makefile.PL
+++ b/contrib/perl5/ext/B/Makefile.PL
@@ -16,7 +16,7 @@ if ($^O eq 'MSWin32') {
WriteMakefile(
NAME => "B",
VERSION => "a5",
- MAN3PODS => ' ',
+ MAN3PODS => {},
clean => {
FILES => "perl$e byteperl$e *$o B.c *~"
}
diff --git a/contrib/perl5/ext/B/README b/contrib/perl5/ext/B/README
index 4e4ed25..fa3f085 100644
--- a/contrib/perl5/ext/B/README
+++ b/contrib/perl5/ext/B/README
@@ -20,8 +20,8 @@
in the file named "Artistic". If not, you can get one from the Perl
distribution. You should also have received a copy of the GNU General
Public License, in the file named "Copying". If not, you can get one
- from the Perl distribution or else write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ from the Perl distribution or else write to the Free Software Foundation,
+ Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
CHANGES
diff --git a/contrib/perl5/ext/DB_File/Changes b/contrib/perl5/ext/DB_File/Changes
index 993fe32..2fab919 100644
--- a/contrib/perl5/ext/DB_File/Changes
+++ b/contrib/perl5/ext/DB_File/Changes
@@ -203,3 +203,32 @@
1.60
Changed the test to check for full tied array support
+
+1.61 19th November 1998
+
+ Added a note to README about how to build Berkeley DB 2.x when
+ using HP-UX.
+ Minor modifications to get the module to build with DB 2.5.x
+ Fixed a typo in the definition of O_RDONLY, courtesy of Mark Kettenis.
+
+1.62 30th November 1998
+
+ Added hints/dynixptx.pl.
+ Fixed typemap -- 1.61 used PL_na instead of na
+
+1.63 19th December 1998
+
+ * Fix to allow DB 2.6.x to build with DB_File
+ * Documentation updated to use push,pop etc in the RECNO example &
+ to include the find_dup & del_dup methods.
+
+1.64 21st February 1999
+
+ * Tidied the 1.x to 2.x flag mapping code.
+ * Added a patch from Mark Kettenis <kettenis@wins.uva.nl> to fix a flag
+ mapping problem with O_RDONLY on the Hurd
+ * Updated the message that db-recno.t prints when tests 51, 53 or 55 fail.
+
+1.65 6th March 1999
+ * Fixed a bug in the recno PUSH logic.
+ * The BOOT version check now needs 2.3.4 when using Berkeley DB version 2
diff --git a/contrib/perl5/ext/DB_File/DB_File.pm b/contrib/perl5/ext/DB_File/DB_File.pm
index fcd0746..e5759ff 100644
--- a/contrib/perl5/ext/DB_File/DB_File.pm
+++ b/contrib/perl5/ext/DB_File/DB_File.pm
@@ -1,10 +1,10 @@
# DB_File.pm -- Perl 5 interface to Berkeley DB
#
-# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
-# last modified 16th May 1998
-# version 1.60
+# written by Paul Marquess (Paul.Marquess@btinternet.com)
+# last modified 6th March 1999
+# version 1.65
#
-# Copyright (c) 1995-8 Paul Marquess. All rights reserved.
+# Copyright (c) 1995-9 Paul Marquess. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
@@ -145,7 +145,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_ver
use Carp;
-$VERSION = "1.60" ;
+$VERSION = "1.65" ;
#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
$DB_BTREE = new DB_File::BTREEINFO ;
@@ -300,6 +300,40 @@ sub STORESIZE
}
}
+sub find_dup
+{
+ croak "Usage: \$db->find_dup(key,value)\n"
+ unless @_ == 3 ;
+
+ my $db = shift ;
+ my ($origkey, $value_wanted) = @_ ;
+ my ($key, $value) = ($origkey, 0);
+ my ($status) = 0 ;
+
+ for ($status = $db->seq($key, $value, R_CURSOR() ) ;
+ $status == 0 ;
+ $status = $db->seq($key, $value, R_NEXT() ) ) {
+
+ return 0 if $key eq $origkey and $value eq $value_wanted ;
+ }
+
+ return $status ;
+}
+
+sub del_dup
+{
+ croak "Usage: \$db->del_dup(key,value)\n"
+ unless @_ == 3 ;
+
+ my $db = shift ;
+ my ($key, $value) = @_ ;
+ my ($status) = $db->find_dup($key, $value) ;
+ return $status if $status != 0 ;
+
+ $status = $db->del($key, R_CURSOR() ) ;
+ return $status ;
+}
+
sub get_dup
{
croak "Usage: \$db->get_dup(key [,flag])\n"
@@ -364,6 +398,8 @@ DB_File - Perl5 access to Berkeley DB version 1.x
$count = $X->get_dup($key) ;
@list = $X->get_dup($key) ;
%list = $X->get_dup($key, 1) ;
+ $status = $X->find_dup($key, $value) ;
+ $status = $X->del_dup($key, $value) ;
# RECNO only
$a = $X->length;
@@ -443,11 +479,11 @@ is considered stable enough for real work.
B<Note:> The database file format has changed in Berkeley DB version 2.
If you cannot recreate your databases, you must dump any existing
databases with the C<db_dump185> utility that comes with Berkeley DB.
-Once you have upgraded DB_File to use Berkeley DB version 2, your
+Once you have rebuilt DB_File to use Berkeley DB version 2, your
databases can be recreated using C<db_load>. Refer to the Berkeley DB
documentation for further details.
-Please read L<COPYRIGHT> before using version 2.x of Berkeley DB with
+Please read L<"COPYRIGHT"> before using version 2.x of Berkeley DB with
DB_File.
=head2 Interface to Berkeley DB
@@ -837,9 +873,12 @@ that prints:
This time we have got all the key/value pairs, including the multiple
values associated with the key C<Wall>.
+To make life easier when dealing with duplicate keys, B<DB_File> comes with
+a few utility methods.
+
=head2 The get_dup() Method
-B<DB_File> comes with a utility method, called C<get_dup>, to assist in
+The C<get_dup> method assists in
reading duplicate values from BTREE databases. The method can take the
following forms:
@@ -888,6 +927,79 @@ and it will print:
Smith => [John]
Dog => []
+=head2 The find_dup() Method
+
+ $status = $X->find_dup($key, $value) ;
+
+This method checks for the existance of a specific key/value pair. If the
+pair exists, the cursor is left pointing to the pair and the method
+returns 0. Otherwise the method returns a non-zero value.
+
+Assuming the database from the previous example:
+
+ use strict ;
+ use DB_File ;
+
+ use vars qw($filename $x %h $found) ;
+
+ my $filename = "tree" ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
+ print "Larry Wall is $found there\n" ;
+
+ $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ;
+ print "Harry Wall is $found there\n" ;
+
+ undef $x ;
+ untie %h ;
+
+prints this
+
+ Larry Wall is there
+ Harry Wall is not there
+
+
+=head2 The del_dup() Method
+
+ $status = $X->del_dup($key, $value) ;
+
+This method deletes a specific key/value pair. It returns
+0 if they exist and have been deleted successfully.
+Otherwise the method returns a non-zero value.
+
+Again assuming the existance of the C<tree> database
+
+ use strict ;
+ use DB_File ;
+
+ use vars qw($filename $x %h $found) ;
+
+ my $filename = "tree" ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ $x->del_dup("Wall", "Larry") ;
+
+ $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ;
+ print "Larry Wall is $found there\n" ;
+
+ undef $x ;
+ untie %h ;
+
+prints this
+
+ Larry Wall is not there
+
=head2 Matching Partial Keys
The BTREE interface has a feature which allows partial keys to be
@@ -970,7 +1082,7 @@ Here is the output:
DB_RECNO provides an interface to flat text files. Both variable and
fixed length records are supported.
-In order to make RECNO more compatible with Perl the array offset for
+In order to make RECNO more compatible with Perl, the array offset for
all RECNO arrays begins at 0 rather than 1 as in Berkeley DB.
As with normal Perl arrays, a RECNO array can be accessed using
@@ -999,7 +1111,7 @@ error will be fixed in the next release of Berkeley DB.
That clarifies the situation with regards Berkeley DB itself. What
about B<DB_File>? Well, the behavior defined in the quote above is
-quite useful, so B<DB_File> conforms it.
+quite useful, so B<DB_File> conforms to it.
That means that you can specify other options (e.g. cachesize) and
still have bval default to C<"\n"> for variable length records, and
@@ -1007,7 +1119,9 @@ space for fixed length records.
=head2 A Simple Example
-Here is a simple example that uses RECNO.
+Here is a simple example that uses RECNO (if you are using a version
+of Perl earlier than 5.004_57 this example won't work -- see
+L<Extra RECNO Methods> for a workaround).
use strict ;
use DB_File ;
@@ -1021,6 +1135,18 @@ Here is a simple example that uses RECNO.
$h[1] = "blue" ;
$h[2] = "yellow" ;
+ push @h, "green", "black" ;
+
+ my $elements = scalar @h ;
+ print "The array contains $elements entries\n" ;
+
+ my $last = pop @h ;
+ print "popped $last\n" ;
+
+ unshift @h, "white" ;
+ my $first = shift @h ;
+ print "shifted $first\n" ;
+
# Check for existence of a key
print "Element 1 Exists with value $h[1]\n" if $h[1] ;
@@ -1032,17 +1158,19 @@ Here is a simple example that uses RECNO.
Here is the output from the script:
-
+ The array contains 5 entries
+ popped black
+ unshifted white
Element 1 Exists with value blue
- The last element is yellow
- The 2nd last element is blue
+ The last element is green
+ The 2nd last element is yellow
-=head2 Extra Methods
+=head2 Extra RECNO Methods
If you are using a version of Perl earlier than 5.004_57, the tied
-array interface is quite limited. The example script above will work,
-but you won't be able to use C<push>, C<pop>, C<shift>, C<unshift>
-etc. with the tied array.
+array interface is quite limited. In the example script above
+C<push>, C<pop>, C<shift>, C<unshift>
+or determining the array length will not work with a tied array.
To make the interface more useful for older versions of Perl, a number
of methods are supplied with B<DB_File> to simulate the missing array
@@ -1657,7 +1785,7 @@ compile properly on IRIX 5.3.
=head1 COPYRIGHT
-Copyright (c) 1995-8 Paul Marquess. All rights reserved. This program
+Copyright (c) 1995-9 Paul Marquess. All rights reserved. This program
is free software; you can redistribute it and/or modify it under the
same terms as Perl itself.
@@ -1688,7 +1816,7 @@ L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>
=head1 AUTHOR
The DB_File interface was written by Paul Marquess
-E<lt>pmarquess@bfsec.bt.co.ukE<gt>.
+E<lt>Paul.Marquess@btinternet.comE<gt>.
Questions about the DB system itself may be addressed to
E<lt>db@sleepycat.com<gt>.
diff --git a/contrib/perl5/ext/DB_File/DB_File.xs b/contrib/perl5/ext/DB_File/DB_File.xs
index c661023..94113eb 100644
--- a/contrib/perl5/ext/DB_File/DB_File.xs
+++ b/contrib/perl5/ext/DB_File/DB_File.xs
@@ -2,13 +2,13 @@
DB_File.xs -- Perl 5 interface to Berkeley DB
- written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
- last modified 16th May 1998
- version 1.60
+ written by Paul Marquess <Paul.Marquess@btinternet.com>
+ last modified 6th March 1999
+ version 1.65
All comments/suggestions/problems are welcome
- Copyright (c) 1995, 1996, 1997, 1998 Paul Marquess. All rights reserved.
+ Copyright (c) 1995-9 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
@@ -56,6 +56,15 @@
This was ok for DB 1.x, but isn't for DB 2.x.
1.59 - No change to DB_File.xs
1.60 - Some code tidy up
+ 1.61 - added flagSet macro for DB 2.5.x
+ fixed typo in O_RDONLY test.
+ 1.62 - No change to DB_File.xs
+ 1.63 - Fix to alllow DB 2.6.x to build.
+ 1.64 - Tidied up the 1.x to 2.x flags mapping code.
+ Added a patch from Mark Kettenis <kettenis@wins.uva.nl>
+ to fix a flag mapping problem with O_RDONLY on the Hurd
+ 1.65 - Fixed a bug in the PUSH logic.
+ Added BOOT check that using 2.3.4 or greater
@@ -65,6 +74,20 @@
#include "perl.h"
#include "XSUB.h"
+#ifndef PERL_VERSION
+#include "patchlevel.h"
+#define PERL_REVISION 5
+#define PERL_VERSION PATCHLEVEL
+#define PERL_SUBVERSION SUBVERSION
+#endif
+
+#if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 ))
+
+# define PL_sv_undef sv_undef
+# define PL_na na
+
+#endif
+
/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
* shortly #included by the <db.h>) __attribute__ to the possibly
* already defined __attribute__, for example by GNUC or by Perl. */
@@ -153,6 +176,12 @@ typedef db_recno_t recno_t;
#define DBT_flags(x) x.flags = 0
#define DB_flags(x, v) x |= v
+#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
+#define flagSet(flags, bitmask) ((flags) & (bitmask))
+#else
+#define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask))
+#endif
+
#else /* db version 1.x */
typedef union INFO {
@@ -205,6 +234,7 @@ typedef union INFO {
#define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag)
#define DBT_flags(x)
#define DB_flags(x, v)
+#define flagSet(flags, bitmask) ((flags) & (bitmask))
#endif /* db version 1 */
@@ -216,10 +246,11 @@ typedef union INFO {
#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
#define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
+
#ifdef DB_VERSION_MAJOR
#define db_DESTROY(db) ((db->dbp)->close)(db->dbp, 0)
#define db_close(db) ((db->dbp)->close)(db->dbp, 0)
-#define db_del(db, key, flags) ((flags & R_CURSOR) \
+#define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \
? ((db->cursor)->c_del)(db->cursor, 0) \
: ((db->dbp)->del)(db->dbp, NULL, &key, flags) )
@@ -232,6 +263,7 @@ typedef union INFO {
#endif
+
#define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags)
typedef struct {
@@ -288,12 +320,17 @@ u_int flags ;
{
int status ;
- if (flags & R_CURSOR) {
+ if (flagSet(flags, R_CURSOR)) {
status = ((db->cursor)->c_del)(db->cursor, 0);
if (status != 0)
return status ;
+#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5
flags &= ~R_CURSOR ;
+#else
+ flags &= ~DB_OPFLAGS_MASK ;
+#endif
+
}
return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ;
@@ -311,12 +348,12 @@ GetVersionInfo()
(void)db_version(&Major, &Minor, &Patch) ;
- /* check that libdb is recent enough */
- if (Major == 2 && Minor == 0 && Patch < 5)
- croak("DB_File needs Berkeley DB 2.0.5 or greater, you have %d.%d.%d\n",
+ /* check that libdb is recent enough -- we need 2.3.4 or greater */
+ if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4)))
+ croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n",
Major, Minor, Patch) ;
-#if PATCHLEVEL > 3
+#if PERL_VERSION > 3
sv_setpvf(ver_sv, "%d.%d", Major, Minor) ;
#else
{
@@ -577,6 +614,7 @@ SV * sv ;
DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
void * openinfo = NULL ;
INFO * info = &RETVAL->info ;
+ STRLEN n_a;
/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */
Zero(RETVAL, 1, DB_File_type) ;
@@ -718,11 +756,11 @@ SV * sv ;
#endif
svp = hv_fetch(action, "bfname", 6, FALSE);
if (svp && SvOK(*svp)) {
- char * ptr = SvPV(*svp,PL_na) ;
+ char * ptr = SvPV(*svp,n_a) ;
#ifdef DB_VERSION_MAJOR
- name = (char*) PL_na ? ptr : NULL ;
+ name = (char*) n_a ? ptr : NULL ;
#else
- info->db_RE_bfname = (char*) (PL_na ? ptr : NULL) ;
+ info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ;
#endif
}
else
@@ -738,7 +776,7 @@ SV * sv ;
{
int value ;
if (SvPOK(*svp))
- value = (int)*SvPV(*svp, PL_na) ;
+ value = (int)*SvPV(*svp, n_a) ;
else
value = SvIV(*svp) ;
@@ -756,7 +794,7 @@ SV * sv ;
if (svp && SvOK(*svp))
{
if (SvPOK(*svp))
- info->db_RE_bval = (u_char)*SvPV(*svp, PL_na) ;
+ info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ;
else
info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ;
DB_flags(info->flags, DB_DELIMITER) ;
@@ -800,26 +838,26 @@ SV * sv ;
if ((flags & O_CREAT) == O_CREAT)
Flags |= DB_CREATE ;
-#ifdef O_NONBLOCK
- if ((flags & O_NONBLOCK) == O_NONBLOCK)
- Flags |= DB_EXCL ;
-#endif
-
#if O_RDONLY == 0
if (flags == O_RDONLY)
#else
- if (flags & O_RDONLY) == O_RDONLY)
+ if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR)
#endif
Flags |= DB_RDONLY ;
-#ifdef O_NONBLOCK
+#ifdef O_TRUNC
if ((flags & O_TRUNC) == O_TRUNC)
Flags |= DB_TRUNCATE ;
#endif
status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ;
if (status == 0)
+#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ;
+#else
+ status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor,
+ 0) ;
+#endif
if (status)
RETVAL->dbp = NULL ;
@@ -1100,9 +1138,10 @@ db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_H
{
char * name = (char *) NULL ;
SV * sv = (SV *) NULL ;
+ STRLEN n_a;
if (items >= 3 && SvOK(ST(2)))
- name = (char*) SvPV(ST(2), PL_na) ;
+ name = (char*) SvPV(ST(2), n_a) ;
if (items == 6)
sv = ST(5) ;
@@ -1191,7 +1230,6 @@ db_FIRSTKEY(db)
{
DBTKEY key ;
DBT value ;
- DB * Db = db->dbp ;
DBT_flags(key) ;
DBT_flags(value) ;
@@ -1208,7 +1246,6 @@ db_NEXTKEY(db, key)
CODE:
{
DBT value ;
- DB * Db = db->dbp ;
DBT_flags(value) ;
CurrentDB = db ;
@@ -1232,6 +1269,7 @@ unshift(db, ...)
int i ;
int One ;
DB * Db = db->dbp ;
+ STRLEN n_a;
DBT_flags(key) ;
DBT_flags(value) ;
@@ -1245,8 +1283,8 @@ unshift(db, ...)
#endif
for (i = items-1 ; i > 0 ; --i)
{
- value.data = SvPV(ST(i), PL_na) ;
- value.size = PL_na ;
+ value.data = SvPV(ST(i), n_a) ;
+ value.size = n_a ;
One = 1 ;
key.data = &One ;
key.size = sizeof(int) ;
@@ -1270,7 +1308,6 @@ pop(db)
{
DBTKEY key ;
DBT value ;
- DB * Db = db->dbp ;
DBT_flags(key) ;
DBT_flags(value) ;
@@ -1298,7 +1335,6 @@ shift(db)
{
DBT value ;
DBTKEY key ;
- DB * Db = db->dbp ;
DBT_flags(key) ;
DBT_flags(value) ;
@@ -1325,42 +1361,42 @@ push(db, ...)
CODE:
{
DBTKEY key ;
- DBTKEY * keyptr = &key ;
DBT value ;
DB * Db = db->dbp ;
int i ;
+ STRLEN n_a;
DBT_flags(key) ;
DBT_flags(value) ;
CurrentDB = db ;
- /* Set the Cursor to the Last element */
- RETVAL = do_SEQ(db, key, value, R_LAST) ;
- if (RETVAL >= 0)
- {
- if (RETVAL == 1)
- keyptr = &empty ;
#ifdef DB_VERSION_MAJOR
+ RETVAL = 0 ;
+ key = empty ;
for (i = 1 ; i < items ; ++i)
{
-
- ++ (* (int*)key.data) ;
- value.data = SvPV(ST(i), PL_na) ;
- value.size = PL_na ;
- RETVAL = (Db->put)(Db, NULL, &key, &value, 0) ;
+ value.data = SvPV(ST(i), n_a) ;
+ value.size = n_a ;
+ RETVAL = (Db->put)(Db, NULL, &key, &value, DB_APPEND) ;
if (RETVAL != 0)
break;
}
#else
+ /* Set the Cursor to the Last element */
+ RETVAL = do_SEQ(db, key, value, R_LAST) ;
+ if (RETVAL >= 0)
+ {
+ if (RETVAL == 1)
+ key = empty ;
for (i = items - 1 ; i > 0 ; --i)
{
- value.data = SvPV(ST(i), PL_na) ;
- value.size = PL_na ;
- RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ;
+ value.data = SvPV(ST(i), n_a) ;
+ value.size = n_a ;
+ RETVAL = (Db->put)(Db, &key, &value, R_IAFTER) ;
if (RETVAL != 0)
break;
}
-#endif
}
+#endif
}
OUTPUT:
RETVAL
@@ -1436,7 +1472,7 @@ db_put(db, key, value, flags=0)
#endif
OUTPUT:
RETVAL
- key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);
+ key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key);
int
db_fd(db)
diff --git a/contrib/perl5/ext/DB_File/Makefile.PL b/contrib/perl5/ext/DB_File/Makefile.PL
index dbe19f1..1a13e0b 100644
--- a/contrib/perl5/ext/DB_File/Makefile.PL
+++ b/contrib/perl5/ext/DB_File/Makefile.PL
@@ -11,7 +11,7 @@ $LIB = "-llibdb" if $^O eq 'MSWin32' ;
WriteMakefile(
NAME => 'DB_File',
LIBS => ["-L/usr/local/lib $LIB"],
- MAN3PODS => ' ', # Pods will be built by installman.
+ MAN3PODS => {}, # Pods will be built by installman.
#INC => '-I/usr/local/include',
VERSION_FROM => 'DB_File.pm',
XSPROTOARG => '-noprototypes',
diff --git a/contrib/perl5/ext/DB_File/dbinfo b/contrib/perl5/ext/DB_File/dbinfo
index 9640ba4..24a7944 100644
--- a/contrib/perl5/ext/DB_File/dbinfo
+++ b/contrib/perl5/ext/DB_File/dbinfo
@@ -3,7 +3,7 @@
# Name: dbinfo -- identify berkeley DB version used to create
# a database file
#
-# Author: Paul Marquess
+# Author: Paul Marquess <Paul.Marquess@btinternet.com>
# Version: 1.01
# Date 16th April 1998
#
diff --git a/contrib/perl5/ext/DB_File/hints/dynixptx.pl b/contrib/perl5/ext/DB_File/hints/dynixptx.pl
new file mode 100644
index 0000000..bb5ffa5
--- /dev/null
+++ b/contrib/perl5/ext/DB_File/hints/dynixptx.pl
@@ -0,0 +1,3 @@
+# Need to add an extra '-lc' to the end to work around a DYNIX/ptx bug
+
+$self->{LIBS} = ['-lm -lc'];
diff --git a/contrib/perl5/ext/DB_File/typemap b/contrib/perl5/ext/DB_File/typemap
index 7af55ae..994ba27 100644
--- a/contrib/perl5/ext/DB_File/typemap
+++ b/contrib/perl5/ext/DB_File/typemap
@@ -1,8 +1,8 @@
# typemap for Perl 5 interface to Berkeley
#
-# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
-# last modified 13th May 1998
-# version 1.59
+# written by Paul Marquess <Paul.Marquess@btinternet.com>
+# last modified 21st February 1999
+# version 1.65
#
#################################### DB SECTION
#
diff --git a/contrib/perl5/ext/Data/Dumper/Changes b/contrib/perl5/ext/Data/Dumper/Changes
index a164958..9a96eda 100644
--- a/contrib/perl5/ext/Data/Dumper/Changes
+++ b/contrib/perl5/ext/Data/Dumper/Changes
@@ -6,6 +6,24 @@ HISTORY - public release history for Data::Dumper
=over 8
+=item 2.10 (31 Oct 1998)
+
+Bugfixes for dumping related undef values, globs, and better double
+quoting: three patches suggested by Gisle Aas <gisle@aas.no>.
+
+Escaping of single quotes in the XS version could get tripped up
+by the presence of nulls in the string. Fix suggested by
+Slaven Rezic <eserte@cs.tu-berlin.de>.
+
+Rather large scale reworking of the logic in how seen values
+are stashed. Anonymous scalars that may be encountered while
+traversing the structure are properly tracked, in case they become
+used in data dumped in a later pass. There used to be a problem
+with the previous logic that prevented such structures from being
+dumped correctly.
+
+Various additions to the testsuite.
+
=item 2.09 (9 July 1998)
Implement $Data::Dumper::Bless, suggested by Mark Daku <daku@nortel.ca>.
diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.pm b/contrib/perl5/ext/Data/Dumper/Dumper.pm
index e3c361f..b1fd2b7 100644
--- a/contrib/perl5/ext/Data/Dumper/Dumper.pm
+++ b/contrib/perl5/ext/Data/Dumper/Dumper.pm
@@ -9,7 +9,7 @@
package Data::Dumper;
-$VERSION = $VERSION = '2.09';
+$VERSION = $VERSION = '2.101';
#$| = 1;
@@ -208,8 +208,6 @@ sub _dump {
my($sname);
my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad);
- return "undef" unless defined $val;
-
$type = ref $val;
$out = "";
@@ -218,47 +216,47 @@ sub _dump {
# prep it, if it looks like an object
if ($type =~ /[a-z_:]/) {
my $freezer = $s->{freezer};
- # UNIVERSAL::can should be used here, when we can require 5.004
- if ($freezer) {
- eval { $val->$freezer() };
- carp "WARNING(Freezer method call failed): $@" if $@;
- }
+ $val->$freezer() if $freezer && UNIVERSAL::can($val, $freezer);
}
($realpack, $realtype, $id) =
(overload::StrVal($val) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/);
- # keep a tab on it so that we dont fall into recursive pit
- if (exists $s->{seen}{$id}) {
-# if ($s->{expdepth} < $s->{level}) {
- if ($s->{purity} and $s->{level} > 0) {
- $out = ($realtype eq 'HASH') ? '{}' :
- ($realtype eq 'ARRAY') ? '[]' :
- "''" ;
- push @post, $name . " = " . $s->{seen}{$id}[0];
- }
- else {
- $out = $s->{seen}{$id}[0];
- if ($name =~ /^([\@\%])/) {
- my $start = $1;
- if ($out =~ /^\\$start/) {
- $out = substr($out, 1);
+ # if it has a name, we need to either look it up, or keep a tab
+ # on it so we know when we hit it later
+ if (defined($name) and length($name)) {
+ # keep a tab on it so that we dont fall into recursive pit
+ if (exists $s->{seen}{$id}) {
+# if ($s->{expdepth} < $s->{level}) {
+ if ($s->{purity} and $s->{level} > 0) {
+ $out = ($realtype eq 'HASH') ? '{}' :
+ ($realtype eq 'ARRAY') ? '[]' :
+ "''" ;
+ push @post, $name . " = " . $s->{seen}{$id}[0];
}
else {
- $out = $start . '{' . $out . '}';
- }
- }
+ $out = $s->{seen}{$id}[0];
+ if ($name =~ /^([\@\%])/) {
+ my $start = $1;
+ if ($out =~ /^\\$start/) {
+ $out = substr($out, 1);
+ }
+ else {
+ $out = $start . '{' . $out . '}';
+ }
+ }
+ }
+ return $out;
+# }
+ }
+ else {
+ # store our name
+ $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) :
+ ($realtype eq 'CODE' and
+ $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) :
+ $name ),
+ $val ];
}
- return $out;
-# }
- }
- else {
- # store our name
- $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) :
- ($realtype eq 'CODE' and
- $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) :
- $name ),
- $val ];
}
$s->{level}++;
@@ -272,14 +270,14 @@ sub _dump {
if ($realtype eq 'SCALAR') {
if ($realpack) {
- $out .= 'do{\\(my $o = ' . $s->_dump($$val, "") . ')}';
+ $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}';
}
else {
- $out .= '\\' . $s->_dump($$val, "");
+ $out .= '\\' . $s->_dump($$val, "\${$name}");
}
}
elsif ($realtype eq 'GLOB') {
- $out .= '\\' . $s->_dump($$val, "");
+ $out .= '\\' . $s->_dump($$val, "*{$name}");
}
elsif ($realtype eq 'ARRAY') {
my($v, $pad, $mname);
@@ -287,7 +285,9 @@ sub _dump {
$out .= ($name =~ /^\@/) ? '(' : '[';
$pad = $s->{sep} . $s->{pad} . $s->{apad};
($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) :
- ($name =~ /[]}]$/) ? ($mname = $name) : ($mname = $name . '->');
+ # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
+ ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
+ ($mname = $name . '->');
$mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
for $v (@$val) {
$sname = $mname . '[' . $i . ']';
@@ -303,8 +303,10 @@ sub _dump {
$out .= ($name =~ /^\%/) ? '(' : '{';
$pad = $s->{sep} . $s->{pad} . $s->{apad};
$lpad = $s->{apad};
- ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) :
- ($name =~ /[]}]$/) ? ($mname = $name) : ($mname = $name . '->');
+ ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) :
+ # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
+ ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
+ ($mname = $name . '->');
$mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
while (($k, $v) = each %$val) {
my $nk = $s->_dump($k, "");
@@ -324,8 +326,7 @@ sub _dump {
$out .= ($name =~ /^\%/) ? ')' : '}';
}
elsif ($realtype eq 'CODE') {
- $out .= '"DUMMY"';
- $out = 'sub { ' . $out . ' }';
+ $out .= 'sub { "DUMMY" }';
carp "Encountered CODE ref, using dummy placeholder" if $s->{purity};
}
else {
@@ -347,11 +348,15 @@ sub _dump {
if ($name ne '') {
($id) = ("$ref" =~ /\(([^\(]*)\)$/);
if (exists $s->{seen}{$id}) {
- $out = $s->{seen}{$id}[0];
- return $out;
+ if ($s->{seen}{$id}[2]) {
+ $out = $s->{seen}{$id}[0];
+ #warn "[<$out]\n";
+ return "\${$out}";
+ }
}
else {
- $s->{seen}{$id} = ["\\$name", $val];
+ #warn "[>\\$name]\n";
+ $s->{seen}{$id} = ["\\$name", $ref];
}
}
if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) { # glob
@@ -368,21 +373,28 @@ sub _dump {
my $k;
local ($s->{level}) = 0;
for $k (qw(SCALAR ARRAY HASH)) {
+ my $gval = *$val{$k};
+ next unless defined $gval;
+ next if $k eq "SCALAR" && ! defined $$gval; # always there
+
# _dump can push into @post, so we hold our place using $postlen
my $postlen = scalar @post;
$post[$postlen] = "\*$sname = ";
local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2;
- $post[$postlen] .= $s->_dump(*{$name}{$k}, "\*$sname\{$k\}");
+ $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}");
}
}
$out .= '*' . $sname;
}
+ elsif (!defined($val)) {
+ $out .= "undef";
+ }
elsif ($val =~ /^-?[1-9]\d{0,8}$/) { # safe decimal number
$out .= $val;
}
else { # string
if ($s->{useqq}) {
- $out .= qquote($val);
+ $out .= qquote($val, $s->{useqq});
}
else {
$val =~ s/([\\\'])/\\$1/g;
@@ -390,10 +402,16 @@ sub _dump {
}
}
}
-
- # if we made it this far, $id was added to seen list at current
- # level, so remove it to get deep copies
- delete($s->{seen}{$id}) if $id and $s->{deepcopy};
+ if ($id) {
+ # if we made it this far, $id was added to seen list at current
+ # level, so remove it to get deep copies
+ if ($s->{deepcopy}) {
+ delete($s->{seen}{$id});
+ }
+ elsif ($name) {
+ $s->{seen}{$id}[2] = 1;
+ }
+ }
return $out;
}
@@ -493,22 +511,41 @@ sub Bless {
defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'};
}
+# used by qquote below
+my %esc = (
+ "\a" => "\\a",
+ "\b" => "\\b",
+ "\t" => "\\t",
+ "\n" => "\\n",
+ "\f" => "\\f",
+ "\r" => "\\r",
+ "\e" => "\\e",
+);
+
# put a string value in double quotes
sub qquote {
local($_) = shift;
- s/([\\\"\@\$\%])/\\$1/g;
- s/\a/\\a/g;
- s/[\b]/\\b/g;
- s/\t/\\t/g;
- s/\n/\\n/g;
- s/\f/\\f/g;
- s/\r/\\r/g;
- s/\e/\\e/g;
-
-# this won't work!
-# s/([^\a\b\t\n\f\r\e\038-\176])/'\\'.sprintf('%03o',ord($1))/eg;
- s/([\000-\006\013\016-\032\034-\037\177\200-\377])/'\\'.sprintf('%03o',ord($1))/eg;
- return "\"$_\"";
+ s/([\\\"\@\$])/\\$1/g;
+ return qq("$_") unless /[^\040-\176]/; # fast exit
+
+ my $high = shift || "";
+ s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
+
+ # no need for 3 digits in escape for these
+ s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg;
+
+ s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg;
+ if ($high eq "iso8859") {
+ s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
+ } elsif ($high eq "utf8") {
+# use utf8;
+# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
+ } elsif ($high eq "8bit") {
+ # leave it as it is
+ } else {
+ s/([\0-\037\177-\377])/'\\'.sprintf('%03o',ord($1))/eg;
+ }
+ return qq("$_");
}
1;
@@ -954,7 +991,7 @@ modify it under the same terms as Perl itself.
=head1 VERSION
-Version 2.09 (9 July 1998)
+Version 2.10 (31 Oct 1998)
=head1 SEE ALSO
diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.xs b/contrib/perl5/ext/Data/Dumper/Dumper.xs
index d8012ee..a3da110 100644
--- a/contrib/perl5/ext/Data/Dumper/Dumper.xs
+++ b/contrib/perl5/ext/Data/Dumper/Dumper.xs
@@ -2,8 +2,19 @@
#include "perl.h"
#include "XSUB.h"
-static SV *freezer;
-static SV *toaster;
+#include "patchlevel.h"
+
+#if PATCHLEVEL < 5
+# ifndef PL_sv_undef
+# define PL_sv_undef sv_undef
+# endif
+# ifndef ERRSV
+# define ERRSV GvSV(errgv)
+# endif
+# ifndef newSVpvn
+# define newSVpvn newSVpv
+# endif
+#endif
static I32 num_q _((char *s, STRLEN slen));
static I32 esc_q _((char *dest, char *src, STRLEN slen));
@@ -84,7 +95,7 @@ static SV *
sv_x(SV *sv, register char *str, STRLEN len, I32 n)
{
if (sv == Nullsv)
- sv = newSVpv("", 0);
+ sv = newSVpvn("", 0);
else
assert(SvTYPE(sv) >= SVt_PV);
@@ -121,11 +132,9 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
U32 i;
char *c, *r, *realpack, id[128];
SV **svp;
- SV *sv;
+ SV *sv, *ipad, *ival;
SV *blesspad = Nullsv;
- SV *ipad;
- SV *ival;
- AV *seenentry;
+ AV *seenentry = Nullav;
char *iname;
STRLEN inamelen, idlen = 0;
U32 flags;
@@ -139,10 +148,6 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
if (SvGMAGICAL(val))
mg_get(val);
- if (val == &PL_sv_undef || !SvOK(val)) {
- sv_catpvn(retval, "undef", 5);
- return 1;
- }
if (SvROK(val)) {
if (SvOBJECT(SvRV(val)) && freezer &&
@@ -152,9 +157,9 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
XPUSHs(val); PUTBACK;
i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR);
SPAGAIN;
- if (SvTRUE(GvSV(PL_errgv)))
+ if (SvTRUE(ERRSV))
warn("WARNING(Freezer method call failed): %s",
- SvPVX(GvSV(PL_errgv)));
+ SvPVX(ERRSV));
else if (i)
val = newSVsv(POPs);
PUTBACK; FREETMPS; LEAVE;
@@ -171,67 +176,77 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
realpack = HvNAME(SvSTASH(ival));
else
realpack = Nullch;
- if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
- (sv = *svp) && SvROK(sv) &&
- (seenentry = (AV*)SvRV(sv))) {
- SV *othername;
- if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) {
- if (purity && *levelp > 0) {
- SV *postentry;
-
- if (realtype == SVt_PVHV)
- sv_catpvn(retval, "{}", 2);
- else if (realtype == SVt_PVAV)
- sv_catpvn(retval, "[]", 2);
- else
- sv_catpvn(retval, "''", 2);
- postentry = newSVpv(name, namelen);
- sv_catpvn(postentry, " = ", 3);
- sv_catsv(postentry, othername);
- av_push(postav, postentry);
- }
- else {
- if (name[0] == '@' || name[0] == '%') {
- if ((SvPVX(othername))[0] == '\\' &&
- (SvPVX(othername))[1] == name[0]) {
- sv_catpvn(retval, SvPVX(othername)+1, SvCUR(othername)-1);
+
+ /* if it has a name, we need to either look it up, or keep a tab
+ * on it so we know when we hit it later
+ */
+ if (namelen) {
+ if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
+ && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
+ {
+ SV *othername;
+ if ((svp = av_fetch(seenentry, 0, FALSE))
+ && (othername = *svp))
+ {
+ if (purity && *levelp > 0) {
+ SV *postentry;
+
+ if (realtype == SVt_PVHV)
+ sv_catpvn(retval, "{}", 2);
+ else if (realtype == SVt_PVAV)
+ sv_catpvn(retval, "[]", 2);
+ else
+ sv_catpvn(retval, "''", 2);
+ postentry = newSVpvn(name, namelen);
+ sv_catpvn(postentry, " = ", 3);
+ sv_catsv(postentry, othername);
+ av_push(postav, postentry);
+ }
+ else {
+ if (name[0] == '@' || name[0] == '%') {
+ if ((SvPVX(othername))[0] == '\\' &&
+ (SvPVX(othername))[1] == name[0]) {
+ sv_catpvn(retval, SvPVX(othername)+1,
+ SvCUR(othername)-1);
+ }
+ else {
+ sv_catpvn(retval, name, 1);
+ sv_catpvn(retval, "{", 1);
+ sv_catsv(retval, othername);
+ sv_catpvn(retval, "}", 1);
+ }
}
- else {
- sv_catpvn(retval, name, 1);
- sv_catpvn(retval, "{", 1);
+ else
sv_catsv(retval, othername);
- sv_catpvn(retval, "}", 1);
- }
}
- else
- sv_catsv(retval, othername);
+ return 1;
+ }
+ else {
+ warn("ref name not found for %s", id);
+ return 0;
}
- return 1;
- }
- else {
- warn("ref name not found for %s", id);
- return 0;
- }
- }
- else { /* store our name and continue */
- SV *namesv;
- if (name[0] == '@' || name[0] == '%') {
- namesv = newSVpv("\\", 1);
- sv_catpvn(namesv, name, namelen);
}
- else if (realtype == SVt_PVCV && name[0] == '*') {
- namesv = newSVpv("\\", 2);
- sv_catpvn(namesv, name, namelen);
- (SvPVX(namesv))[1] = '&';
+ else { /* store our name and continue */
+ SV *namesv;
+ if (name[0] == '@' || name[0] == '%') {
+ namesv = newSVpvn("\\", 1);
+ sv_catpvn(namesv, name, namelen);
+ }
+ else if (realtype == SVt_PVCV && name[0] == '*') {
+ namesv = newSVpvn("\\", 2);
+ sv_catpvn(namesv, name, namelen);
+ (SvPVX(namesv))[1] = '&';
+ }
+ else
+ namesv = newSVpvn(name, namelen);
+ seenentry = newAV();
+ av_push(seenentry, namesv);
+ (void)SvREFCNT_inc(val);
+ av_push(seenentry, val);
+ (void)hv_store(seenhv, id, strlen(id),
+ newRV((SV*)seenentry), 0);
+ SvREFCNT_dec(seenentry);
}
- else
- namesv = newSVpv(name, namelen);
- seenentry = newAV();
- av_push(seenentry, namesv);
- (void)SvREFCNT_inc(val);
- av_push(seenentry, val);
- (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
- SvREFCNT_dec(seenentry);
}
(*levelp)++;
@@ -249,20 +264,34 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
}
}
- if (realtype <= SVt_PVBM || realtype == SVt_PVGV) { /* scalars */
- if (realpack && realtype != SVt_PVGV) { /* blessed */
+ if (realtype <= SVt_PVBM) { /* scalar ref */
+ SV *namesv = newSVpvn("${", 2);
+ sv_catpvn(namesv, name, namelen);
+ sv_catpvn(namesv, "}", 1);
+ if (realpack) { /* blessed */
sv_catpvn(retval, "do{\\(my $o = ", 13);
- DD_dump(ival, "", 0, retval, seenhv, postav,
- levelp, indent, pad, xpad, apad, sep,
+ DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
+ postav, levelp, indent, pad, xpad, apad, sep,
freezer, toaster, purity, deepcopy, quotekeys, bless);
sv_catpvn(retval, ")}", 2);
- }
+ } /* plain */
else {
sv_catpvn(retval, "\\", 1);
- DD_dump(ival, "", 0, retval, seenhv, postav,
- levelp, indent, pad, xpad, apad, sep,
+ DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
+ postav, levelp, indent, pad, xpad, apad, sep,
freezer, toaster, purity, deepcopy, quotekeys, bless);
}
+ SvREFCNT_dec(namesv);
+ }
+ else if (realtype == SVt_PVGV) { /* glob ref */
+ SV *namesv = newSVpvn("*{", 2);
+ sv_catpvn(namesv, name, namelen);
+ sv_catpvn(namesv, "}", 1);
+ sv_catpvn(retval, "\\", 1);
+ DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
+ postav, levelp, indent, pad, xpad, apad, sep,
+ freezer, toaster, purity, deepcopy, quotekeys, bless);
+ SvREFCNT_dec(namesv);
}
else if (realtype == SVt_PVAV) {
SV *totpad;
@@ -280,7 +309,16 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
}
else {
sv_catpvn(retval, "[", 1);
- if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') {
+ /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
+ /*if (namelen > 0
+ && name[namelen-1] != ']' && name[namelen-1] != '}'
+ && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
+ if ((namelen > 0
+ && name[namelen-1] != ']' && name[namelen-1] != '}')
+ || (namelen > 4
+ && (name[1] == '{'
+ || (name[0] == '\\' && name[2] == '{'))))
+ {
iname[inamelen++] = '-'; iname[inamelen++] = '>';
iname[inamelen] = '\0';
}
@@ -346,14 +384,20 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
I32 klen;
SV *hval;
- iname = newSVpv(name, namelen);
+ iname = newSVpvn(name, namelen);
if (name[0] == '%') {
sv_catpvn(retval, "(", 1);
(SvPVX(iname))[0] = '$';
}
else {
sv_catpvn(retval, "{", 1);
- if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') {
+ /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
+ if ((namelen > 0
+ && name[namelen-1] != ']' && name[namelen-1] != '}')
+ || (namelen > 4
+ && (name[1] == '{'
+ || (name[0] == '\\' && name[2] == '{'))))
+ {
sv_catpvn(iname, "->", 2);
}
}
@@ -472,33 +516,36 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
(void) sprintf(id, "0x%lx", (unsigned long)val);
if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
(sv = *svp) && SvROK(sv) &&
- (seenentry = (AV*)SvRV(sv))) {
+ (seenentry = (AV*)SvRV(sv)))
+ {
SV *othername;
- if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) {
+ if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
+ && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
+ {
+ sv_catpvn(retval, "${", 2);
sv_catsv(retval, othername);
+ sv_catpvn(retval, "}", 1);
return 1;
}
}
else {
SV *namesv;
- namesv = newSVpv("\\", 1);
+ namesv = newSVpvn("\\", 1);
sv_catpvn(namesv, name, namelen);
seenentry = newAV();
av_push(seenentry, namesv);
- (void)SvREFCNT_inc(val);
- av_push(seenentry, val);
+ av_push(seenentry, newRV(val));
(void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
SvREFCNT_dec(seenentry);
}
}
-
+
if (SvIOK(val)) {
STRLEN len;
i = SvIV(val);
(void) sprintf(tmpbuf, "%d", i);
len = strlen(tmpbuf);
sv_catpvn(retval, tmpbuf, len);
- return 1;
}
else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
c = SvPV(val, i);
@@ -522,21 +569,27 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
r[0] = '*'; strcpy(r+1, c);
i++;
}
+ SvCUR_set(retval, SvCUR(retval)+i);
if (purity) {
static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
static STRLEN sizes[] = { 8, 7, 6 };
SV *e;
- SV *nname = newSVpv("", 0);
- SV *newapad = newSVpv("", 0);
+ SV *nname = newSVpvn("", 0);
+ SV *newapad = newSVpvn("", 0);
GV *gv = (GV*)val;
I32 j;
for (j=0; j<3; j++) {
e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
- if (e) {
+ if (!e)
+ continue;
+ if (j == 0 && !SvOK(e))
+ continue;
+
+ {
I32 nlevel = 0;
- SV *postentry = newSVpv(r,i);
+ SV *postentry = newSVpvn(r,i);
sv_setsv(nname, postentry);
sv_catpvn(nname, entries[j], sizes[j]);
@@ -560,6 +613,9 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
SvREFCNT_dec(nname);
}
}
+ else if (val == &PL_sv_undef || !SvOK(val)) {
+ sv_catpvn(retval, "undef", 5);
+ }
else {
c = SvPV(val, i);
sv_grow(retval, SvCUR(retval)+3+2*i);
@@ -569,13 +625,18 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
++i;
r[i++] = '\'';
r[i] = '\0';
+ SvCUR_set(retval, SvCUR(retval)+i);
}
- SvCUR_set(retval, SvCUR(retval)+i);
}
- if (deepcopy && idlen)
- (void)hv_delete(seenhv, id, idlen, G_DISCARD);
-
+ if (idlen) {
+ if (deepcopy)
+ (void)hv_delete(seenhv, id, idlen, G_DISCARD);
+ else if (namelen && seenentry) {
+ SV *mark = *av_fetch(seenentry, 2, TRUE);
+ sv_setiv(mark,1);
+ }
+ }
return 1;
}
@@ -647,7 +708,7 @@ Data_Dumper_Dumpxs(href, ...)
terse = useqq = purity = deepcopy = 0;
quotekeys = 1;
- retval = newSVpv("", 0);
+ retval = newSVpvn("", 0);
if (SvROK(href)
&& (hv = (HV*)SvRV((SV*)href))
&& SvTYPE(hv) == SVt_PVHV) {
@@ -692,7 +753,7 @@ Data_Dumper_Dumpxs(href, ...)
imax = av_len(todumpav);
else
imax = -1;
- valstr = newSVpv("",0);
+ valstr = newSVpvn("",0);
for (i = 0; i <= imax; ++i) {
SV *newapad;
@@ -787,7 +848,7 @@ Data_Dumper_Dumpxs(href, ...)
if (gimme == G_ARRAY) {
XPUSHs(sv_2mortal(retval));
if (i < imax) /* not the last time thro ? */
- retval = newSVpv("",0);
+ retval = newSVpvn("",0);
}
}
SvREFCNT_dec(postav);
diff --git a/contrib/perl5/ext/Data/Dumper/Makefile.PL b/contrib/perl5/ext/Data/Dumper/Makefile.PL
index 6c94e95d..12930c5 100644
--- a/contrib/perl5/ext/Data/Dumper/Makefile.PL
+++ b/contrib/perl5/ext/Data/Dumper/Makefile.PL
@@ -7,5 +7,5 @@ WriteMakefile(
SUFFIX => 'gz',
DIST_DEFAULT => 'all tardist',
},
- MAN3PODS => ' ',
+ MAN3PODS => {},
);
diff --git a/contrib/perl5/ext/Data/Dumper/Todo b/contrib/perl5/ext/Data/Dumper/Todo
index 4a41f97..7dcd40b 100644
--- a/contrib/perl5/ext/Data/Dumper/Todo
+++ b/contrib/perl5/ext/Data/Dumper/Todo
@@ -29,4 +29,6 @@ where we don't care so much for cross-references).
=item Implement redesign that allows various backends (Perl, Lisp,
some-binary-data-format, graph-description-languages, etc.)
+=item Dump traversal in breadth-first order
+
=back
diff --git a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL
index 4c41559..cf7d708 100644
--- a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL
+++ b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL
@@ -101,7 +101,8 @@ push(@dl_library_path, split(/:/, $ENV{LD_LIBRARY_PATH}))
# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
-boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader);
+boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
+ !defined(&dl_load_file);
if ($dl_debug) {
diff --git a/contrib/perl5/ext/DynaLoader/Makefile.PL b/contrib/perl5/ext/DynaLoader/Makefile.PL
index 7a75115..2141fde 100644
--- a/contrib/perl5/ext/DynaLoader/Makefile.PL
+++ b/contrib/perl5/ext/DynaLoader/Makefile.PL
@@ -4,7 +4,7 @@ WriteMakefile(
NAME => 'DynaLoader',
LINKTYPE => 'static',
DEFINE => '-DPERL_CORE -DLIBC="$(LIBC)"',
- MAN3PODS => ' ', # Pods will be built by installman.
+ MAN3PODS => {}, # Pods will be built by installman.
SKIP => [qw(dynamic dynamic_lib dynamic_bs)],
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'DynaLoader_pm.PL',
diff --git a/contrib/perl5/ext/DynaLoader/dl_beos.xs b/contrib/perl5/ext/DynaLoader/dl_beos.xs
new file mode 100644
index 0000000..42a27cb
--- /dev/null
+++ b/contrib/perl5/ext/DynaLoader/dl_beos.xs
@@ -0,0 +1,115 @@
+/*
+ * dl_beos.xs, by Tom Spindler
+ * based on dl_dlopen.xs, by Paul Marquess
+ * $Id:$
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include <be/kernel/image.h>
+#include <OS.h>
+#include <stdlib.h>
+#include <limits.h>
+
+#define dlerror() strerror(errno)
+
+#include "dlutils.c" /* SaveError() etc */
+
+static void
+dl_private_init()
+{
+ (void)dl_generic_private_init();
+}
+
+MODULE = DynaLoader PACKAGE = DynaLoader
+
+BOOT:
+ (void)dl_private_init();
+
+
+void *
+dl_load_file(filename, flags=0)
+ char * filename
+ int flags
+ CODE:
+{ image_id bogo;
+ char *path;
+ path = malloc(PATH_MAX);
+ if (*filename != '/') {
+ getcwd(path, PATH_MAX);
+ strcat(path, "/");
+ strcat(path, filename);
+ } else {
+ strcpy(path, filename);
+ }
+
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", path, flags));
+ bogo = load_add_on(path);
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%lx\n", (unsigned long) RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (bogo < 0) {
+ SaveError("%s", strerror(bogo));
+ PerlIO_printf(PerlIO_stderr(), "load_add_on(%s) : %d (%s)\n", path, bogo, strerror(bogo));
+ } else {
+ RETVAL = (void *) bogo;
+ sv_setiv( ST(0), (IV)RETVAL);
+ }
+ free(path);
+}
+
+void *
+dl_find_symbol(libhandle, symbolname)
+ void * libhandle
+ char * symbolname
+ CODE:
+ status_t retcode;
+ void *adr = 0;
+#ifdef DLSYM_NEEDS_UNDERSCORE
+ symbolname = form("_%s", symbolname);
+#endif
+ RETVAL = NULL;
+ DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+ "dl_find_symbol(handle=%lx, symbol=%s)\n",
+ (unsigned long) libhandle, symbolname));
+ retcode = get_image_symbol((image_id) libhandle, symbolname,
+ B_SYMBOL_TYPE_TEXT, (void **) &adr);
+ RETVAL = adr;
+ DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+ " symbolref = %lx\n", (unsigned long) RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (RETVAL == NULL) {
+ SaveError("%s", strerror(retcode)) ;
+ PerlIO_printf(PerlIO_stderr(), "retcode = %p (%s)\n", retcode, strerror(retcode));
+ } else
+ sv_setiv( ST(0), (IV)RETVAL);
+
+
+void
+dl_undef_symbols()
+ PPCODE:
+
+
+
+# These functions should not need changing on any platform:
+
+void
+dl_install_xsub(perl_name, symref, filename="$Package")
+ char * perl_name
+ void * symref
+ char * filename
+ CODE:
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%lx)\n",
+ perl_name, (unsigned long) symref));
+ ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)_((CV *)))symref, filename)));
+
+
+char *
+dl_error()
+ CODE:
+ RETVAL = LastError ;
+ OUTPUT:
+ RETVAL
+
+# end.
diff --git a/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs b/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs
index 2b75637..b64ab3e 100644
--- a/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs
+++ b/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs
@@ -82,11 +82,11 @@ dl_load_file(filename,flags=0)
int flags
PREINIT:
CODE:
- DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename));
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(),"dl_load_file(%s):\n", filename));
RETVAL = (void*) LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ;
- DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," libref=%x\n", RETVAL));
ST(0) = sv_newmortal() ;
if (RETVAL == NULL){
SaveError("%d",GetLastError()) ;
@@ -113,10 +113,10 @@ dl_find_symbol(libhandle, symbolname)
void * libhandle
char * symbolname
CODE:
- DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n",
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_find_symbol(handle=%x, symbol=%s)\n",
libhandle, symbolname));
RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname);
- DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," symbolref = %x\n", RETVAL));
ST(0) = sv_newmortal() ;
if (RETVAL == NULL)
SaveError("%d",GetLastError()) ;
@@ -138,7 +138,7 @@ dl_install_xsub(perl_name, symref, filename="$Package")
void * symref
char * filename
CODE:
- DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n",
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_install_xsub(name=%s, symref=%x)\n",
perl_name, symref));
ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
diff --git a/contrib/perl5/ext/DynaLoader/dl_mpeix.xs b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs
index 808c3b0..4cc07ec 100644
--- a/contrib/perl5/ext/DynaLoader/dl_mpeix.xs
+++ b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs
@@ -2,6 +2,7 @@
* Author: Mark Klein (mklein@dis.com)
* Version: 2.1, 1996/07/25
* Version: 2.2, 1997/09/25 Mark Bixby (markb@cccd.edu)
+ * Version: 2.3, 1998/11/19 Mark Bixby (markb@cccd.edu)
*/
#include "EXTERN.h"
@@ -59,13 +60,13 @@ flags));
",filename);
obj = (p_mpe_dld) safemalloc(sizeof(t_mpe_dld));
memzero(obj, sizeof(t_mpe_dld));
- if (filename[0] == '.')
+ if (filename[0] != '/')
{
getcwd(buf,sizeof(buf));
- sprintf(obj->filename,"$%s/%s$",buf,filename);
+ sprintf(obj->filename," %s/%s ",buf,filename);
}
else
- sprintf(obj->filename,"$%s$",filename);
+ sprintf(obj->filename," %s ",filename);
DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," libref=%x\n", obj));
@@ -90,11 +91,11 @@ dl_find_symbol(libhandle, symbolname)
ST(0) = sv_newmortal() ;
errno = 0;
- sprintf(symname, "$%s$", symbolname);
+ sprintf(symname, " %s ", symbolname);
HPGETPROCPLABEL(8, symname, &symaddr, &status, obj->filename, 1,
0, &datalen, 1, 0, 0);
- DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," symbolref(PROCEDURE) = %x\n", symaddr));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," symbolref(PROCEDURE) = %x, status=%x\n", symaddr, status));
if (status != 0) {
SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ;
diff --git a/contrib/perl5/ext/DynaLoader/dl_next.xs b/contrib/perl5/ext/DynaLoader/dl_next.xs
index 2b547f0..dfa8a3e 100644
--- a/contrib/perl5/ext/DynaLoader/dl_next.xs
+++ b/contrib/perl5/ext/DynaLoader/dl_next.xs
@@ -172,6 +172,7 @@ static char *dlopen(char *path, int mode /* mode is ignored */)
I32 i, psize;
char *result;
char **p;
+ STRLEN n_a;
/* Do not load what is already loaded into this process */
if (hv_fetch(dl_loaded_files, path, strlen(path), 0))
@@ -182,7 +183,7 @@ static char *dlopen(char *path, int mode /* mode is ignored */)
p = (char **) safemalloc(psize * sizeof(char*));
p[0] = path;
for(i=1; i<psize-1; i++) {
- p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), PL_na);
+ p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), n_a);
}
p[psize-1] = 0;
rld_success = rld_load(nxerr, (struct mach_header **)0, p,
diff --git a/contrib/perl5/ext/DynaLoader/dl_vms.xs b/contrib/perl5/ext/DynaLoader/dl_vms.xs
index 974fd58..08fd2f3 100644
--- a/contrib/perl5/ext/DynaLoader/dl_vms.xs
+++ b/contrib/perl5/ext/DynaLoader/dl_vms.xs
@@ -1,7 +1,7 @@
/* dl_vms.xs
*
* Platform: OpenVMS, VAX or AXP
- * Author: Charles Bailey bailey@genetics.upenn.edu
+ * Author: Charles Bailey bailey@newman.upenn.edu
* Revised: 12-Dec-1994
*
* Implementation Note
diff --git a/contrib/perl5/ext/Errno/Errno_pm.PL b/contrib/perl5/ext/Errno/Errno_pm.PL
index f4d5020..c1f26fc 100644
--- a/contrib/perl5/ext/Errno/Errno_pm.PL
+++ b/contrib/perl5/ext/Errno/Errno_pm.PL
@@ -4,7 +4,7 @@ use strict;
use vars qw($VERSION);
-$VERSION = "1.09";
+$VERSION = "1.111";
my %err = ();
@@ -21,7 +21,7 @@ unlink "errno.c" if -f "errno.c";
sub process_file {
my($file) = @_;
- return unless defined $file;
+ return unless defined $file and -f $file;
local *FH;
if (($^O eq 'VMS') && ($Config{vms_cc_type} ne 'gnuc')) {
@@ -31,7 +31,9 @@ sub process_file {
}
} else {
unless(open(FH,"< $file")) {
- warn "Cannot open '$file'";
+ # This file could be a temporary file created by cppstdin
+ # so only warn under -w, and return
+ warn "Cannot open '$file'" if $^W;
return;
}
}
@@ -42,6 +44,24 @@ sub process_file {
close(FH);
}
+my $cppstdin;
+
+sub default_cpp {
+ unless (defined $cppstdin) {
+ use File::Spec;
+ $cppstdin = $Config{cppstdin};
+ my $upup_cppstdin = File::Spec->catfile(File::Spec->updir,
+ File::Spec->updir,
+ "cppstdin");
+ my $cppstdin_is_wrapper =
+ ($cppstdin eq 'cppstdin'
+ and -f $upup_cppstdin
+ and -x $upup_cppstdin);
+ $cppstdin = $upup_cppstdin if $cppstdin_is_wrapper;
+ }
+ return "$cppstdin $Config{cppflags} $Config{cppminus}";
+}
+
sub get_files {
my %file = ();
# VMS keeps its include files in system libraries (well, except for Gcc)
@@ -56,6 +76,9 @@ sub get_files {
} elsif ($^O eq 'os390') {
# OS/390 C compiler doesn't generate #file or #line directives
$file{'/usr/include/errno.h'} = 1;
+ } elsif ($^O eq 'vmesa') {
+ # OS/390 C compiler doesn't generate #file or #line directives
+ $file{'../../vmesa/errno.h'} = 1;
} else {
open(CPPI,"> errno.c") or
die "Cannot open errno.c";
@@ -65,9 +88,14 @@ sub get_files {
close(CPPI);
# invoke CPP and read the output
-
- open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
- die "Cannot exec $Config{cpprun}";
+ if ($^O eq 'MSWin32') {
+ open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
+ die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
+ } else {
+ my $cpp = default_cpp();
+ open(CPPO,"$cpp < errno.c |") or
+ die "Cannot exec $cpp";
+ }
my $pat;
if ($^O eq 'MSWin32' and $Config{cc} =~ /^bcc/i) {
@@ -77,7 +105,16 @@ sub get_files {
$pat = '^#(?:line)?\s*\d+\s+"([^"]+)"';
}
while(<CPPO>) {
- $file{$1} = 1 if /$pat/o;
+ if ($^O eq 'os2' or $^O eq 'MSWin32') {
+ if (/$pat/o) {
+ my $f = $1;
+ $f =~ s,\\\\,/,g;
+ $file{$f} = 1;
+ }
+ }
+ else {
+ $file{$1} = 1 if /$pat/o;
+ }
}
close(CPPO);
}
@@ -87,6 +124,10 @@ sub get_files {
sub write_errno_pm {
my $err;
+ # quick sanity check
+
+ die "No error definitions found" unless keys %err;
+
# create the CPP input
open(CPPI,"> errno.c") or
@@ -107,14 +148,13 @@ sub write_errno_pm {
$cpp =~ s/sys\$input//i;
open(CPPO,"$cpp errno.c |") or
die "Cannot exec $Config{cppstdin}";
- } elsif(!$Config{'cpprun'} or $^O eq 'next') {
- # NeXT will do syntax checking unless it is reading from stdin
- my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
+ } elsif ($^O eq 'MSWin32') {
+ open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
+ die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'";
+ } else {
+ my $cpp = default_cpp();
open(CPPO,"$cpp < errno.c |")
or die "Cannot exec $cpp";
- } else {
- open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
- die "Cannot exec $Config{cpprun}";
}
%err = ();
diff --git a/contrib/perl5/ext/Errno/Makefile.PL b/contrib/perl5/ext/Errno/Makefile.PL
index ffc8c4b..604d4fb 100644
--- a/contrib/perl5/ext/Errno/Makefile.PL
+++ b/contrib/perl5/ext/Errno/Makefile.PL
@@ -1,10 +1,11 @@
use ExtUtils::MakeMaker;
-@VMS = ($^O eq 'VMS') ? (MAN3PODS => ' ') : ();
+@VMS = ($^O eq 'VMS') ? (MAN3PODS => {}) : ();
WriteMakefile(
NAME => 'Errno',
VERSION_FROM => 'Errno_pm.PL',
+ MAN3PODS => {}, # Pods will be built by installman.
PL_FILES => {'Errno_pm.PL'=>'Errno.pm'},
PM => {'Errno.pm' => '$(INST_LIBDIR)/Errno.pm'},
'clean' => {FILES => 'Errno.pm'},
diff --git a/contrib/perl5/ext/Fcntl/Makefile.PL b/contrib/perl5/ext/Fcntl/Makefile.PL
index 66a6df6..0346373 100644
--- a/contrib/perl5/ext/Fcntl/Makefile.PL
+++ b/contrib/perl5/ext/Fcntl/Makefile.PL
@@ -1,7 +1,7 @@
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'Fcntl',
- MAN3PODS => ' ', # Pods will be built by installman.
+ MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'Fcntl.pm',
);
diff --git a/contrib/perl5/ext/GDBM_File/Makefile.PL b/contrib/perl5/ext/GDBM_File/Makefile.PL
index d244613..2a7256f 100644
--- a/contrib/perl5/ext/GDBM_File/Makefile.PL
+++ b/contrib/perl5/ext/GDBM_File/Makefile.PL
@@ -2,7 +2,7 @@ use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'GDBM_File',
LIBS => ["-L/usr/local/lib -lgdbm", "-ldbm"],
- MAN3PODS => ' ', # Pods will be built by installman.
+ MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'GDBM_File.pm',
);
diff --git a/contrib/perl5/ext/GDBM_File/hints/sco.pl b/contrib/perl5/ext/GDBM_File/hints/sco.pl
new file mode 100644
index 0000000..5c74a77
--- /dev/null
+++ b/contrib/perl5/ext/GDBM_File/hints/sco.pl
@@ -0,0 +1,2 @@
+# SCO OSR5 needs to link with libc.so again to have C<fsync> defined
+$self->{LIBS} = ['-lgdbm -lc'];
diff --git a/contrib/perl5/ext/IO/IO.xs b/contrib/perl5/ext/IO/IO.xs
index a434cca..300581e 100644
--- a/contrib/perl5/ext/IO/IO.xs
+++ b/contrib/perl5/ext/IO/IO.xs
@@ -111,7 +111,8 @@ fsetpos(handle, pos)
SV * pos
CODE:
char *p;
- if (handle && (p = SvPVx(pos, PL_na)) && PL_na == sizeof(Fpos_t))
+ STRLEN n_a;
+ if (handle && (p = SvPVx(pos, n_a)) && n_a == sizeof(Fpos_t))
#ifdef PerlIO
RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
#else
diff --git a/contrib/perl5/ext/IO/Makefile.PL b/contrib/perl5/ext/IO/Makefile.PL
index 4a34be6..6a2d50d 100644
--- a/contrib/perl5/ext/IO/Makefile.PL
+++ b/contrib/perl5/ext/IO/Makefile.PL
@@ -1,7 +1,7 @@
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'IO',
- MAN3PODS => ' ', # Pods will be built by installman.
+ MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'lib/IO/Handle.pm',
XS_VERSION => 1.15
diff --git a/contrib/perl5/ext/IO/lib/IO/Pipe.pm b/contrib/perl5/ext/IO/lib/IO/Pipe.pm
index ae6d9a5..23c51b0 100644
--- a/contrib/perl5/ext/IO/lib/IO/Pipe.pm
+++ b/contrib/perl5/ext/IO/lib/IO/Pipe.pm
@@ -14,7 +14,7 @@ use vars qw($VERSION);
use Carp;
use Symbol;
-$VERSION = "1.0901";
+$VERSION = "1.0902";
sub new {
my $type = shift;
@@ -96,7 +96,7 @@ sub reader {
close ${*$me}[1];
bless $me, ref($fh);
- *{*$me} = *{*$fh}; # Alias self to handle
+ *$me = *$fh; # Alias self to handle
bless $fh; # Really wan't un-bless here
${*$me}{'io_pipe_pid'} = $pid
if defined $pid;
@@ -113,7 +113,7 @@ sub writer {
close ${*$me}[0];
bless $me, ref($fh);
- *{*$me} = *{*$fh}; # Alias self to handle
+ *$me = *$fh; # Alias self to handle
bless $fh; # Really wan't un-bless here
${*$me}{'io_pipe_pid'} = $pid
if defined $pid;
@@ -177,10 +177,10 @@ IO::pipe - supply object methods for pipes
=head1 DESCRIPTION
-C<IO::Pipe> provides an interface to createing pipes between
+C<IO::Pipe> provides an interface to creating pipes between
processes.
-=head1 CONSTRCUTOR
+=head1 CONSTRUCTOR
=over 4
diff --git a/contrib/perl5/ext/IO/lib/IO/Seekable.pm b/contrib/perl5/ext/IO/lib/IO/Seekable.pm
index 91c381a..86154c5 100644
--- a/contrib/perl5/ext/IO/lib/IO/Seekable.pm
+++ b/contrib/perl5/ext/IO/lib/IO/Seekable.pm
@@ -14,7 +14,7 @@ IO::Seekable - supply seek based methods for I/O objects
=head1 DESCRIPTION
-C<IO::Seekable> does not have a constuctor of its own as is intended to
+C<IO::Seekable> does not have a constructor of its own as it is intended to
be inherited by other C<IO::Handle> based objects. It provides methods
which allow seeking of the file descriptors.
diff --git a/contrib/perl5/ext/IO/lib/IO/Socket.pm b/contrib/perl5/ext/IO/lib/IO/Socket.pm
index 406f74d..2b4bc49 100644
--- a/contrib/perl5/ext/IO/lib/IO/Socket.pm
+++ b/contrib/perl5/ext/IO/lib/IO/Socket.pm
@@ -664,7 +664,7 @@ Returns the pathname to the fifo at the local end
=item peerpath()
-Returns the pathanme to the fifo at the peer end
+Returns the pathname to the fifo at the peer end
=back
diff --git a/contrib/perl5/ext/IPC/SysV/Makefile.PL b/contrib/perl5/ext/IPC/SysV/Makefile.PL
index c8e320f..60dd74d 100644
--- a/contrib/perl5/ext/IPC/SysV/Makefile.PL
+++ b/contrib/perl5/ext/IPC/SysV/Makefile.PL
@@ -22,6 +22,7 @@ sub MY::libscan
WriteMakefile(
VERSION_FROM => "SysV.pm",
NAME => "IPC::SysV",
+ MAN3PODS => {}, # Pods will be built by installman.
'dist' => {COMPRESS => 'gzip -9f',
SUFFIX => 'gz',
diff --git a/contrib/perl5/ext/IPC/SysV/Msg.pm b/contrib/perl5/ext/IPC/SysV/Msg.pm
index 93d2ae1..a739ca2 100644
--- a/contrib/perl5/ext/IPC/SysV/Msg.pm
+++ b/contrib/perl5/ext/IPC/SysV/Msg.pm
@@ -84,7 +84,7 @@ sub remove {
}
sub rcv {
- @_ == 5 || croak '$msg->rcv( BUF, LEN, TYPE, FLAGS )';
+ @_ <= 5 && @_ >= 3 or croak '$msg->rcv( BUF, LEN, TYPE, FLAGS )';
my $self = shift;
my $buf = "";
msgrcv($$self,$buf,$_[1],$_[2] || 0, $_[3] || 0) or
@@ -95,7 +95,7 @@ sub rcv {
}
sub snd {
- @_ == 4 || croak '$msg->snd( TYPE, BUF, FLAGS )';
+ @_ <= 4 && @_ >= 3 or croak '$msg->snd( TYPE, BUF, FLAGS )';
my $self = shift;
msgsnd($$self,pack("L a*",$_[0],$_[1]), $_[2] || 0);
}
diff --git a/contrib/perl5/ext/IPC/SysV/SysV.xs b/contrib/perl5/ext/IPC/SysV/SysV.xs
index 0fbf783..ecd5270 100644
--- a/contrib/perl5/ext/IPC/SysV/SysV.xs
+++ b/contrib/perl5/ext/IPC/SysV/SysV.xs
@@ -4,32 +4,52 @@
#include <sys/types.h>
#ifdef __linux__
-#include <asm/page.h>
+# include <asm/page.h>
#endif
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
-#include <sys/ipc.h>
-#ifdef HAS_MSG
-#include <sys/msg.h>
-#endif
-#ifdef HAS_SEM
-#include <sys/sem.h>
-#endif
-#ifdef HAS_SHM
-#if defined(PERL_SCO5) || defined(PERL_ISC)
-#include <sys/sysmacros.h>
-#endif
-#include <sys/shm.h>
-# ifndef HAS_SHMAT_PROTOTYPE
- extern Shmat_t shmat _((int, char *, int));
-# endif
+#ifndef HAS_SEM
+# include <sys/ipc.h>
+#endif
+# ifdef HAS_MSG
+# include <sys/msg.h>
+# endif
+# ifdef HAS_SHM
+# if defined(PERL_SCO) || defined(PERL_ISC)
+# include <sys/sysmacros.h> /* SHMLBA */
+# endif
+# include <sys/shm.h>
+# ifndef HAS_SHMAT_PROTOTYPE
+ extern Shmat_t shmat _((int, char *, int));
+# endif
+# if defined(__sparc__) && (defined(__NetBSD__) || defined(__OpenBSD__))
+# undef SHMLBA /* not static: determined at boot time */
+# define SHMLBA getpagesize()
+# endif
+# endif
#endif
+
+/* Required to get 'struct pte' for SHMLBA on ULTRIX. */
+#if defined(__ultrix) || defined(__ultrix__) || defined(ultrix)
+# include <machine/pte.h>
#endif
/* Required in BSDI to get PAGE_SIZE definition for SHMLBA.
* Ugly. More beautiful solutions welcome.
* Shouting at BSDI sounds quite beautiful. */
#ifdef __bsdi__
-# include <vm/vm_param.h>
+# include <vm/vm_param.h> /* move upwards under HAS_SHM? */
+#endif
+
+#ifndef S_IRWXU
+# ifdef S_IRUSR
+# define S_IRWXU (S_IRUSR|S_IWUSR|S_IWUSR)
+# define S_IRWXG (S_IRGRP|S_IWGRP|S_IWGRP)
+# define S_IRWXO (S_IROTH|S_IWOTH|S_IWOTH)
+# else
+# define S_IRWXU 0700
+# define S_IRWXG 0070
+# define S_IRWXO 0007
+# endif
#endif
MODULE=IPC::SysV PACKAGE=IPC::Msg::stat
diff --git a/contrib/perl5/ext/NDBM_File/Makefile.PL b/contrib/perl5/ext/NDBM_File/Makefile.PL
index ca4c107..6ceab55 100644
--- a/contrib/perl5/ext/NDBM_File/Makefile.PL
+++ b/contrib/perl5/ext/NDBM_File/Makefile.PL
@@ -2,7 +2,7 @@ use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'NDBM_File',
LIBS => ["-L/usr/local/lib -lndbm", "-ldbm -lucb"],
- MAN3PODS => ' ', # Pods will be built by installman.
+ MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'NDBM_File.pm',
);
diff --git a/contrib/perl5/ext/ODBM_File/Makefile.PL b/contrib/perl5/ext/ODBM_File/Makefile.PL
index 76a5d19..2732a32 100644
--- a/contrib/perl5/ext/ODBM_File/Makefile.PL
+++ b/contrib/perl5/ext/ODBM_File/Makefile.PL
@@ -2,7 +2,7 @@ use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'ODBM_File',
LIBS => ["-ldbm -lucb"],
- MAN3PODS => ' ', # Pods will be built by installman.
+ MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'ODBM_File.pm',
);
diff --git a/contrib/perl5/ext/Opcode/Makefile.PL b/contrib/perl5/ext/Opcode/Makefile.PL
index 48a6ed8..d7e781f 100644
--- a/contrib/perl5/ext/Opcode/Makefile.PL
+++ b/contrib/perl5/ext/Opcode/Makefile.PL
@@ -1,7 +1,7 @@
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'Opcode',
- MAN3PODS => ' ',
+ MAN3PODS => {},
VERSION_FROM => 'Opcode.pm',
XS_VERSION => '1.03'
);
diff --git a/contrib/perl5/ext/Opcode/Opcode.xs b/contrib/perl5/ext/Opcode/Opcode.xs
index e853cf1..e93b900 100644
--- a/contrib/perl5/ext/Opcode/Opcode.xs
+++ b/contrib/perl5/ext/Opcode/Opcode.xs
@@ -400,7 +400,8 @@ PPCODE:
}
else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {
int b, j;
- char *bitmap = SvPV(bitspec,PL_na);
+ STRLEN n_a;
+ char *bitmap = SvPV(bitspec,n_a);
myopcode = 0;
for (b=0; b < opset_len; b++) {
U16 bits = bitmap[b];
diff --git a/contrib/perl5/ext/Opcode/Safe.pm b/contrib/perl5/ext/Opcode/Safe.pm
index 940a972..2d09c2e 100644
--- a/contrib/perl5/ext/Opcode/Safe.pm
+++ b/contrib/perl5/ext/Opcode/Safe.pm
@@ -283,8 +283,8 @@ perl code is compiled into an internal format before execution.
Evaluating perl code (e.g. via "eval" or "do 'file'") causes
the code to be compiled into an internal format and then,
provided there was no error in the compilation, executed.
-Code evaulated in a compartment compiles subject to the
-compartment's operator mask. Attempting to evaulate code in a
+Code evaluated in a compartment compiles subject to the
+compartment's operator mask. Attempting to evaluate code in a
compartment which contains a masked operator will cause the
compilation to fail with an error. The code will not be executed.
diff --git a/contrib/perl5/ext/Opcode/ops.pm b/contrib/perl5/ext/Opcode/ops.pm
index b9ea36c..9b553b7 100644
--- a/contrib/perl5/ext/Opcode/ops.pm
+++ b/contrib/perl5/ext/Opcode/ops.pm
@@ -31,7 +31,7 @@ ops - Perl pragma to restrict unsafe operations when compiling
=head1 DESCRIPTION
-Since the ops pragma currently has an irreversable global effect, it is
+Since the ops pragma currently has an irreversible global effect, it is
only of significant practical use with the C<-M> option on the command line.
See the L<Opcode> module for information about opcodes, optags, opmasks
diff --git a/contrib/perl5/ext/POSIX/Makefile.PL b/contrib/perl5/ext/POSIX/Makefile.PL
index bc1dda9..d379fdb 100644
--- a/contrib/perl5/ext/POSIX/Makefile.PL
+++ b/contrib/perl5/ext/POSIX/Makefile.PL
@@ -2,7 +2,7 @@ use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'POSIX',
($^O eq 'MSWin32' ? () : (LIBS => ["-lm -lposix -lcposix"])),
- MAN3PODS => ' ', # Pods will be built by installman.
+ MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'POSIX.pm',
);
diff --git a/contrib/perl5/ext/POSIX/POSIX.pm b/contrib/perl5/ext/POSIX/POSIX.pm
index 5d3ef5c..84298cb 100644
--- a/contrib/perl5/ext/POSIX/POSIX.pm
+++ b/contrib/perl5/ext/POSIX/POSIX.pm
@@ -268,25 +268,25 @@ sub toupper {
sub closedir {
usage "closedir(dirhandle)" if @_ != 1;
- closedir($_[0]);
+ CORE::closedir($_[0]);
}
sub opendir {
usage "opendir(directory)" if @_ != 1;
my $dirhandle = gensym;
- opendir($dirhandle, $_[0])
+ CORE::opendir($dirhandle, $_[0])
? $dirhandle
: undef;
}
sub readdir {
usage "readdir(dirhandle)" if @_ != 1;
- readdir($_[0]);
+ CORE::readdir($_[0]);
}
sub rewinddir {
usage "rewinddir(dirhandle)" if @_ != 1;
- rewinddir($_[0]);
+ CORE::rewinddir($_[0]);
}
sub errno {
@@ -301,42 +301,42 @@ sub creat {
sub fcntl {
usage "fcntl(filehandle, cmd, arg)" if @_ != 3;
- fcntl($_[0], $_[1], $_[2]);
+ CORE::fcntl($_[0], $_[1], $_[2]);
}
sub getgrgid {
usage "getgrgid(gid)" if @_ != 1;
- getgrgid($_[0]);
+ CORE::getgrgid($_[0]);
}
sub getgrnam {
usage "getgrnam(name)" if @_ != 1;
- getgrnam($_[0]);
+ CORE::getgrnam($_[0]);
}
sub atan2 {
usage "atan2(x,y)" if @_ != 2;
- atan2($_[0], $_[1]);
+ CORE::atan2($_[0], $_[1]);
}
sub cos {
usage "cos(x)" if @_ != 1;
- cos($_[0]);
+ CORE::cos($_[0]);
}
sub exp {
usage "exp(x)" if @_ != 1;
- exp($_[0]);
+ CORE::exp($_[0]);
}
sub fabs {
usage "fabs(x)" if @_ != 1;
- abs($_[0]);
+ CORE::abs($_[0]);
}
sub log {
usage "log(x)" if @_ != 1;
- log($_[0]);
+ CORE::log($_[0]);
}
sub pow {
@@ -346,22 +346,22 @@ sub pow {
sub sin {
usage "sin(x)" if @_ != 1;
- sin($_[0]);
+ CORE::sin($_[0]);
}
sub sqrt {
usage "sqrt(x)" if @_ != 1;
- sqrt($_[0]);
+ CORE::sqrt($_[0]);
}
sub getpwnam {
usage "getpwnam(name)" if @_ != 1;
- getpwnam($_[0]);
+ CORE::getpwnam($_[0]);
}
sub getpwuid {
usage "getpwuid(uid)" if @_ != 1;
- getpwuid($_[0]);
+ CORE::getpwuid($_[0]);
}
sub longjmp {
@@ -382,12 +382,12 @@ sub sigsetjmp {
sub kill {
usage "kill(pid, sig)" if @_ != 2;
- kill $_[1], $_[0];
+ CORE::kill $_[1], $_[0];
}
sub raise {
usage "raise(sig)" if @_ != 1;
- kill $_[0], $$; # Is this good enough?
+ CORE::kill $_[0], $$; # Is this good enough?
}
sub offsetof {
@@ -480,12 +480,12 @@ sub fwrite {
sub getc {
usage "getc(handle)" if @_ != 1;
- getc($_[0]);
+ CORE::getc($_[0]);
}
sub getchar {
usage "getchar()" if @_ != 0;
- getc(STDIN);
+ CORE::getc(STDIN);
}
sub gets {
@@ -500,7 +500,7 @@ sub perror {
sub printf {
usage "printf(pattern, args...)" if @_ < 1;
- printf STDOUT @_;
+ CORE::printf STDOUT @_;
}
sub putc {
@@ -517,17 +517,17 @@ sub puts {
sub remove {
usage "remove(filename)" if @_ != 1;
- unlink($_[0]);
+ CORE::unlink($_[0]);
}
sub rename {
usage "rename(oldfilename, newfilename)" if @_ != 2;
- rename($_[0], $_[1]);
+ CORE::rename($_[0], $_[1]);
}
sub rewind {
usage "rewind(filehandle)" if @_ != 1;
- seek($_[0],0,0);
+ CORE::seek($_[0],0,0);
}
sub scanf {
@@ -536,7 +536,7 @@ sub scanf {
sub sprintf {
usage "sprintf(pattern,args)" if @_ == 0;
- sprintf(shift,@_);
+ CORE::sprintf(shift,@_);
}
sub sscanf {
@@ -565,7 +565,7 @@ sub vsprintf {
sub abs {
usage "abs(x)" if @_ != 1;
- abs($_[0]);
+ CORE::abs($_[0]);
}
sub atexit {
@@ -598,7 +598,7 @@ sub div {
sub exit {
usage "exit(status)" if @_ != 1;
- exit($_[0]);
+ CORE::exit($_[0]);
}
sub free {
@@ -640,7 +640,7 @@ sub srand {
sub system {
usage "system(command)" if @_ != 1;
- system($_[0]);
+ CORE::system($_[0]);
}
sub memchr {
@@ -719,7 +719,7 @@ sub strspn {
sub strstr {
usage "strstr(big, little)" if @_ != 2;
- index($_[0], $_[1]);
+ CORE::index($_[0], $_[1]);
}
sub strtok {
@@ -728,71 +728,71 @@ sub strtok {
sub chmod {
usage "chmod(mode, filename)" if @_ != 2;
- chmod($_[0], $_[1]);
+ CORE::chmod($_[0], $_[1]);
}
sub fstat {
usage "fstat(fd)" if @_ != 1;
local *TMP;
open(TMP, "<&$_[0]"); # Gross.
- my @l = stat(TMP);
+ my @l = CORE::stat(TMP);
close(TMP);
@l;
}
sub mkdir {
usage "mkdir(directoryname, mode)" if @_ != 2;
- mkdir($_[0], $_[1]);
+ CORE::mkdir($_[0], $_[1]);
}
sub stat {
usage "stat(filename)" if @_ != 1;
- stat($_[0]);
+ CORE::stat($_[0]);
}
sub umask {
usage "umask(mask)" if @_ != 1;
- umask($_[0]);
+ CORE::umask($_[0]);
}
sub wait {
usage "wait()" if @_ != 0;
- wait();
+ CORE::wait();
}
sub waitpid {
usage "waitpid(pid, options)" if @_ != 2;
- waitpid($_[0], $_[1]);
+ CORE::waitpid($_[0], $_[1]);
}
sub gmtime {
usage "gmtime(time)" if @_ != 1;
- gmtime($_[0]);
+ CORE::gmtime($_[0]);
}
sub localtime {
usage "localtime(time)" if @_ != 1;
- localtime($_[0]);
+ CORE::localtime($_[0]);
}
sub time {
usage "time()" if @_ != 0;
- time;
+ CORE::time;
}
sub alarm {
usage "alarm(seconds)" if @_ != 1;
- alarm($_[0]);
+ CORE::alarm($_[0]);
}
sub chdir {
usage "chdir(directory)" if @_ != 1;
- chdir($_[0]);
+ CORE::chdir($_[0]);
}
sub chown {
usage "chown(filename, uid, gid)" if @_ != 3;
- chown($_[0], $_[1], $_[2]);
+ CORE::chown($_[0], $_[1], $_[2]);
}
sub execl {
@@ -821,7 +821,7 @@ sub execvp {
sub fork {
usage "fork()" if @_ != 0;
- fork;
+ CORE::fork;
}
sub getcwd
@@ -861,12 +861,12 @@ sub getgroups {
sub getlogin {
usage "getlogin()" if @_ != 0;
- getlogin();
+ CORE::getlogin();
}
sub getpgrp {
usage "getpgrp()" if @_ != 0;
- getpgrp($_[0]);
+ CORE::getpgrp;
}
sub getpid {
@@ -876,7 +876,7 @@ sub getpid {
sub getppid {
usage "getppid()" if @_ != 0;
- getppid;
+ CORE::getppid;
}
sub getuid {
@@ -891,12 +891,16 @@ sub isatty {
sub link {
usage "link(oldfilename, newfilename)" if @_ != 2;
- link($_[0], $_[1]);
+ CORE::link($_[0], $_[1]);
}
sub rmdir {
usage "rmdir(directoryname)" if @_ != 1;
- rmdir($_[0]);
+ CORE::rmdir($_[0]);
+}
+
+sub setbuf {
+ redef "IO::Handle::setbuf()";
}
sub setgid {
@@ -909,18 +913,22 @@ sub setuid {
$< = $_[0];
}
+sub setvbuf {
+ redef "IO::Handle::setvbuf()";
+}
+
sub sleep {
usage "sleep(seconds)" if @_ != 1;
- sleep($_[0]);
+ CORE::sleep($_[0]);
}
sub unlink {
usage "unlink(filename)" if @_ != 1;
- unlink($_[0]);
+ CORE::unlink($_[0]);
}
sub utime {
usage "utime(filename, atime, mtime)" if @_ != 3;
- utime($_[1], $_[2], $_[0]);
+ CORE::utime($_[1], $_[2], $_[0]);
}
diff --git a/contrib/perl5/ext/POSIX/POSIX.pod b/contrib/perl5/ext/POSIX/POSIX.pod
index 4726487..6a4a61a 100644
--- a/contrib/perl5/ext/POSIX/POSIX.pod
+++ b/contrib/perl5/ext/POSIX/POSIX.pod
@@ -1009,13 +1009,14 @@ Convert date and time information to string. Returns the string.
Synopsis:
- strftime(fmt, sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0)
+ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero.
I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The
-year (C<year>) is given in years since 1900. I.e. The year 1995 is 95; the
+year (C<year>) is given in years since 1900. I.e., the year 1995 is 95; the
year 2001 is 101. Consult your system's C<strftime()> manpage for details
-about these and the other arguments.
+about these and the other arguments. The given arguments are made consistent
+by calling C<mktime()> before calling your system's C<strftime()> function.
The string for Tuesday, December 12, 1995.
diff --git a/contrib/perl5/ext/POSIX/POSIX.xs b/contrib/perl5/ext/POSIX/POSIX.xs
index 6958c00..15e026e 100644
--- a/contrib/perl5/ext/POSIX/POSIX.xs
+++ b/contrib/perl5/ext/POSIX/POSIX.xs
@@ -10,8 +10,6 @@
# undef open
# undef setmode
# define open PerlLIO_open3
-# undef TAINT_PROPER
-# define TAINT_PROPER(a)
#endif
#include <ctype.h>
#ifdef I_DIRENT /* XXX maybe better to just rely on perl.h? */
@@ -2569,7 +2567,7 @@ new(packname = "POSIX::SigSet", ...)
CODE:
{
int i;
- RETVAL = (sigset_t*)safemalloc(sizeof(sigset_t));
+ New(0, RETVAL, 1, sigset_t);
sigemptyset(RETVAL);
for (i = 1; i < items; i++)
sigaddset(RETVAL, SvIV(ST(i)));
@@ -2581,7 +2579,7 @@ void
DESTROY(sigset)
POSIX::SigSet sigset
CODE:
- safefree((char *)sigset);
+ Safefree(sigset);
SysRet
sigaddset(sigset, sig)
@@ -2615,7 +2613,7 @@ new(packname = "POSIX::Termios", ...)
CODE:
{
#ifdef I_TERMIOS
- RETVAL = (struct termios*)safemalloc(sizeof(struct termios));
+ New(0, RETVAL, 1, struct termios);
#else
not_here("termios");
RETVAL = 0;
@@ -2629,7 +2627,7 @@ DESTROY(termios_ref)
POSIX::Termios termios_ref
CODE:
#ifdef I_TERMIOS
- safefree((char *)termios_ref);
+ Safefree(termios_ref);
#else
not_here("termios");
#endif
@@ -3181,10 +3179,11 @@ sigaction(sig, action, oldaction = 0)
sig_name[sig],
strlen(sig_name[sig]),
TRUE);
+ STRLEN n_a;
/* Remember old handler name if desired. */
if (oldaction) {
- char *hand = SvPVx(*sigsvp, PL_na);
+ char *hand = SvPVx(*sigsvp, n_a);
svp = hv_fetch(oldaction, "HANDLER", 7, TRUE);
sv_setpv(*svp, *hand ? hand : "DEFAULT");
}
@@ -3195,7 +3194,7 @@ sigaction(sig, action, oldaction = 0)
svp = hv_fetch(action, "HANDLER", 7, FALSE);
if (!svp)
croak("Can't supply an action without a HANDLER");
- sv_setpv(*sigsvp, SvPV(*svp, PL_na));
+ sv_setpv(*sigsvp, SvPV(*svp, n_a));
mg_set(*sigsvp); /* handles DEFAULT and IGNORE */
act.sa_handler = sighandler;
@@ -3234,7 +3233,7 @@ sigaction(sig, action, oldaction = 0)
sigset = (sigset_t*) tmp;
}
else {
- sigset = (sigset_t*)safemalloc(sizeof(sigset_t));
+ New(0, sigset, 1, sigset_t);
sv_setptrobj(*svp, sigset, "POSIX::SigSet");
}
*sigset = oact.sa_mask;
@@ -3256,7 +3255,20 @@ SysRet
sigprocmask(how, sigset, oldsigset = 0)
int how
POSIX::SigSet sigset
- POSIX::SigSet oldsigset
+ POSIX::SigSet oldsigset = NO_INIT
+INIT:
+ if ( items < 3 ) {
+ oldsigset = 0;
+ }
+ else if (sv_derived_from(ST(2), "POSIX::SigSet")) {
+ IV tmp = SvIV((SV*)SvRV(ST(2)));
+ oldsigset = (POSIX__SigSet) tmp;
+ }
+ else {
+ New(0, oldsigset, 1, sigset_t);
+ sigemptyset(oldsigset);
+ sv_setref_pv(ST(2), "POSIX::SigSet", (void*)oldsigset);
+ }
SysRet
sigsuspend(signal_mask)
@@ -3591,7 +3603,7 @@ mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0)
RETVAL
char *
-strftime(fmt, sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0)
+strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
char * fmt
int sec
int min
@@ -3617,8 +3629,45 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0)
mytm.tm_wday = wday;
mytm.tm_yday = yday;
mytm.tm_isdst = isdst;
+ (void) mktime(&mytm);
len = strftime(tmpbuf, sizeof tmpbuf, fmt, &mytm);
- ST(0) = sv_2mortal(newSVpv(tmpbuf, len));
+ /*
+ ** The following is needed to handle to the situation where
+ ** tmpbuf overflows. Basically we want to allocate a buffer
+ ** and try repeatedly. The reason why it is so complicated
+ ** is that getting a return value of 0 from strftime can indicate
+ ** one of the following:
+ ** 1. buffer overflowed,
+ ** 2. illegal conversion specifier, or
+ ** 3. the format string specifies nothing to be returned(not
+ ** an error). This could be because format is an empty string
+ ** or it specifies %p that yields an empty string in some locale.
+ ** If there is a better way to make it portable, go ahead by
+ ** all means.
+ */
+ if ( ( len > 0 && len < sizeof(tmpbuf) )
+ || ( len == 0 && strlen(fmt) == 0 ) ) {
+ ST(0) = sv_2mortal(newSVpv(tmpbuf, len));
+ } else {
+ /* Possibly buf overflowed - try again with a bigger buf */
+ int bufsize = strlen(fmt) + sizeof(tmpbuf);
+ char* buf;
+ int buflen;
+
+ New(0, buf, bufsize, char);
+ while( buf ) {
+ buflen = strftime(buf, bufsize, fmt, &mytm);
+ if ( buflen > 0 && buflen < bufsize ) break;
+ bufsize *= 2;
+ Renew(buf, bufsize, char);
+ }
+ if ( buf ) {
+ ST(0) = sv_2mortal(newSVpv(buf, buflen));
+ Safefree(buf);
+ } else {
+ ST(0) = sv_2mortal(newSVpv(tmpbuf, len));
+ }
+ }
}
void
diff --git a/contrib/perl5/ext/POSIX/hints/dynixptx.pl b/contrib/perl5/ext/POSIX/hints/dynixptx.pl
new file mode 100644
index 0000000..9b63684
--- /dev/null
+++ b/contrib/perl5/ext/POSIX/hints/dynixptx.pl
@@ -0,0 +1,4 @@
+# Need to add an extra '-lc' to the end to work around a DYNIX/ptx bug
+# PR#227670 - linker error on fpgetround()
+
+$self->{LIBS} = ['-ldb -lm -lc'];
diff --git a/contrib/perl5/ext/POSIX/hints/mint.pl b/contrib/perl5/ext/POSIX/hints/mint.pl
new file mode 100644
index 0000000..b975cbb
--- /dev/null
+++ b/contrib/perl5/ext/POSIX/hints/mint.pl
@@ -0,0 +1,2 @@
+$self->{CCFLAGS} = $Config{ccflags} . ' -DNO_LOCALECONV_GROUPING -DNO_LOCALECONV_MON_GROUPING';
+
diff --git a/contrib/perl5/ext/SDBM_File/Makefile.PL b/contrib/perl5/ext/SDBM_File/Makefile.PL
index b639b29..7494785 100644
--- a/contrib/perl5/ext/SDBM_File/Makefile.PL
+++ b/contrib/perl5/ext/SDBM_File/Makefile.PL
@@ -12,7 +12,7 @@ else { $myextlib = 'sdbm/libsdbm$(LIB_EXT)'; }
WriteMakefile(
NAME => 'SDBM_File',
MYEXTLIB => $myextlib,
- MAN3PODS => ' ', # Pods will be built by installman.
+ MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'SDBM_File.pm',
DEFINE => $define,
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c
index 637fbe9..c147e45 100644
--- a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c
+++ b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c
@@ -437,6 +437,7 @@ setdbit(register DBM *db, register long int dbit)
dirb = c / DBLKSIZ;
if (dirb != db->dirbno) {
+ (void) memset(db->dirbuf, 0, DBLKSIZ);
if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0
|| read(db->dirf, db->dirbuf, DBLKSIZ) < 0)
return 0;
diff --git a/contrib/perl5/ext/Socket/Makefile.PL b/contrib/perl5/ext/Socket/Makefile.PL
index 7b9469a..3819143 100644
--- a/contrib/perl5/ext/Socket/Makefile.PL
+++ b/contrib/perl5/ext/Socket/Makefile.PL
@@ -2,6 +2,6 @@ use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'Socket',
VERSION_FROM => 'Socket.pm',
- MAN3PODS => ' ', # Pods will be built by installman.
+ MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
);
diff --git a/contrib/perl5/ext/Socket/Socket.pm b/contrib/perl5/ext/Socket/Socket.pm
index 5a4870f..1ed19f7 100644
--- a/contrib/perl5/ext/Socket/Socket.pm
+++ b/contrib/perl5/ext/Socket/Socket.pm
@@ -193,10 +193,25 @@ require DynaLoader;
AF_UNIX
AF_UNSPEC
AF_X25
+ MSG_CTLFLAGS
+ MSG_CTLIGNORE
+ MSG_CTRUNC
MSG_DONTROUTE
+ MSG_DONTWAIT
+ MSG_EOF
+ MSG_EOR
+ MSG_ERRQUEUE
+ MSG_FIN
MSG_MAXIOVLEN
+ MSG_NOSIGNAL
MSG_OOB
MSG_PEEK
+ MSG_PROXY
+ MSG_RST
+ MSG_SYN
+ MSG_TRUNC
+ MSG_URG
+ MSG_WAITALL
PF_802
PF_APPLETALK
PF_CCITT
@@ -221,6 +236,11 @@ require DynaLoader;
PF_UNIX
PF_UNSPEC
PF_X25
+ SCM_CONNECT
+ SCM_CREDENTIALS
+ SCM_CREDS
+ SCM_RIGHTS
+ SCM_TIMESTAMP
SOCK_DGRAM
SOCK_RAW
SOCK_RDM
diff --git a/contrib/perl5/ext/Socket/Socket.xs b/contrib/perl5/ext/Socket/Socket.xs
index de0217b..0bd6e59 100644
--- a/contrib/perl5/ext/Socket/Socket.xs
+++ b/contrib/perl5/ext/Socket/Socket.xs
@@ -330,42 +330,114 @@ constant(char *name, int arg)
case 'L':
break;
case 'M':
+ if (strEQ(name, "MSG_CTLFLAGS"))
+#ifdef MSG_CTLFLAGS
+ return MSG_CTLFLAGS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MSG_CTLIGNORE"))
+#ifdef MSG_CTLIGNORE
+ return MSG_CTLIGNORE;
+#else
+ goto not_there;
+#endif
if (strEQ(name, "MSG_CTRUNC"))
-#if defined(MSG_CTRUNC) || defined(HAS_GNULIBC) /* XXX it's an enum */
+#if defined(MSG_TRUNC) || defined(HAS_MSG_CTRUNC) /* might be an enum */
return MSG_CTRUNC;
#else
goto not_there;
#endif
if (strEQ(name, "MSG_DONTROUTE"))
-#if defined(MSG_DONTROUTE) || defined(HAS_GNULIBC) /* XXX it's an enum */
+#if defined(MSG_DONTROUTE) || defined(HAS_MSG_DONTROUTE) /* might be an enum */
return MSG_DONTROUTE;
#else
goto not_there;
#endif
+ if (strEQ(name, "MSG_DONTWAIT"))
+#ifdef MSG_DONTWAIT
+ return MSG_DONTWAIT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MSG_EOF"))
+#ifdef MSG_EOF
+ return MSG_EOF;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MSG_EOR"))
+#ifdef MSG_EOR
+ return MSG_EOR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MSG_ERRQUEUE"))
+#ifdef MSG_ERRQUEUE
+ return MSG_ERRQUEUE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MSG_FIN"))
+#ifdef MSG_FIN
+ return MSG_FIN;
+#else
+ goto not_there;
+#endif
if (strEQ(name, "MSG_MAXIOVLEN"))
#ifdef MSG_MAXIOVLEN
return MSG_MAXIOVLEN;
#else
goto not_there;
#endif
+ if (strEQ(name, "MSG_NOSIGNAL"))
+#ifdef MSG_NOSIGNAL
+ return MSG_NOSIGNAL;
+#else
+ goto not_there;
+#endif
if (strEQ(name, "MSG_OOB"))
-#if defined(MSG_OOB) || defined(HAS_GNULIBC) /* XXX it's an enum */
+#if defined(MSG_OOB) || defined(HAS_MSG_OOB) /* might be an enum */
return MSG_OOB;
#else
goto not_there;
#endif
if (strEQ(name, "MSG_PEEK"))
-#if defined(MSG_PEEK) || defined(HAS_GNULIBC) /* XXX it's an enum */
+#if defined(MSG_PEEK) || defined(HAS_MSG_PEEK) /* might be an enum */
return MSG_PEEK;
#else
goto not_there;
#endif
if (strEQ(name, "MSG_PROXY"))
-#if defined(MSG_PROXY) || defined(HAS_GNULIBC) /* XXX it's an enum */
+#if defined(MSG_PROXY) || defined(HAS_MSG_PROXY) /* might be an enum */
return MSG_PROXY;
#else
goto not_there;
#endif
+ if (strEQ(name, "MSG_RST"))
+#ifdef MSG_RST
+ return MSG_RST;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MSG_SYN"))
+#ifdef MSG_SYN
+ return MSG_SYN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MSG_TRUNC"))
+#ifdef MSG_TRUNC
+ return MSG_TRUNC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MSG_WAITALL"))
+#ifdef MSG_WAITALL
+ return MSG_WAITALL;
+#else
+ goto not_there;
+#endif
break;
case 'N':
break;
@@ -522,6 +594,36 @@ constant(char *name, int arg)
case 'R':
break;
case 'S':
+ if (strEQ(name, "SCM_CONNECT"))
+#ifdef SCM_CONNECT
+ return SCM_CONNECT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SCM_CREDENTIALS"))
+#ifdef SCM_CREDENTIALS
+ return SCM_CREDENTIALS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SCM_CREDS"))
+#ifdef SCM_CREDS
+ return SCM_CREDS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SCM_RIGHTS"))
+#if defined(SCM_RIGHTS) || defined(HAS_SCM_RIGHTS) /* might be an enum */
+ return SCM_RIGHTS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SCM_TIMESTAMP"))
+#ifdef SCM_TIMESTAMP
+ return SCM_TIMESTAMP;
+#else
+ goto not_there;
+#endif
if (strEQ(name, "SOCK_DGRAM"))
#ifdef SOCK_DGRAM
return SOCK_DGRAM;
diff --git a/contrib/perl5/ext/Thread/Makefile.PL b/contrib/perl5/ext/Thread/Makefile.PL
index e252d4e..e67fbb7 100644
--- a/contrib/perl5/ext/Thread/Makefile.PL
+++ b/contrib/perl5/ext/Thread/Makefile.PL
@@ -2,6 +2,6 @@ use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'Thread',
VERSION_FROM => 'Thread.pm',
- MAN3PODS => ' '
+ MAN3PODS => {}
);
diff --git a/contrib/perl5/ext/Thread/Thread.xs b/contrib/perl5/ext/Thread/Thread.xs
index 48f8aa0..2337e8c 100644
--- a/contrib/perl5/ext/Thread/Thread.xs
+++ b/contrib/perl5/ext/Thread/Thread.xs
@@ -115,18 +115,21 @@ threadstart(void *arg)
sv = POPs;
PUTBACK;
+ ENTER;
+ SAVETMPS;
perl_call_sv(sv, G_ARRAY|G_EVAL);
SPAGAIN;
retval = SP - (PL_stack_base + oldmark);
SP = PL_stack_base + oldmark + 1;
if (SvCUR(thr->errsv)) {
+ STRLEN n_a;
MUTEX_LOCK(&thr->mutex);
thr->flags |= THRf_DID_DIE;
MUTEX_UNLOCK(&thr->mutex);
av_store(av, 0, &PL_sv_no);
av_store(av, 1, newSVsv(thr->errsv));
DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p died: %s\n",
- thr, SvPV(thr->errsv, PL_na)));
+ thr, SvPV(thr->errsv, n_a)));
} else {
DEBUG_S(STMT_START {
for (i = 1; i <= retval; i++) {
@@ -138,6 +141,8 @@ threadstart(void *arg)
for (i = 1; i <= retval; i++, SP++)
sv_setsv(*av_fetch(av, i, TRUE), SvREFCNT_inc(*SP));
}
+ FREETMPS;
+ LEAVE;
finishoff:
#if 0
@@ -174,7 +179,7 @@ threadstart(void *arg)
Safefree(PL_screamnext);
Safefree(PL_reg_start_tmp);
SvREFCNT_dec(PL_lastscream);
- /*SvREFCNT_dec(PL_defoutgv);*/
+ SvREFCNT_dec(PL_defoutgv);
MUTEX_LOCK(&thr->mutex);
DEBUG_S(PerlIO_printf(PerlIO_stderr(),
@@ -233,6 +238,11 @@ newthread (SV *startsv, AV *initargs, char *classname)
savethread = thr;
thr = new_struct_thread(thr);
+ /* temporarily pretend to be the child thread in case the
+ * XPUSHs() below want to grow the child's stack. This is
+ * safe, since the other thread is not yet created, and we
+ * are the only ones who know about it */
+ SET_THR(thr);
SPAGAIN;
DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"%p: newthread (%p), tid is %u, preparing stack\n",
@@ -244,11 +254,14 @@ newthread (SV *startsv, AV *initargs, char *classname)
XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE)));
XPUSHs(SvREFCNT_inc(startsv));
PUTBACK;
+
+ /* On your marks... */
+ SET_THR(savethread);
+ MUTEX_LOCK(&thr->mutex);
+
#ifdef THREAD_CREATE
err = THREAD_CREATE(thr, threadstart);
#else
- /* On your marks... */
- MUTEX_LOCK(&thr->mutex);
/* Get set... */
sigfillset(&fullmask);
if (sigprocmask(SIG_SETMASK, &fullmask, &oldmask) == -1)
@@ -279,10 +292,9 @@ newthread (SV *startsv, AV *initargs, char *classname)
#else
err = pthread_create(&thr->self, &attr, threadstart, (void*) thr);
#endif
- /* Go */
- MUTEX_UNLOCK(&thr->mutex);
#endif
if (err) {
+ MUTEX_UNLOCK(&thr->mutex);
DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"%p: create of %p failed %d\n",
savethread, thr, err));
@@ -295,16 +307,23 @@ newthread (SV *startsv, AV *initargs, char *classname)
SvREFCNT_dec(startsv);
return NULL;
}
+
#ifdef THREAD_POST_CREATE
THREAD_POST_CREATE(thr);
#else
if (sigprocmask(SIG_SETMASK, &oldmask, 0))
croak("panic: sigprocmask");
#endif
+
sv = newSViv(thr->tid);
sv_magic(sv, thr->oursv, '~', 0, 0);
SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
- return sv_bless(newRV_noinc(sv), gv_stashpv(classname, TRUE));
+ sv = sv_bless(newRV_noinc(sv), gv_stashpv(classname, TRUE));
+
+ /* Go */
+ MUTEX_UNLOCK(&thr->mutex);
+
+ return sv;
#else
croak("No threads in this perl");
return &PL_sv_undef;
@@ -371,7 +390,8 @@ join(t)
for (i = 1; i <= AvFILL(av); i++)
XPUSHs(sv_2mortal(*av_fetch(av, i, FALSE)));
} else {
- char *mess = SvPV(*av_fetch(av, 1, FALSE), PL_na);
+ STRLEN n_a;
+ char *mess = SvPV(*av_fetch(av, 1, FALSE), n_a);
DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"%p: join propagating die message: %s\n",
thr, mess));
@@ -483,6 +503,7 @@ CODE:
croak("cond_wait for lock that we don't own\n");
}
MgOWNER(mg) = 0;
+ COND_SIGNAL(MgOWNERCONDP(mg));
COND_WAIT(MgCONDP(mg), MgMUTEXP(mg));
while (MgOWNER(mg))
COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
diff --git a/contrib/perl5/ext/Thread/create.t b/contrib/perl5/ext/Thread/create.t
index 7d6d189..df8fc77 100644
--- a/contrib/perl5/ext/Thread/create.t
+++ b/contrib/perl5/ext/Thread/create.t
@@ -1,4 +1,7 @@
-use Thread;
+use Thread 'async';
+use Config;
+use Tie::Hash;
+
sub start_here {
my $i;
print "In start_here with args: @_\n";
@@ -8,6 +11,12 @@ sub start_here {
}
}
+async {
+ tie my(%h), 'Tie::StdHash';
+ %h = %Config;
+ print "running on $h{archname}\n";
+};
+
print "Starting new thread now\n";
$t = new Thread \&start_here, qw(foo bar baz);
print "Started thread $t\n";
diff --git a/contrib/perl5/ext/attrs/Makefile.PL b/contrib/perl5/ext/attrs/Makefile.PL
index c421757..86ed3f3 100644
--- a/contrib/perl5/ext/attrs/Makefile.PL
+++ b/contrib/perl5/ext/attrs/Makefile.PL
@@ -2,6 +2,6 @@ use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'attrs',
VERSION_FROM => 'attrs.pm',
- MAN3PODS => ' ', # Pods will be built by installman.
+ MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes'
);
diff --git a/contrib/perl5/ext/attrs/attrs.xs b/contrib/perl5/ext/attrs/attrs.xs
index da952d5..7f7970d 100644
--- a/contrib/perl5/ext/attrs/attrs.xs
+++ b/contrib/perl5/ext/attrs/attrs.xs
@@ -27,7 +27,8 @@ char * Class
if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
croak("can't set attributes outside a subroutine scope");
for (i = 1; i < items; i++) {
- char *attr = SvPV(ST(i), PL_na);
+ STRLEN n_a;
+ char *attr = SvPV(ST(i), n_a);
cv_flags_t flag = get_flag(attr);
if (!flag)
croak("invalid attribute name %s", attr);
@@ -47,7 +48,8 @@ SV * sub
sub = Nullsv;
}
else {
- char *name = SvPV(sub, PL_na);
+ STRLEN n_a;
+ char *name = SvPV(sub, n_a);
sub = (SV*)perl_get_cv(name, FALSE);
}
if (!sub)
diff --git a/contrib/perl5/ext/re/Makefile.PL b/contrib/perl5/ext/re/Makefile.PL
index 9ed83d1..040b085 100644
--- a/contrib/perl5/ext/re/Makefile.PL
+++ b/contrib/perl5/ext/re/Makefile.PL
@@ -2,7 +2,7 @@ use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 're',
VERSION_FROM => 're.pm',
- MAN3PODS => ' ', # Pods will be built by installman.
+ MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes',
OBJECT => 're_exec$(OBJ_EXT) re_comp$(OBJ_EXT) re$(OBJ_EXT)',
DEFINE => '-DPERL_EXT_RE_BUILD',
diff --git a/contrib/perl5/ext/re/re.pm b/contrib/perl5/ext/re/re.pm
index 7cea77d..83e7dba 100644
--- a/contrib/perl5/ext/re/re.pm
+++ b/contrib/perl5/ext/re/re.pm
@@ -41,11 +41,11 @@ on tainted data aren't meant to extract safe substrings, but to perform
other transformations.
When C<use re 'eval'> is in effect, a regex is allowed to contain
-C<(?{ ... })> zero-width assertions even if regular expression contains
-variable interpolation. That is normally disallowed, since it is a
+C<(?{ ... })> zero-width assertions even if the regex contains
+variable interpolation. This is normally disallowed, since it is a
potential security risk. Note that this pragma is ignored when the regular
expression is obtained from tainted data, i.e. evaluation is always
-disallowed with tainted regular expresssions. See L<perlre/(?{ code })>.
+disallowed with tainted regular expressions. See L<perlre/(?{ code })>.
For the purpose of this pragma, interpolation of precompiled regular
expressions (i.e., the result of C<qr//>) is I<not> considered variable
OpenPOWER on IntegriCloud