From 77644ee620b6a79cf8c538abaf7cd301a875528d Mon Sep 17 00:00:00 2001 From: markm Date: Sun, 2 May 1999 14:33:17 +0000 Subject: Maintenance releace 3 of perl5.005. Includes support for threads. --- contrib/perl5/ext/B/B.pm | 10 +- contrib/perl5/ext/B/B.xs | 14 +- contrib/perl5/ext/B/B/Assembler.pm | 4 +- contrib/perl5/ext/B/B/C.pm | 81 +++++++-- contrib/perl5/ext/B/B/CC.pm | 27 ++- contrib/perl5/ext/B/B/Disassembler.pm | 2 +- contrib/perl5/ext/B/Makefile.PL | 2 +- contrib/perl5/ext/B/README | 4 +- contrib/perl5/ext/DB_File/Changes | 29 +++ contrib/perl5/ext/DB_File/DB_File.pm | 168 +++++++++++++++-- contrib/perl5/ext/DB_File/DB_File.xs | 128 ++++++++----- contrib/perl5/ext/DB_File/Makefile.PL | 2 +- contrib/perl5/ext/DB_File/dbinfo | 2 +- contrib/perl5/ext/DB_File/hints/dynixptx.pl | 3 + contrib/perl5/ext/DB_File/typemap | 6 +- contrib/perl5/ext/Data/Dumper/Changes | 18 ++ contrib/perl5/ext/Data/Dumper/Dumper.pm | 171 ++++++++++------- contrib/perl5/ext/Data/Dumper/Dumper.xs | 253 ++++++++++++++++---------- contrib/perl5/ext/Data/Dumper/Makefile.PL | 2 +- contrib/perl5/ext/Data/Dumper/Todo | 2 + contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL | 3 +- contrib/perl5/ext/DynaLoader/Makefile.PL | 2 +- contrib/perl5/ext/DynaLoader/dl_beos.xs | 115 ++++++++++++ contrib/perl5/ext/DynaLoader/dl_cygwin32.xs | 10 +- contrib/perl5/ext/DynaLoader/dl_mpeix.xs | 11 +- contrib/perl5/ext/DynaLoader/dl_next.xs | 3 +- contrib/perl5/ext/DynaLoader/dl_vms.xs | 2 +- contrib/perl5/ext/Errno/Errno_pm.PL | 66 +++++-- contrib/perl5/ext/Errno/Makefile.PL | 3 +- contrib/perl5/ext/Fcntl/Makefile.PL | 2 +- contrib/perl5/ext/GDBM_File/Makefile.PL | 2 +- contrib/perl5/ext/GDBM_File/hints/sco.pl | 2 + contrib/perl5/ext/IO/IO.xs | 3 +- contrib/perl5/ext/IO/Makefile.PL | 2 +- contrib/perl5/ext/IO/lib/IO/Pipe.pm | 10 +- contrib/perl5/ext/IO/lib/IO/Seekable.pm | 2 +- contrib/perl5/ext/IO/lib/IO/Socket.pm | 2 +- contrib/perl5/ext/IPC/SysV/Makefile.PL | 1 + contrib/perl5/ext/IPC/SysV/Msg.pm | 4 +- contrib/perl5/ext/IPC/SysV/SysV.xs | 54 ++++-- contrib/perl5/ext/NDBM_File/Makefile.PL | 2 +- contrib/perl5/ext/ODBM_File/Makefile.PL | 2 +- contrib/perl5/ext/Opcode/Makefile.PL | 2 +- contrib/perl5/ext/Opcode/Opcode.xs | 3 +- contrib/perl5/ext/Opcode/Safe.pm | 4 +- contrib/perl5/ext/Opcode/ops.pm | 2 +- contrib/perl5/ext/POSIX/Makefile.PL | 2 +- contrib/perl5/ext/POSIX/POSIX.pm | 110 +++++------ contrib/perl5/ext/POSIX/POSIX.pod | 7 +- contrib/perl5/ext/POSIX/POSIX.xs | 73 ++++++-- contrib/perl5/ext/POSIX/hints/dynixptx.pl | 4 + contrib/perl5/ext/POSIX/hints/mint.pl | 2 + contrib/perl5/ext/SDBM_File/Makefile.PL | 2 +- contrib/perl5/ext/SDBM_File/sdbm/sdbm.c | 1 + contrib/perl5/ext/Socket/Makefile.PL | 2 +- contrib/perl5/ext/Socket/Socket.pm | 20 ++ contrib/perl5/ext/Socket/Socket.xs | 112 +++++++++++- contrib/perl5/ext/Thread/Makefile.PL | 2 +- contrib/perl5/ext/Thread/Thread.xs | 37 +++- contrib/perl5/ext/Thread/create.t | 11 +- contrib/perl5/ext/attrs/Makefile.PL | 2 +- contrib/perl5/ext/attrs/attrs.xs | 6 +- contrib/perl5/ext/re/Makefile.PL | 2 +- contrib/perl5/ext/re/re.pm | 6 +- 64 files changed, 1227 insertions(+), 416 deletions(-) create mode 100644 contrib/perl5/ext/DB_File/hints/dynixptx.pl create mode 100644 contrib/perl5/ext/DynaLoader/dl_beos.xs create mode 100644 contrib/perl5/ext/GDBM_File/hints/sco.pl create mode 100644 contrib/perl5/ext/POSIX/hints/dynixptx.pl create mode 100644 contrib/perl5/ext/POSIX/hints/mint.pl (limited to 'contrib/perl5/ext') 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 (corresponding to the C function C). =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 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 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 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. Refer to the Berkeley DB documentation for further details. -Please read L 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. +To make life easier when dealing with duplicate keys, B comes with +a few utility methods. + =head2 The get_dup() Method -B comes with a utility method, called C, to assist in +The C 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 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? Well, the behavior defined in the quote above is -quite useful, so B conforms it. +quite useful, so B 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 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, C, C, C -etc. with the tied array. +array interface is quite limited. In the example script above +C, C, C, C +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 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, L, L, L, L =head1 AUTHOR The DB_File interface was written by Paul Marquess -Epmarquess@bfsec.bt.co.ukE. +EPaul.Marquess@btinternet.comE. Questions about the DB system itself may be addressed to Edb@sleepycat.com. 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 + 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 + 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 (which will be * shortly #included by the ) __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 # 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 +# 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 . + +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 . + +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 . 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 +#include +#include +#include + +#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; icatfile(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() { - $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 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 provides an interface to createing pipes between +C 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 does not have a constuctor of its own as is intended to +C does not have a constructor of its own as it is intended to be inherited by other C 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 #ifdef __linux__ -#include +# include #endif #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) -#include -#ifdef HAS_MSG -#include -#endif -#ifdef HAS_SEM -#include -#endif -#ifdef HAS_SHM -#if defined(PERL_SCO5) || defined(PERL_ISC) -#include -#endif -#include -# ifndef HAS_SHMAT_PROTOTYPE - extern Shmat_t shmat _((int, char *, int)); -# endif +#ifndef HAS_SEM +# include +#endif +# ifdef HAS_MSG +# include +# endif +# ifdef HAS_SHM +# if defined(PERL_SCO) || defined(PERL_ISC) +# include /* SHMLBA */ +# endif +# include +# 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 #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 +# include /* 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 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), weekday (C), and yearday (C) begin at zero. I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The -year (C) is given in years since 1900. I.e. The year 1995 is 95; the +year (C) is given in years since 1900. I.e., the year 1995 is 95; the year 2001 is 101. Consult your system's C manpage for details -about these and the other arguments. +about these and the other arguments. The given arguments are made consistent +by calling C before calling your system's C 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 #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 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. +disallowed with tainted regular expressions. See L. For the purpose of this pragma, interpolation of precompiled regular expressions (i.e., the result of C) is I considered variable -- cgit v1.1