diff options
118 files changed, 3334 insertions, 1162 deletions
@@ -9,6 +9,311 @@ releases.) ---------------- +Version 5.003_23 +---------------- + +This release is our first candidate for a public beta test. + + CORE LANGUAGE CHANGES + + Title: "Disallow changing $_[0] in __DIE__ handlers" + From: Chip Salzenberg <chip@atlantic.net> + Files: pod/perlfunc.pod util.c + + Title: "Fix overloading with inheritance and AUTOLOAD" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199701202226.RAA05072@monk.mps.ohio-state.edu> + Date: Mon, 20 Jan 1997 17:26:32 -0500 (EST) + Files: gv.c lib/diagnostics.pm lib/overload.pm pod/perldebug.pod + pod/perldiag.pod pod/perlfunc.pod pod/perlop.pod + pod/perlre.pod pod/perltoc.pod pod/perlxs.pod + + Title: "Nested here-docs" + From: larry@wall.org (Larry Wall) + Msg-ID: <199701202313.PAA11693@wall.org> + Date: Mon, 20 Jan 1997 15:13:42 -0800 + Files: toke.c + + Title: "Revert $^X to old behavior (plus HP-UX bug fix)" + From: Chip Salzenberg <chip@atlantic.net> + Files: hints/hpux.sh toke.c + + Title: "Protect against '0' in 'stmt while <HANDLE>'" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c + + Title: "Don't warn when closure uses var at file scope" + From: Chip Salzenberg <chip@atlantic.net> + Files: op.c + + CORE PORTABILITY + + Title: "VMS patches for _22" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> + Msg-ID: <01IEGBJ2TMYS003PCL@hmivax.humgen.upenn.edu> + Date: Mon, 20 Jan 1997 22:50:21 -0500 (EST) + Files: ext/POSIX/POSIX.xs lib/ExtUtils/MM_VMS.pm lib/ExtUtils/xsubpp + lib/Test/Harness.pm toke.c vms/Makefile vms/descrip.mms + vms/genconfig.pl vms/perly_c.vms vms/vmsish.h x2p/a2p.h + vms/Makefile vms/config.vms vms/descrip.mms vms/perly_c.vms + + Title: "Re: Perl 5.003_21: OS/2 patches" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199701170446.XAA28939@monk.mps.ohio-state.edu> + Date: Thu, 16 Jan 1997 23:46:40 -0500 (EST) + Files: os2/Changes os2/os2.c + + Title: "Plan9 update" + From: lutherh@stratcom.com (Luther Huffman) + Files: plan9/config.plan9 plan9/mkfile + + Title: "Bugfixes for AmigaOS" + From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de> + Msg-ID: <77724691@Armageddon.meb.uni-bonn.de> + Date: Wed, 22 Jan 1997 00:13:54 +0100 + Files: hints/amigaos.sh lib/File/Basename.pm + + Title: "New dec_osf.sh hints file" + From: Achim Bohnet <ach@rosat.mpe-garching.mpg.de> + Msg-ID: <9701241058.AA29550@o09.rosat.mpe-garching.mpg.de> + Date: Fri, 24 Jan 1997 11:58:24 +0100 + Files: hints/dec_osf.sh + + Title: "on NeXT: gdbm problem fixed" + From: Andreas Koenig <k@anna.in-berlin.de> + Msg-ID: <199701210201.DAA17794@anna.in-berlin.de> + Date: Tue, 21 Jan 1997 03:01:32 +0100 + Files: hints/next_3.sh hints/next_3_0.sh + + Title: "patch for hints/powerux.sh" + From: tom@amber.ssd.hcsc.com (Tom Horsley) + Msg-ID: <9701181833.AA02602@amber.ssd.hcsc.com> + Date: Sat, 18 Jan 97 13:33:26 -0500 + Files: hints/powerux.sh + + Title: "hints & Configure changes to build perl on DC/OSx" + From: Stephen Zander <stephen.zander@interlock.mckesson.com> + Msg-ID: <199701170043.QAA25985@wsbip1.mckesson.com> + Date: Thu, 16 Jan 1997 16:43:52 -0800 + Files: Configure MANIFEST hints/dcosx.sh + + Title: "patch for hints/cxux.sh perl5.003_22" + From: tom@amber.ssd.hcsc.com (Tom Horsley) + Msg-ID: <9701192014.AA05722@amber.ssd.hcsc.com> + Date: Sun, 19 Jan 97 15:14:04 -0500 + Files: hints/cxux.sh + + OTHER CORE CHANGES + + Title: "Make PERL5LIB and -I work like C<use lib>" + From: Tim Bunce <Tim.Bunce@ig.co.uk> + Msg-ID: <9701231523.AA26613@toad.ig.co.uk> + Date: Thu, 23 Jan 1997 15:23:27 +0000 + Files: lib/lib.pm perl.c + + Title: "Fix /\G.a/" + From: Chip Salzenberg <chip@atlantic.net> + Files: regcomp.c regcomp.h regexec.c regexp.h toke.c + + Title: "Extend stack in pp_undef (!)" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c + + Title: "Allow for sub to be redefined while executing" + From: Chip Salzenberg <chip@atlantic.net> + Files: cop.h pp_hot.c t/op/misc.t + + Title: "Eliminate redundant flag CVf_FORMAT" + From: Chip Salzenberg <chip@atlantic.net> + Files: cv.h op.c perl.c perly.c perly.y proto.h sv.c toke.c + + Title: "Generate IVs when possible in abs() and int()" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp.c + + Title: "Efficiency patchlet for pp_aassign()" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199701210305.WAA05451@monk.mps.ohio-state.edu> + Date: Mon, 20 Jan 1997 22:05:39 -0500 (EST) + Files: pp_hot.c + + Title: "When sorting, promote to PVNV only for built-in comparison" + From: Chip Salzenberg <chip@atlantic.net> + Files: pp_ctl.c + + Title: "Remove "suidperl security patch" message" + From: Chip Salzenberg <chip@atlantic.net> + Files: perl.c + + BUILD PROCESS + + Title: "Make configure.gnu a copy of configure; make configure writea + From: Chip Salzenberg <chip@atlantic.net> + Files: MANIFEST configure.gnu + + Title: "Regen Configure with metaconfig: +ARCHNAME, -FILE_filbuf" + From: Chip Salzenberg and Charles Bailey + Files: Configure config_H config_h.SH hints/lynxos.sh + os2/diff.configure os2/os2ish.h plan9/config.plan9 sv.c + utils/perlbug.PL vms/config.vms vms/fndvers.com + + Title: "Compile with optimization when testing memory functions" + From: Chip Salzenberg <chip@atlantic.net> + Files: Configure + + Title: "Minor patch for Debian installation" + From: Chip Salzenberg <chip@atlantic.net> + Files: installperl + + LIBRARY AND EXTENSIONS + + Title: "Debugger update" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199701190455.XAA02579@monk.mps.ohio-state.edu> + Date: Sat, 18 Jan 1997 23:54:59 -0500 (EST) + Files: lib/perl5db.pl + + Title: "DynaLoader enhancement: support RTLD_GLOBAL" + From: Nick Ing-Simmons <nik@tiuk.ti.com> + Msg-ID: <199701240937.JAA11443@pluto.tiuk.ti.com> + Date: Fri, 24 Jan 1997 09:37:18 GMT + Files: ext/DynaLoader/DynaLoader.pm ext/DynaLoader/dl_aix.xs + ext/DynaLoader/dl_dld.xs ext/DynaLoader/dl_dlopen.xs + ext/DynaLoader/dl_hpux.xs ext/DynaLoader/dl_next.xs + ext/DynaLoader/dl_vms.xs + + Title: "Fcntl: add more constants" + From: Jarkko.Hietaniemi@cc.hut.fi + Msg-ID: <199701191811.UAA16346@alpha.hut.fi> + Date: Sun, 19 Jan 1997 20:11:22 +0200 (EET) + Files: ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs + + Title: "Refresh IO to 1.15 (plus DESTROY and new_tmpfile fixes)" + From: Chip Salzenberg <chip@atlantic.net> + Files: ext/IO/lib/IO/File.pm ext/IO/lib/IO/Handle.pm + ext/IO/lib/IO/Pipe.pm ext/IO/lib/IO/Seekable.pm + ext/IO/lib/IO/Socket.pm t/lib/io_pipe.t + + Title: "Allow IO.xs to remain at 1.15 while $VERSION is 1.1501" + From: Chip Salzenberg <chip@atlantic.net> + Files: XSUB.h ext/IO/Makefile.PL ext/IO/lib/IO/Handle.pm + + Title: "Refresh CPAN to 1.15" + From: Andreas Koenig <a.koenig@mind.de> + Files: lib/CPAN.pm lib/CPAN/FirstTime.pm + + Title: "Add E* and SA_* constants" + From: Roderick Schertler <roderick@gate.net> + Msg-ID: <23338.853986967@eeyore.ibcinc.com> + Date: Wed, 22 Jan 1997 21:36:07 -0500 + Files: ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod ext/POSIX/POSIX.xs + + TESTS + + Title: "Test nested here-docs" + From: hv@crypt.compulink.co.uk (Hugo van der Sanden) + Msg-ID: <199701210053.AAA02139@crypt.compulink.co.uk> + Date: Tue, 21 Jan 1997 00:53:44 +0000 (GMT) + Files: t/base/lex.t + + Title: "Fix tests of $^X and $0 to work with QNX" + From: Chip Salzenberg <chip@atlantic.net> + Files: t/lib/io_pipe.t t/lib/open2.t t/lib/open3.t t/op/magic.t + + Title: "Patch tests for systems without fork()" + From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de> + Msg-ID: <77724697@Armageddon.meb.uni-bonn.de> + Date: Thu, 23 Jan 1997 23:51:28 +0100 + Files: t/io/pipe.t t/lib/filehand.t t/lib/io_pipe.t t/lib/io_sock.t + t/lib/open2.t t/lib/open3.t t/op/fork.t + + Title: "Test patches for OS/2" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199701170448.XAA28948@monk.mps.ohio-state.edu> + Date: Thu, 16 Jan 1997 23:48:18 -0500 (EST) + Files: os2/OS2/ExtAttr/t/os2_ea.t os2/OS2/PrfDB/t/os2_prfdb.t + os2/OS2/REXX/t/rx_cmprt.t os2/OS2/REXX/t/rx_dllld.t + os2/OS2/REXX/t/rx_objcall.t os2/OS2/REXX/t/rx_sql.test + os2/OS2/REXX/t/rx_tiesql.test os2/OS2/REXX/t/rx_tievar.t + os2/OS2/REXX/t/rx_tieydb.t os2/OS2/REXX/t/rx_varset.t + os2/OS2/REXX/t/rx_vrexx.t t/README t/cmd/while.t + t/comp/colon.t t/comp/multiline.t t/io/argv.t t/lib/anydbm.t + t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t t/lib/sdbm.t + t/op/cmp.t t/op/magic.t + + UTILITIES + + Title: "Translate \200 to È in pod2html" + From: Chip Salzenberg <chip@atlantic.net> + Files: pod/pod2html.PL + + Title: "VMS patches: '.com' extension on scripts" + From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU> + Msg-ID: <01IELNPDLYJM003E7J@hmivax.humgen.upenn.edu> + Date: Fri, 24 Jan 1997 18:42:29 -0500 (EST) + Files: pod/checkpods.PL pod/pod2html.PL pod/pod2latex.PL + pod/pod2man.PL pod/pod2text.PL utils/c2ph.PL utils/h2ph.PL + utils/h2xs.PL utils/perlbug.PL utils/perldoc.PL + utils/pl2pm.PL utils/splain.PL vms/Makefile vms/descrip.mms + x2p/find2perl.PL x2p/s2p.PL + + Title: "Allow MakeMaker 5.34 to use libraries containing '+' in name" + From: dennism@cyrix.com (Dennis Marsa) + Msg-ID: <9701172027.AA27861@orion.cyrix.com> + Date: Fri, 17 Jan 97 14:27:32 CST + Files: lib/ExtUtils/Liblist.pm + + DOCUMENTATION + + Title: "First cut at INSTALL edit" + From: Chip Salzenberg <chip@atlantic.net> + Files: INSTALL + + Title: "Additional docs for __DIE__ and __WARN__" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Files: pod/perlfunc.pod pod/perlrun.pod pod/perlvar.pod + + Title: "Document #line directive" + From: Gurusamy Sarathy <gsar@engin.umich.edu> + Msg-ID: <199701240908.EAA23846@aatma.engin.umich.edu> + Date: Fri, 24 Jan 1997 04:08:44 -0500 + Files: pod/perlsyn.pod pod/perltoc.pod + + Title: "Perlguts version 30" + From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com> + Msg-ID: <199701172117.AA116515863@hpcc123.corp.hp.com> + Date: Fri, 17 Jan 1997 13:17:43 -0800 + Files: pod/perlguts.pod + + Title: "delta for perldelta" + From: Tom Christiansen <tchrist@mox.perl.com> + Msg-ID: <804.854121463@jinete> + Date: Fri, 24 Jan 1997 07:57:43 -0800 + Files: pod/perlnews.pod pod/perltoc.pod + + Title: "Updates to perldelta" + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Msg-ID: <199701211610.LAA06227@monk.mps.ohio-state.edu> + Date: Mon, 20 Jan 1997 06:48:49 -0500 (EST) + Files: pod/perlnews.pod pod/perltoc.pod + + Title: "perlnews.pod diff for the Fcntl" + From: Jarkko Hietaniemi <jhi@cc.hut.fi> + Msg-ID: <199701211600.SAA30117@alpha.hut.fi> + Date: Tue, 21 Jan 1997 18:00:56 +0200 (EET) + Files: pod/perlnews.pod + + Title: "Rename perlnews -> perldelta per Tom's request" + From: Chip Salzenberg <chip@atlantic.net> + Files: MANIFEST pod/Makefile pod/buildtoc pod/perl.pod + pod/perldelta.pod pod/perltoc.pod pod/roffitall + + Title: "Remove bad advice from perllocale.pod" + From: Chip Salzenberg <chip@atlantic.net> + Files: pod/perllocale.pod + + +---------------- Version 5.003_22 ---------------- @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.8 1995/07/25 13:40:02 ram Exp $ # -# Generated on Tue Dec 17 14:33:33 EST 1996 [metaconfig 3.0 PL60] +# Generated on Thu Jan 23 14:39:28 EST 1997 [metaconfig 3.0 PL60] cat >/tmp/c1$$ <<EOF ARGGGHHHH!!!!! @@ -390,7 +390,6 @@ d_stdstdio='' stdio_base='' stdio_bufsiz='' stdio_cnt='' -stdio_filbuf='' stdio_ptr='' d_index='' d_strchr='' @@ -1707,6 +1706,9 @@ EOM *) osvers=$tmp;; esac ;; + *dc.osx) osname=dcosx + osvers="$3" + ;; dnix) osname=dnix osvers="$3" ;; @@ -2434,7 +2436,7 @@ else fi : set the base revision -baserev=5 +baserev=5.0 : get the patchlevel echo " " @@ -2466,23 +2468,26 @@ set archlib archlib eval $prefixit case "$archlib" in '') - case "$privlib" in - '') dflt=`./loc . "." $prefixexp/lib /usr/local/lib /usr/lib /lib` - set dflt - eval $prefixup - ;; - *) if test 0 -eq "$subversion"; then - version=`echo $baserev $patchlevel | \ - $awk '{ printf "%d.%03d\n",$1,$2 }'` - else - version=`echo $baserev $patchlevel $subversion | \ - $awk '{ printf "%d.%03d%02d\n",$1,$2,$3 }'` - fi - dflt="$privlib/$archname/$version" - ;; - esac + case "$privlib" in + '') dflt=`./loc . "." $prefixexp/lib /usr/local/lib /usr/lib /lib` + set dflt + eval $prefixup ;; -*) dflt="$archlib";; + *) if test 0 -eq "$subversion"; then + version=`LC_ALL=C; export LC_ALL; \ + echo $baserev $patchlevel | \ + $awk '{ printf "%.3f\n", $1 + $2/1000.0 }'` + else + version=`LC_ALL=C; export LC_ALL; \ + echo $baserev $patchlevel $subversion | \ + $awk '{ printf "%.5f\n", $1 + $2/1000.0 + $3/100000.0 }'` + fi + ;; + esac + ;; +*) + dflt="$archlib" + ;; esac cat <<EOM @@ -5158,7 +5163,7 @@ case "$myhostname" in .) dflt=.`$sed -n -e 's/ / /g' \ -e 's/^domain *\([^ ]*\).*/\1/p' $tans \ | ./tr '[A-Z]' '[a-z]' 2>/dev/null` - ;; + ;; esac fi ;; @@ -6418,9 +6423,7 @@ main() } EOCP if $cc $ccflags $ldflags try.c -o try >/dev/null 2>&1; then - cat <<EOS >mtry -$startsh -EOS + echo "$startsh" >mtry echo "./try >try.out 2>try.ret 3>try.err || exit 4" >>mtry chmod +x mtry ./mtry >/dev/null 2>&1 @@ -7048,7 +7051,8 @@ for (align = 7; align >= 0; align--) { exit(0); } EOCP - if $cc $ccflags $ldflags foo.c -o safebcpy $libs >/dev/null 2>&1; then + if $cc $optimize $ccflags $ldflags foo.c \ + -o safebcpy $libs >/dev/null 2>&1; then if ./safebcpy 2>/dev/null; then echo "Yes, it can." val="$define" @@ -7126,7 +7130,8 @@ for (align = 7; align >= 0; align--) { exit(0); } EOCP - if $cc $ccflags $ldflags foo.c -o safemcpy $libs >/dev/null 2>&1; then + if $cc $optimize $ccflags $ldflags foo.c \ + -o safemcpy $libs >/dev/null 2>&1; then if ./safemcpy 2>/dev/null; then echo "Yes, it can." val="$define" @@ -7186,7 +7191,8 @@ if ((a < b) && memcmp(&a, &b, 1) < 0) exit(0); } EOCP - if $cc $ccflags $ldflags foo.c -o sanemcmp $libs >/dev/null 2>&1; then + if $cc $optimize $ccflags $ldflags foo.c \ + -o sanemcmp $libs >/dev/null 2>&1; then if ./sanemcmp 2>/dev/null; then echo "Yes, it can." val="$define" @@ -7635,47 +7641,6 @@ esac set d_stdio_cnt_lval eval $setvar -: How to access the stdio _filbuf or __filbuf function. -: If this fails, check how the getc macro in stdio.h works. -case "${d_stdio_ptr_lval}${d_stdio_cnt_lval}" in -${define}${define}) - : Try $hint value, if any, then _filbuf, __filbuf, _fill, then punt. - : _fill is for os/2. - xxx='notok' - for filbuf in $stdio_filbuf '_filbuf(fp)' '__filbuf(fp) ' '_fill(fp)' ; do - $cat >try.c <<EOP -#include <stdio.h> -#define FILE_ptr(fp) $stdio_ptr -#define FILE_cnt(fp) $stdio_cnt -#define FILE_filbuf(fp) $filbuf -main() { - FILE *fp = fopen("try.c", "r"); - int c; - c = getc(fp); - c = FILE_filbuf(fp); /* Just looking for linker errors.*/ - exit(0); -} -EOP - if $cc $ccflags $ldflags -o try try.c $libs >/dev/null 2>&1 && ./try; then - echo "Your stdio appears to use $filbuf" - stdio_filbuf="$filbuf" - xxx='ok' - break - else - echo "Hmm. $filbuf doesn't seem to work." - fi - $rm -f try.c try - done - case "$xxx" in - notok) echo "I can't figure out how to access _filbuf" - echo "I'll just have to work around it." - d_stdio_ptr_lval="$undef" - d_stdio_cnt_lval="$undef" - ;; - esac - ;; -esac - : see if _base is also standard val="$undef" @@ -10298,7 +10263,6 @@ stdchar='$stdchar' stdio_base='$stdio_base' stdio_bufsiz='$stdio_bufsiz' stdio_cnt='$stdio_cnt' -stdio_filbuf='$stdio_filbuf' stdio_ptr='$stdio_ptr' strings='$strings' submit='$submit' @@ -4,8 +4,9 @@ Changes5.000 Differences between 4.x and 5.000 Changes5.001 Differences between 5.000 and 5.001 Changes5.002 Differences between 5.001 and 5.002 Changes5.003 Differences between 5.002 and 5.003 -Configure Portability tool configure Crude emulation of GNU configure +configure.gnu Copy of configure (for case-insensitive systems) +Configure Portability tool Copying The GNU General Public License EXTERN.h Included before foreign .h files INSTALL Detailed installation instructions @@ -208,6 +209,7 @@ hints/broken-db.msg Warning message for systems with broken DB library hints/bsdos.sh Hints for named architecture hints/convexos.sh Hints for named architecture hints/cxux.sh Hints for named architecture +hints/dcosx.sh Hints for named architecture hints/dec_osf.sh Hints for named architecture hints/dgux.sh Hints for named architecture hints/dynix.sh Hints for named architecture @@ -495,6 +497,7 @@ pod/perlbot.pod Object-oriented Bag o' Tricks pod/perlcall.pod Callback info pod/perldata.pod Data structure info pod/perldebug.pod Debugger info +pod/perldelta.pod Changes since last version pod/perldiag.pod Diagnostic info pod/perldsc.pod Data Structures Cookbook pod/perlembed.pod Embedding info @@ -505,7 +508,6 @@ pod/perlipc.pod IPC info pod/perllocale.pod Locale support info pod/perllol.pod How to use lists of lists pod/perlmod.pod Module info -pod/perlnews.pod News of changes since last version pod/perlobj.pod Object info pod/perlop.pod Operator info pod/perlpod.pod Pod info @@ -1,7 +1,7 @@ Perl Kit, Version 5.0 - Copyright 1989-1996, Larry Wall + Copyright 1989-1997, Larry Wall All rights reserved. This program is free software; you can redistribute it and/or modify @@ -38,19 +38,25 @@ #ifdef XS_VERSION # define XS_VERSION_BOOTCHECK \ - STMT_START { \ - char vn[255], *module = SvPV(ST(0),na); \ - if (items >= 2) /* version supplied as bootstrap arg */ \ - Sv=ST(1); \ - else { /* read version from module::VERSION */ \ - sprintf(vn,"%s::VERSION", module); \ - Sv = perl_get_sv(vn, FALSE); /* XXX GV_ADDWARN */ \ - } \ - if (Sv && (!SvOK(Sv) || strNE(XS_VERSION, SvPV(Sv,na))) ) \ - croak("%s object version %s does not match %s.pm $VERSION %s", \ - module,XS_VERSION, module,(Sv && SvOK(Sv))?SvPV(Sv,na):"(undef)");\ + STMT_START { \ + char vn[255], *module = SvPV(ST(0),na); \ + if (items >= 2) /* version supplied as bootstrap arg */ \ + Sv = ST(1); \ + else { \ + sprintf(vn,"%s::XS_VERSION", module); \ + Sv = perl_get_sv(vn, FALSE); /* XXX GV_ADDWARN */ \ + if (!Sv || !SvOK(Sv)) { \ + sprintf(vn,"%s::VERSION", module); \ + Sv = perl_get_sv(vn, FALSE); /* XXX GV_ADDWARN */ \ + } \ + } \ + if (!Sv || !SvOK(Sv)) \ + croak("%s object can't find $%s::XS_VERSION or $%s::VERSION", \ + module, module, module); \ + else if (strNE(XS_VERSION, SvPV(Sv, na))) \ + croak("%s object version %s does not match $%s %s", \ + module, XS_VERSION, vn, SvPV(Sv, na)); \ } STMT_END #else # define XS_VERSION_BOOTCHECK #endif - @@ -28,6 +28,14 @@ */ #define MEM_ALIGNBYTES 4 /**/ +/* ARCHNAME: + * This symbol holds a string representing the architecture name. + * It may be used to construct an architecture-dependant pathname + * where library files may be held under a private library, for + * instance. + */ +#define ARCHNAME "unknown" /**/ + /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. @@ -335,13 +343,6 @@ #define HAS_NTOHL /**/ #define HAS_NTOHS /**/ -/* HAS_INET_ATON: - * This symbol, if defined, indicates to the C program that the - * inet_aton() function is available to parse IP address "dotted-quad" - * strings. - */ -#define HAS_INET_ATON /**/ - /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. @@ -723,22 +724,12 @@ * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ -/* FILE_filbuf: - * This macro is used to access the internal stdio _filbuf function - * (or equivalent), if STDIO_CNT_LVALUE and STDIO_PTR_LVALUE - * are defined. It is typically either _filbuf or __filbuf. - * This macro will only be defined if both STDIO_CNT_LVALUE and - * STDIO_PTR_LVALUE are defined. - */ #define USE_STDIO_PTR /**/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) ((fp)->_ptr) #define STDIO_PTR_LVALUE /**/ #define FILE_cnt(fp) ((fp)->_cnt) #define STDIO_CNT_LVALUE /**/ -#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) -#define FILE_filbuf(fp) _filbuf(fp) /**/ -#endif #endif /* USE_STDIO_BASE: @@ -813,19 +804,19 @@ /* HAS_STRTOD: * This symbol, if defined, indicates that the strtod routine is - * available to translate strings to doubles. + * available to provide better numeric string conversion than atof(). */ #define HAS_STRTOD /**/ /* HAS_STRTOL: - * This symbol, if defined, indicates that the strtol routine is - * available to translate strings to integers. + * This symbol, if defined, indicates that the strtol routine is available + * to provide better numeric string conversion than atoi() and friends. */ #define HAS_STRTOL /**/ /* HAS_STRTOUL: * This symbol, if defined, indicates that the strtoul routine is - * available to translate strings to integers. + * available to provide conversion of strings to unsigned long. */ #define HAS_STRTOUL /**/ @@ -1290,6 +1281,33 @@ */ #define Mode_t mode_t /* file mode parameter for system calls */ +/* VAL_O_NONBLOCK: + * This symbol is to be used during open() or fcntl(F_SETFL) to turn on + * non-blocking I/O for the file descriptor. Note that there is no way + * back, i.e. you cannot turn it blocking again this way. If you wish to + * alternatively switch between blocking and non-blocking, use the + * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. + */ +/* VAL_EAGAIN: + * This symbol holds the errno error code set by read() when no data was + * present on the non-blocking file descriptor. + */ +/* RD_NODATA: + * This symbol holds the return code from read() when no data is present + * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is + * not defined, then you can't distinguish between no data and EOF by + * issuing a read(). You'll have to find another way to tell for sure! + */ +/* EOF_NONBLOCK: + * This symbol, if defined, indicates to the C program that a read() on + * a non-blocking file descriptor will return 0 on EOF, and not the value + * held in RD_NODATA (-1 usually, in that case!). + */ +#define VAL_O_NONBLOCK O_NONBLOCK +#define VAL_EAGAIN EAGAIN +#define RD_NODATA -1 +#define EOF_NONBLOCK + /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. @@ -1338,6 +1356,16 @@ */ #define Size_t size_t /* length paramater for string functions */ +/* SSize_t: + * This symbol holds the type used by functions that return + * a count of bytes or an error condition. It must be a signed type. + * It is usually ssize_t, but may be long or int, etc. + * It may be necessary to include <sys/types.h> or <unistd.h> + * to get any typedef'ed information. + * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). + */ +#define SSize_t ssize_t /* signed count of bytes */ + /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". @@ -1477,6 +1505,13 @@ #define HAS_GETPGRP /**/ /*#define USE_BSD_GETPGRP / **/ +/* HAS_INET_ATON: + * This symbol, if defined, indicates to the C program that the + * inet_aton() function is available to parse IP address "dotted-quad" + * strings. + */ +#define HAS_INET_ATON /**/ + /* HAS_SETPGID: * This symbol, if defined, indicates to the C program that * the setpgid(pid, gpid) function is available to set the @@ -1591,33 +1626,6 @@ */ #define MYMALLOC /**/ -/* VAL_O_NONBLOCK: - * This symbol is to be used during open() or fcntl(F_SETFL) to turn on - * non-blocking I/O for the file descriptor. Note that there is no way - * back, i.e. you cannot turn it blocking again this way. If you wish to - * alternatively switch between blocking and non-blocking, use the - * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. - */ -/* VAL_EAGAIN: - * This symbol holds the errno error code set by read() when no data was - * present on the non-blocking file descriptor. - */ -/* RD_NODATA: - * This symbol holds the return code from read() when no data is present - * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is - * not defined, then you can't distinguish between no data and EOF by - * issuing a read(). You'll have to find another way to tell for sure! - */ -/* EOF_NONBLOCK: - * This symbol, if defined, indicates to the C program that a read() on - * a non-blocking file descriptor will return 0 on EOF, and not the value - * held in RD_NODATA (-1 usually, in that case!). - */ -#define VAL_O_NONBLOCK O_NONBLOCK -#define VAL_EAGAIN EAGAIN -#define RD_NODATA -1 -#define EOF_NONBLOCK - /* OLDARCHLIB: * This variable, if defined, holds the name of the directory in * which the user has perl5.000 or perl5.001 architecture-dependent @@ -1718,16 +1726,6 @@ #define SITELIB "/opt/perl/lib/site_perl" /**/ #define SITELIB_EXP "/opt/perl/lib/site_perl" /**/ -/* SSize_t: - * This symbol holds the type used by functions that return - * a count of bytes or an error condition. It must be a signed type. - * It is usually ssize_t, but may be long or int, etc. - * It may be necessary to include <sys/types.h> or <unistd.h> - * to get any typedef'ed information. - * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). - */ -#define SSize_t ssize_t /* signed count of bytes */ - /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not diff --git a/config_h.SH b/config_h.SH index c6d662aaa0..9b9236e125 100755 --- a/config_h.SH +++ b/config_h.SH @@ -42,6 +42,14 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #define MEM_ALIGNBYTES $alignbytes /**/ +/* ARCHNAME: + * This symbol holds a string representing the architecture name. + * It may be used to construct an architecture-dependant pathname + * where library files may be held under a private library, for + * instance. + */ +#define ARCHNAME "$archname" /**/ + /* BIN: * This symbol holds the path of the bin directory where the package will * be installed. Program must be prepared to deal with ~name substitution. @@ -349,13 +357,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #$d_htonl HAS_NTOHL /**/ #$d_htonl HAS_NTOHS /**/ -/* HAS_INET_ATON: - * This symbol, if defined, indicates to the C program that the - * inet_aton() function is available to parse IP address "dotted-quad" - * strings. - */ -#$d_inetaton HAS_INET_ATON /**/ - /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. @@ -737,22 +738,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- * This symbol is defined if the FILE_cnt macro can be used as an * lvalue. */ -/* FILE_filbuf: - * This macro is used to access the internal stdio _filbuf function - * (or equivalent), if STDIO_CNT_LVALUE and STDIO_PTR_LVALUE - * are defined. It is typically either _filbuf or __filbuf. - * This macro will only be defined if both STDIO_CNT_LVALUE and - * STDIO_PTR_LVALUE are defined. - */ #$d_stdstdio USE_STDIO_PTR /**/ #ifdef USE_STDIO_PTR #define FILE_ptr(fp) $stdio_ptr #$d_stdio_ptr_lval STDIO_PTR_LVALUE /**/ #define FILE_cnt(fp) $stdio_cnt #$d_stdio_cnt_lval STDIO_CNT_LVALUE /**/ -#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) -#define FILE_filbuf(fp) $stdio_filbuf /**/ -#endif #endif /* USE_STDIO_BASE: @@ -1304,6 +1295,33 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #define Mode_t $modetype /* file mode parameter for system calls */ +/* VAL_O_NONBLOCK: + * This symbol is to be used during open() or fcntl(F_SETFL) to turn on + * non-blocking I/O for the file descriptor. Note that there is no way + * back, i.e. you cannot turn it blocking again this way. If you wish to + * alternatively switch between blocking and non-blocking, use the + * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. + */ +/* VAL_EAGAIN: + * This symbol holds the errno error code set by read() when no data was + * present on the non-blocking file descriptor. + */ +/* RD_NODATA: + * This symbol holds the return code from read() when no data is present + * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is + * not defined, then you can't distinguish between no data and EOF by + * issuing a read(). You'll have to find another way to tell for sure! + */ +/* EOF_NONBLOCK: + * This symbol, if defined, indicates to the C program that a read() on + * a non-blocking file descriptor will return 0 on EOF, and not the value + * held in RD_NODATA (-1 usually, in that case!). + */ +#define VAL_O_NONBLOCK $o_nonblock +#define VAL_EAGAIN $eagain +#define RD_NODATA $rd_nodata +#$d_eofnblk EOF_NONBLOCK + /* CAN_PROTOTYPE: * If defined, this macro indicates that the C compiler can handle * function prototypes. @@ -1352,6 +1370,16 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #define Size_t $sizetype /* length paramater for string functions */ +/* SSize_t: + * This symbol holds the type used by functions that return + * a count of bytes or an error condition. It must be a signed type. + * It is usually ssize_t, but may be long or int, etc. + * It may be necessary to include <sys/types.h> or <unistd.h> + * to get any typedef'ed information. + * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). + */ +#define SSize_t $ssizetype /* signed count of bytes */ + /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". @@ -1491,6 +1519,13 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #$d_getpgrp HAS_GETPGRP /**/ #$d_bsdgetpgrp USE_BSD_GETPGRP /**/ +/* HAS_INET_ATON: + * This symbol, if defined, indicates to the C program that the + * inet_aton() function is available to parse IP address "dotted-quad" + * strings. + */ +#$d_inetaton HAS_INET_ATON /**/ + /* HAS_SETPGID: * This symbol, if defined, indicates to the C program that * the setpgid(pid, gpid) function is available to set the @@ -1605,33 +1640,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_mymalloc MYMALLOC /**/ -/* VAL_O_NONBLOCK: - * This symbol is to be used during open() or fcntl(F_SETFL) to turn on - * non-blocking I/O for the file descriptor. Note that there is no way - * back, i.e. you cannot turn it blocking again this way. If you wish to - * alternatively switch between blocking and non-blocking, use the - * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. - */ -/* VAL_EAGAIN: - * This symbol holds the errno error code set by read() when no data was - * present on the non-blocking file descriptor. - */ -/* RD_NODATA: - * This symbol holds the return code from read() when no data is present - * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is - * not defined, then you can't distinguish between no data and EOF by - * issuing a read(). You'll have to find another way to tell for sure! - */ -/* EOF_NONBLOCK: - * This symbol, if defined, indicates to the C program that a read() on - * a non-blocking file descriptor will return 0 on EOF, and not the value - * held in RD_NODATA (-1 usually, in that case!). - */ -#define VAL_O_NONBLOCK $o_nonblock -#define VAL_EAGAIN $eagain -#define RD_NODATA $rd_nodata -#$d_eofnblk EOF_NONBLOCK - /* OLDARCHLIB: * This variable, if defined, holds the name of the directory in * which the user has perl5.000 or perl5.001 architecture-dependent @@ -1732,16 +1740,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #define SITELIB "$sitelib" /**/ #define SITELIB_EXP "$sitelibexp" /**/ -/* SSize_t: - * This symbol holds the type used by functions that return - * a count of bytes or an error condition. It must be a signed type. - * It is usually ssize_t, but may be long or int, etc. - * It may be necessary to include <sys/types.h> or <unistd.h> - * to get any typedef'ed information. - * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). - */ -#define SSize_t $ssizetype /* signed count of bytes */ - /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not diff --git a/configure.gnu b/configure.gnu index e69de29bb2..868e454111 100755 --- a/configure.gnu +++ b/configure.gnu @@ -0,0 +1,120 @@ +#! /bin/sh +# +# $Id: configure,v 3.0.1.1 1995/07/25 14:16:21 ram Exp $ +# +# GNU configure-like front end to metaconfig's Configure. +# +# Written by Andy Dougherty <doughera@lafcol.lafayette.edu> +# and Matthew Green <mrg@mame.mu.oz.au>. +# +# Reformatted and modified for inclusion in the dist-3.0 package by +# Raphael Manfredi <ram@hptnos02.grenoble.hp.com>. +# +# This script belongs to the public domain and may be freely redistributed. +# +# The remaining of this leading shell comment may be removed if you +# include this script in your own package. +# +# $Log: configure,v $ +# Revision 3.0.1.1 1995/07/25 14:16:21 ram +# patch56: created +# + +(exit $?0) || exec sh $0 $argv:q + +case "$0" in +*configure) + if cmp $0 `echo $0 | sed -e s/configure/Configure/` >/dev/null; then + echo "Your configure and Configure scripts seem to be identical." + echo "This can happen on filesystems that aren't fully case sensitive." + echo "You'll have to explicitely extract Configure and run that." + exit 1 + fi + ;; +esac + +opts='' +verbose='' +create='-e' +while test $# -gt 0; do + case $1 in + --help) + cat <<EOM +Usage: configure [options] +This is GNU configure-like front end for a metaconfig-generated Configure. +It emulates the following GNU configure options (must be fully spelled out): + --help + --no-create + --prefix=PREFIX + --quiet + --silent + --verbose + --version + +And it honours these environment variables: CC, CFLAGS and DEFS. +EOM + exit 0 + ;; + --no-create) + create='-E' + shift + ;; + --prefix=*) + arg=`echo $1 | sed 's/--prefix=/-Dprefix=/'` + opts="$opts $arg" + shift + ;; + --quiet|--silent) + exec >/dev/null 2>&1 + shift + ;; + --verbose) + verbose=true + shift + ;; + --version) + copt="$copt -V" + shift + ;; + --*) + opt=`echo $1 | sed 's/=.*//'` + echo "This GNU configure front end does not understand $opt" + exit 1 + ;; + *) + opts="$opts $1" + shift + ;; + esac +done + +case "$CC" in +'') ;; +*) opts="$opts -Dcc='$CC'";; +esac + +# Join DEFS and CFLAGS together. +ccflags='' +case "$DEFS" in +'') ;; +*) ccflags=$DEFS;; +esac +case "$CFLAGS" in +'') ;; +*) ccflags="$ccflags $CFLAGS";; +esac +case "$ccflags" in +'') ;; +*) opts="$opts -Dccflags='$ccflags'";; +esac + +# Don't use -s if they want verbose mode +case "$verbose" in +'') copt="$copt -ds";; +*) copt="$copt -d";; +esac + +set X sh Configure $copt $create $opts +shift +echo "$@" +exec "$@" @@ -49,9 +49,13 @@ struct block_sub { /* We muck with cxstack_ix since _dec may call a DESTROY, overwriting cx. */ #define POPSUB(cx) \ - if (cx->blk_sub.hasargs) { /* put back old @_ */ \ + if (cx->blk_sub.hasargs) { \ + /* put back old @_ */ \ SvREFCNT_dec(GvAV(defgv)); \ GvAV(defgv) = cx->blk_sub.savearray; \ + /* destroy arg array */ \ + av_clear(cx->blk_sub.argarray); \ + AvREAL_off(cx->blk_sub.argarray); \ } \ if (cx->blk_sub.cv) { \ if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) { \ @@ -52,7 +52,6 @@ struct xpvcv { #define CVf_UNIQUE 0x10 /* can't be cloned */ #define CVf_NODEBUG 0x20 /* no DB::sub indirection for this CV (esp. useful for special XSUBs) */ -#define CVf_FORMAT 0x40 /* is a format, not a sub */ #define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE) #define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE) @@ -74,10 +73,6 @@ struct xpvcv { #define CvUNIQUE_on(cv) (CvFLAGS(cv) |= CVf_UNIQUE) #define CvUNIQUE_off(cv) (CvFLAGS(cv) &= ~CVf_UNIQUE) -#define CvFORMAT(cv) (CvFLAGS(cv) & CVf_FORMAT) -#define CvFORMAT_on(cv) (CvFLAGS(cv) |= CVf_FORMAT) -#define CvFORMAT_off(cv) (CvFLAGS(cv) &= ~CVf_FORMAT) - #define CvNODEBUG(cv) (CvFLAGS(cv) & CVf_NODEBUG) #define CvNODEBUG_on(cv) (CvFLAGS(cv) |= CVf_NODEBUG) #define CvNODEBUG_off(cv) (CvFLAGS(cv) &= ~CVf_NODEBUG) diff --git a/ext/IO/Makefile.PL b/ext/IO/Makefile.PL index eb059bf8e7..4a34be61fb 100644 --- a/ext/IO/Makefile.PL +++ b/ext/IO/Makefile.PL @@ -4,4 +4,5 @@ WriteMakefile( 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/ext/IO/lib/IO/File.pm b/ext/IO/lib/IO/File.pm index e44d77f1fe..0f8df001de 100644 --- a/ext/IO/lib/IO/File.pm +++ b/ext/IO/lib/IO/File.pm @@ -11,12 +11,12 @@ IO::File - supply object methods for filehandles use IO::File; $fh = new IO::File; - if ($fh->open "< file") { + if ($fh->open("< file")) { print <$fh>; $fh->close; } - $fh = new IO::File "> FOO"; + $fh = new IO::File "> file"; if (defined $fh) { print $fh "bar\n"; $fh->close; @@ -31,13 +31,12 @@ IO::File - supply object methods for filehandles $fh = new IO::File "file", O_WRONLY|O_APPEND; if (defined $fh) { print $fh "corge\n"; - undef $fh; # automatically closes the file - } - $pos = $fh->getpos; - $fh->setpos $pos; + $pos = $fh->getpos; + $fh->setpos($pos); - $fh->setvbuf($buffer_var, _IOLBF, 1024); + undef $fh; # automatically closes the file + } autoflush STDOUT 1; diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm index 03118ee55e..135351fac0 100644 --- a/ext/IO/lib/IO/Handle.pm +++ b/ext/IO/lib/IO/Handle.pm @@ -1,3 +1,4 @@ + package IO::Handle; =head1 NAME @@ -9,39 +10,33 @@ IO::Handle - supply object methods for I/O handles use IO::Handle; $fh = new IO::Handle; - if ($fh->open "< file") { - print <$fh>; - $fh->close; - } - - $fh = new IO::Handle "> FOO"; - if (defined $fh) { - print $fh "bar\n"; + if ($fh->fdopen(fileno(STDIN),"r")) { + print $fh->getline; $fh->close; } - $fh = new IO::Handle "file", "r"; - if (defined $fh) { - print <$fh>; - undef $fh; # automatically closes the file - } - - $fh = new IO::Handle "file", O_WRONLY|O_APPEND; - if (defined $fh) { - print $fh "corge\n"; - undef $fh; # automatically closes the file + $fh = new IO::Handle; + if ($fh->fdopen(fileno(STDOUT),"w")) { + $fh->print("Some text\n"); } - $pos = $fh->getpos; - $fh->setpos $pos; - $fh->setvbuf($buffer_var, _IOLBF, 1024); + undef $fh; # automatically closes the file if it's open + autoflush STDOUT 1; =head1 DESCRIPTION -C<IO::Handle> is the base class for all other IO handle classes. +C<IO::Handle> is the base class for all other IO handle classes. It is +not intended that objects of C<IO::Handle> would be created directly, +but instead C<IO::Handle> is inherited from by several other classes +in the IO hierarchy. + +If you are reading this documentation, looking for a replacement for +the C<FileHandle> package, then I suggest you read the documentation +for C<IO::File> + A C<IO::Handle> object is a reference to a symbol (see the C<Symbol> package) =head1 CONSTRUCTOR @@ -167,7 +162,7 @@ module keeps a C<timeout> variable in 'io_socket_timeout'. L<perlfunc>, L<perlop/"I/O Operators">, -L<FileHandle> +L<IO::File> =head1 BUGS @@ -184,7 +179,7 @@ Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt> require 5.000; use strict; -use vars qw($VERSION @EXPORT_OK $AUTOLOAD @ISA); +use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA); use Carp; use Symbol; use SelectSaver; @@ -192,7 +187,8 @@ use SelectSaver; require Exporter; @ISA = qw(Exporter); -$VERSION = "1.1402"; +$VERSION = "1.1501"; +$XS_VERSION = "1.15"; @EXPORT_OK = qw( autoflush @@ -231,7 +227,7 @@ $VERSION = "1.1402"; require DynaLoader; @IO::ISA = qw(DynaLoader); -bootstrap IO $VERSION; +bootstrap IO $XS_VERSION; sub AUTOLOAD { if ($AUTOLOAD =~ /::(_?[a-z])/) { @@ -314,14 +310,8 @@ sub fdopen { sub close { @_ == 1 or croak 'usage: $fh->close()'; my($fh) = @_; - my $r = close($fh); - - # This may seem as though it should be in IO::Pipe, but the - # object gets blessed out of IO::Pipe when reader/writer is called - waitpid(${*$fh}{'io_pipe_pid'},0) - if(defined ${*$fh}{'io_pipe_pid'}); - $r; + close($fh); } ################################################ diff --git a/ext/IO/lib/IO/Pipe.pm b/ext/IO/lib/IO/Pipe.pm index 34cb0daad2..499856a6c6 100644 --- a/ext/IO/lib/IO/Pipe.pm +++ b/ext/IO/lib/IO/Pipe.pm @@ -1,7 +1,145 @@ +# IO::Pipe.pm # +# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights +# reserved. This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. package IO::Pipe; +require 5.000; + +use IO::Handle; +use strict; +use vars qw($VERSION); +use Carp; +use Symbol; + +$VERSION = "1.09"; + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::Pipe"; + @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]"; + + my $me = bless gensym(), $class; + + my($readfh,$writefh) = @_ ? @_ : $me->handles; + + pipe($readfh, $writefh) + or return undef; + + @{*$me} = ($readfh, $writefh); + + $me; +} + +sub handles { + @_ == 1 or croak 'usage: $pipe->handles()'; + (IO::Pipe::End->new(), IO::Pipe::End->new()); +} + +my $do_spawn = $^O eq 'os2'; + +sub _doit { + my $me = shift; + my $rw = shift; + + my $pid = $do_spawn ? 0 : fork(); + + if($pid) { # Parent + return $pid; + } + elsif(defined $pid) { # Child or spawn + my $fh; + my $io = $rw ? \*STDIN : \*STDOUT; + my ($mode, $save) = $rw ? "r" : "w"; + if ($do_spawn) { + require Fcntl; + $save = IO::Handle->new_from_fd($io, $mode); + # Close in child: + fcntl(shift, Fcntl::F_SETFD(), 1) or croak "fcntl: $!"; + $fh = $rw ? ${*$me}[0] : ${*$me}[1]; + } else { + shift; + $fh = $rw ? $me->reader() : $me->writer(); # close the other end + } + bless $io, "IO::Handle"; + $io->fdopen($fh, $mode); + + if ($do_spawn) { + $pid = eval { system 1, @_ }; # 1 == P_NOWAIT + my $err = $!; + + $io->fdopen($save, $mode); + $save->close or croak "Cannot close $!"; + croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0; + return $pid; + } else { + exec @_ or + croak "IO::Pipe: Cannot exec: $!"; + } + } + else { + croak "IO::Pipe: Cannot fork: $!"; + } + + # NOT Reached +} + +sub reader { + @_ >= 1 or croak 'usage: $pipe->reader()'; + my $me = shift; + my $fh = ${*$me}[0]; + my $pid = $me->_doit(0, $fh, @_) + if(@_); + + close ${*$me}[1]; + bless $me, ref($fh); + *{*$me} = *{*$fh}; # Alias self to handle + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +sub writer { + @_ >= 1 or croak 'usage: $pipe->writer()'; + my $me = shift; + my $fh = ${*$me}[1]; + my $pid = $me->_doit(1, $fh, @_) + if(@_); + + close ${*$me}[0]; + bless $me, ref($fh); + *{*$me} = *{*$fh}; # Alias self to handle + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +package IO::Pipe::End; + +use vars qw(@ISA); + +@ISA = qw(IO::Handle); + +sub close { + my $fh = shift; + my $r = $fh->SUPER::close(@_); + + waitpid(${*$fh}{'io_pipe_pid'},0) + if(defined ${*$fh}{'io_pipe_pid'}); + + $r; +} + +1; + +__END__ + =head1 NAME IO::pipe - supply object methods for pipes @@ -79,7 +217,7 @@ is called and C<ARGS> are passed to exec. This method is called during construction by C<IO::Pipe::new> on the newly created C<IO::Pipe> object. It returns an array of two objects -blessed into C<IO::Handle>, or a subclass thereof. +blessed into C<IO::Pipe::End>, or a subclass thereof. =back @@ -93,101 +231,8 @@ Graham Barr <bodg@tiuk.ti.com> =head1 COPYRIGHT -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free +Copyright (c) 1996 Graham Barr. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut - -require 5.000; -use strict; -use vars qw($VERSION); -use Carp; -use Symbol; -require IO::Handle; - -$VERSION = "1.08"; - -sub new { - my $type = shift; - my $class = ref($type) || $type || "IO::Pipe"; - @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]"; - - my $me = bless gensym(), $class; - - my($readfh,$writefh) = @_ ? @_ : $me->handles; - - pipe($readfh, $writefh) - or return undef; - - @{*$me} = ($readfh, $writefh); - - $me; -} - -sub handles { - @_ == 1 or croak 'usage: $pipe->handles()'; - (IO::Handle->new(), IO::Handle->new()); -} - -sub _doit { - my $me = shift; - my $rw = shift; - - my $pid = fork(); - - if($pid) { # Parent - return $pid; - } - elsif(defined $pid) { # Child - my $fh = $rw ? $me->reader() : $me->writer(); - my $io = $rw ? \*STDIN : \*STDOUT; - - bless $io, "IO::Handle"; - $io->fdopen($fh, $rw ? "r" : "w"); - exec @_ or - croak "IO::Pipe: Cannot exec: $!"; - } - else { - croak "IO::Pipe: Cannot fork: $!"; - } - - # NOT Reached -} - -sub reader { - @_ >= 1 or croak 'usage: $pipe->reader()'; - my $me = shift; - my $fh = ${*$me}[0]; - my $pid = $me->_doit(0,@_) - if(@_); - - close(${*$me}[1]); - bless $me, ref($fh); - *{*$me} = *{*$fh}; # Alias self to handle - bless $fh, 'IO::Pipe::DeadEnd'; # Really wan't un-bless here - ${*$me}{'io_pipe_pid'} = $pid - if defined $pid; - - $me; -} - -sub writer { - @_ >= 1 or croak 'usage: $pipe->writer()'; - my $me = shift; - my $fh = ${*$me}[1]; - my $pid = $me->_doit(1,@_) - if(@_); - - close(${*$me}[0]); - bless $me, ref($fh); - *{*$me} = *{*$fh}; # Alias self to handle - bless $fh, 'IO::Pipe::DeadEnd'; # Really wan't un-bless here - ${*$me}{'io_pipe_pid'} = $pid - if defined $pid; - - $me; -} - -1; - diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm index 6a69c6b624..264d1ac076 100644 --- a/ext/IO/lib/IO/Socket.pm +++ b/ext/IO/lib/IO/Socket.pm @@ -1,4 +1,8 @@ +# IO::Socket.pm # +# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights +# reserved. This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. package IO::Socket; @@ -114,7 +118,7 @@ use Exporter; @ISA = qw(IO::Handle); -$VERSION = "1.15"; +$VERSION = "1.16"; sub import { my $pkg = shift; @@ -136,16 +140,7 @@ my @domain2pkg = (); sub register_domain { my($p,$d) = @_; - $domain2pkg[$d] = bless \$d, $p; -} - -sub _domain2pkg { - my $domain = shift; - - croak "Unsupported socket domain" - unless defined $domain2pkg[$domain]; - - $domain2pkg[$domain] + $domain2pkg[$d] = $p; } sub configure { @@ -155,12 +150,13 @@ sub configure { croak 'IO::Socket: Cannot configure a generic socket' unless defined $domain; - my $class = ref(_domain2pkg($domain)); + croak "IO::Socket: Unsupported socket domain" + unless defined $domain2pkg[$domain]; croak "IO::Socket: Cannot configure socket in domain '$domain'" unless ref($fh) eq "IO::Socket"; - bless($fh, $class); + bless($fh, $domain2pkg[$domain]); $fh->configure; } @@ -168,18 +164,13 @@ sub socket { @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)'; my($fh,$domain,$type,$protocol) = @_; - if(!defined ${*$fh}{'io_socket_domain'} - || !ref(${*$fh}{'io_socket_domain'}) - || ${${*$fh}{'io_socket_domain'}} != $domain) { - my $pkg = - ${*$fh}{'io_socket_domain'} = _domain2pkg($domain); - } - socket($fh,$domain,$type,$protocol) or return undef; - ${*$fh}{'io_socket_type'} = $type; - ${*$fh}{'io_socket_proto'} = $protocol; + ${*$fh}{'io_socket_domain'} = $domain; + ${*$fh}{'io_socket_type'} = $type; + ${*$fh}{'io_socket_proto'} = $protocol; + $fh; } @@ -352,7 +343,7 @@ sub timeout { sub sockdomain { @_ == 1 or croak 'usage: $fh->sockdomain()'; my $fh = shift; - ${${*$fh}{'io_socket_domain'}} + ${*$fh}{'io_socket_domain'}; } sub socktype { @@ -549,9 +540,6 @@ sub configure { my $pname = (getprotobynumber($proto))[0]; $type = $arg->{Type} || $socket_type{$pname}; - my $domain = AF_INET; - ${*$fh}{'io_socket_domain'} = bless \$domain; - $fh->socket(AF_INET, $type, $proto) or return _error($fh,"$!"); @@ -667,9 +655,6 @@ sub configure { my $type = $arg->{Type} || SOCK_STREAM; - my $domain = AF_UNIX; - ${*$fh}{'io_socket_domain'} = bless \$domain; - $fh->socket(AF_UNIX, $type, 0) or return undef; @@ -713,7 +698,7 @@ Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> =head1 COPYRIGHT -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free +Copyright (c) 1996 Graham Barr. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm index b095ffebe7..ce315dcf7c 100644 --- a/ext/POSIX/POSIX.pm +++ b/ext/POSIX/POSIX.pm @@ -22,11 +22,19 @@ $VERSION = "1.00" ; dirent_h => [qw()], - errno_h => [qw(E2BIG EACCES EAGAIN EBADF EBUSY ECHILD EDEADLK EDOM - EEXIST EFAULT EFBIG EINTR EINVAL EIO EISDIR EMFILE - EMLINK ENAMETOOLONG ENFILE ENODEV ENOENT ENOEXEC ENOLCK - ENOMEM ENOSPC ENOSYS ENOTDIR ENOTEMPTY ENOTTY ENXIO - EPERM EPIPE ERANGE EROFS ESPIPE ESRCH EXDEV errno)], + errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT + EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED + ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT + EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS + EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK + EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH + ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM + ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR + ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM + EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE + ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT + ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY + EUSERS EWOULDBLOCK EXDEV errno)], fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK @@ -72,12 +80,13 @@ $VERSION = "1.00" ; setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)], - signal_h => [qw(SA_NOCLDSTOP SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE - SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV - SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 - SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK - raise sigaction signal sigpending sigprocmask - sigsuspend)], + signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK + SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM + SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL + SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN + SIGTTOU SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR + SIG_IGN SIG_SETMASK SIG_UNBLOCK raise sigaction signal + sigpending sigprocmask sigsuspend)], stdarg_h => [qw()], diff --git a/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod index 34597d1bd5..fba225f5b9 100644 --- a/ext/POSIX/POSIX.pod +++ b/ext/POSIX/POSIX.pod @@ -1576,7 +1576,16 @@ _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_M =item Constants -E2BIG EACCES EAGAIN EBADF EBUSY ECHILD EDEADLK EDOM EEXIST EFAULT EFBIG EINTR EINVAL EIO EISDIR EMFILE EMLINK ENAMETOOLONG ENFILE ENODEV ENOENT ENOEXEC ENOLCK ENOMEM ENOSPC ENOSYS ENOTDIR ENOTEMPTY ENOTTY ENXIO EPERM EPIPE ERANGE EROFS ESPIPE ESRCH EXDEV +E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY EBADF +EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ +EDOM EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS EINTR +EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE ENAMETOOLONG +ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS ENODEV ENOENT ENOEXEC +ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR +ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT EPIPE +EPROCLIM EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE ERESTART EROFS +ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS +ETXTBSY EUSERS EWOULDBLOCK EXDEV =back @@ -1636,7 +1645,11 @@ HUGE_VAL =item Constants -SA_NOCLDSTOP SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK +SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND SA_RESTART +SA_SIGINFO SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT +SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU +SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK +SIG_UNBLOCK =back diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 6354dc3db5..42aeb3bb93 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -47,6 +47,9 @@ # include <libdef.h> /* LIB$_INVARG constant */ # include <lib$routines.h> /* prototype for lib$ediv() */ # include <starlet.h> /* prototype for sys$gettim() */ +# if DECC_VERSION < 50000000 +# define pid_t int /* old versions of DECC miss this in types.h */ +# endif # undef mkfifo /* #defined in perl.h */ # define mkfifo(a,b) (not_here("mkfifo"),-1) @@ -624,12 +627,36 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EADDRINUSE")) +#ifdef EADDRINUSE + return EADDRINUSE; +#else + goto not_there; +#endif + if (strEQ(name, "EADDRNOTAVAIL")) +#ifdef EADDRNOTAVAIL + return EADDRNOTAVAIL; +#else + goto not_there; +#endif + if (strEQ(name, "EAFNOSUPPORT")) +#ifdef EAFNOSUPPORT + return EAFNOSUPPORT; +#else + goto not_there; +#endif if (strEQ(name, "EAGAIN")) #ifdef EAGAIN return EAGAIN; #else goto not_there; #endif + if (strEQ(name, "EALREADY")) +#ifdef EALREADY + return EALREADY; +#else + goto not_there; +#endif break; case 'B': if (strEQ(name, "EBADF")) @@ -676,6 +703,24 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "ECONNABORTED")) +#ifdef ECONNABORTED + return ECONNABORTED; +#else + goto not_there; +#endif + if (strEQ(name, "ECONNREFUSED")) +#ifdef ECONNREFUSED + return ECONNREFUSED; +#else + goto not_there; +#endif + if (strEQ(name, "ECONNRESET")) +#ifdef ECONNRESET + return ECONNRESET; +#else + goto not_there; +#endif break; case 'D': if (strEQ(name, "EDEADLK")) @@ -684,12 +729,24 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EDESTADDRREQ")) +#ifdef EDESTADDRREQ + return EDESTADDRREQ; +#else + goto not_there; +#endif if (strEQ(name, "EDOM")) #ifdef EDOM return EDOM; #else goto not_there; #endif + if (strEQ(name, "EDQUOT")) +#ifdef EDQUOT + return EDQUOT; +#else + goto not_there; +#endif break; case 'E': if (strEQ(name, "EEXIST")) @@ -713,7 +770,27 @@ int arg; goto not_there; #endif break; + case 'H': + if (strEQ(name, "EHOSTDOWN")) +#ifdef EHOSTDOWN + return EHOSTDOWN; +#else + goto not_there; +#endif + if (strEQ(name, "EHOSTUNREACH")) +#ifdef EHOSTUNREACH + return EHOSTUNREACH; +#else + goto not_there; +#endif + break; case 'I': + if (strEQ(name, "EINPROGRESS")) +#ifdef EINPROGRESS + return EINPROGRESS; +#else + goto not_there; +#endif if (strEQ(name, "EINTR")) #ifdef EINTR return EINTR; @@ -732,12 +809,24 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EISCONN")) +#ifdef EISCONN + return EISCONN; +#else + goto not_there; +#endif if (strEQ(name, "EISDIR")) #ifdef EISDIR return EISDIR; #else goto not_there; #endif + if (strEQ(name, "ELOOP")) +#ifdef ELOOP + return ELOOP; +#else + goto not_there; +#endif break; case 'M': if (strEQ(name, "EMFILE")) @@ -752,29 +841,71 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EMSGSIZE")) +#ifdef EMSGSIZE + return EMSGSIZE; +#else + goto not_there; +#endif break; case 'N': + if (strEQ(name, "ENETDOWN")) +#ifdef ENETDOWN + return ENETDOWN; +#else + goto not_there; +#endif + if (strEQ(name, "ENETRESET")) +#ifdef ENETRESET + return ENETRESET; +#else + goto not_there; +#endif + if (strEQ(name, "ENETUNREACH")) +#ifdef ENETUNREACH + return ENETUNREACH; +#else + goto not_there; +#endif + if (strEQ(name, "ENOBUFS")) +#ifdef ENOBUFS + return ENOBUFS; +#else + goto not_there; +#endif + if (strEQ(name, "ENOEXEC")) +#ifdef ENOEXEC + return ENOEXEC; +#else + goto not_there; +#endif if (strEQ(name, "ENOMEM")) #ifdef ENOMEM return ENOMEM; #else goto not_there; #endif + if (strEQ(name, "ENOPROTOOPT")) +#ifdef ENOPROTOOPT + return ENOPROTOOPT; +#else + goto not_there; +#endif if (strEQ(name, "ENOSPC")) #ifdef ENOSPC return ENOSPC; #else goto not_there; #endif - if (strEQ(name, "ENOEXEC")) -#ifdef ENOEXEC - return ENOEXEC; + if (strEQ(name, "ENOTBLK")) +#ifdef ENOTBLK + return ENOTBLK; #else goto not_there; #endif - if (strEQ(name, "ENOTTY")) -#ifdef ENOTTY - return ENOTTY; + if (strEQ(name, "ENOTCONN")) +#ifdef ENOTCONN + return ENOTCONN; #else goto not_there; #endif @@ -790,6 +921,18 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "ENOTSOCK")) +#ifdef ENOTSOCK + return ENOTSOCK; +#else + goto not_there; +#endif + if (strEQ(name, "ENOTTY")) +#ifdef ENOTTY + return ENOTTY; +#else + goto not_there; +#endif if (strEQ(name, "ENFILE")) #ifdef ENFILE return ENFILE; @@ -840,6 +983,12 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EOPNOTSUPP")) +#ifdef EOPNOTSUPP + return EOPNOTSUPP; +#else + goto not_there; +#endif break; case 'P': if (strEQ(name, "EPERM")) @@ -848,12 +997,36 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EPFNOSUPPORT")) +#ifdef EPFNOSUPPORT + return EPFNOSUPPORT; +#else + goto not_there; +#endif if (strEQ(name, "EPIPE")) #ifdef EPIPE return EPIPE; #else goto not_there; #endif + if (strEQ(name, "EPROCLIM")) +#ifdef EPROCLIM + return EPROCLIM; +#else + goto not_there; +#endif + if (strEQ(name, "EPROTONOSUPPORT")) +#ifdef EPROTONOSUPPORT + return EPROTONOSUPPORT; +#else + goto not_there; +#endif + if (strEQ(name, "EPROTOTYPE")) +#ifdef EPROTOTYPE + return EPROTOTYPE; +#else + goto not_there; +#endif break; case 'R': if (strEQ(name, "ERANGE")) @@ -862,6 +1035,18 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EREMOTE")) +#ifdef EREMOTE + return EREMOTE; +#else + goto not_there; +#endif + if (strEQ(name, "ERESTART")) +#ifdef ERESTART + return ERESTART; +#else + goto not_there; +#endif if (strEQ(name, "EROFS")) #ifdef EROFS return EROFS; @@ -870,6 +1055,18 @@ int arg; #endif break; case 'S': + if (strEQ(name, "ESHUTDOWN")) +#ifdef ESHUTDOWN + return ESHUTDOWN; +#else + goto not_there; +#endif + if (strEQ(name, "ESOCKTNOSUPPORT")) +#ifdef ESOCKTNOSUPPORT + return ESOCKTNOSUPPORT; +#else + goto not_there; +#endif if (strEQ(name, "ESPIPE")) #ifdef ESPIPE return ESPIPE; @@ -882,7 +1079,49 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "ESTALE")) +#ifdef ESTALE + return ESTALE; +#else + goto not_there; +#endif break; + case 'T': + if (strEQ(name, "ETIMEDOUT")) +#ifdef ETIMEDOUT + return ETIMEDOUT; +#else + goto not_there; +#endif + if (strEQ(name, "ETOOMANYREFS")) +#ifdef ETOOMANYREFS + return ETOOMANYREFS; +#else + goto not_there; +#endif + if (strEQ(name, "ETXTBSY")) +#ifdef ETXTBSY + return ETXTBSY; +#else + goto not_there; +#endif + break; + case 'U': + if (strEQ(name, "EUSERS")) +#ifdef EUSERS + return EUSERS; +#else + goto not_there; +#endif + break; + case 'W': + if (strEQ(name, "EWOULDBLOCK")) +#ifdef EWOULDBLOCK + return EWOULDBLOCK; +#else + goto not_there; +#endif + break; case 'X': if (strEQ(name, "EXIT_FAILURE")) #ifdef EXIT_FAILURE @@ -1769,12 +2008,51 @@ int arg; #else goto not_there; #endif - if (strEQ(name, "SA_NOCLDSTOP")) + if (strnEQ(name, "SA_", 3)) { + if (strEQ(name, "SA_NOCLDSTOP")) #ifdef SA_NOCLDSTOP - return SA_NOCLDSTOP; + return SA_NOCLDSTOP; #else - goto not_there; + goto not_there; #endif + if (strEQ(name, "SA_NOCLDWAIT")) +#ifdef SA_NOCLDWAIT + return SA_NOCLDWAIT; +#else + goto not_there; +#endif + if (strEQ(name, "SA_NODEFER")) +#ifdef SA_NODEFER + return SA_NODEFER; +#else + goto not_there; +#endif + if (strEQ(name, "SA_ONSTACK")) +#ifdef SA_ONSTACK + return SA_ONSTACK; +#else + goto not_there; +#endif + if (strEQ(name, "SA_RESETHAND")) +#ifdef SA_RESETHAND + return SA_RESETHAND; +#else + goto not_there; +#endif + if (strEQ(name, "SA_RESTART")) +#ifdef SA_RESTART + return SA_RESTART; +#else + goto not_there; +#endif + if (strEQ(name, "SA_SIGINFO")) +#ifdef SA_SIGINFO + return SA_SIGINFO; +#else + goto not_there; +#endif + break; + } if (strEQ(name, "SCHAR_MAX")) #ifdef SCHAR_MAX return SCHAR_MAX; @@ -912,8 +912,8 @@ HV* stash; AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL; AMT amt; - if (mg && (amtp=((AMT*)(mg->mg_ptr)))->was_ok_am == amagic_generation && - amtp->was_ok_sub == sub_generation) + if (mg && amtp->was_ok_am == amagic_generation + && amtp->was_ok_sub == sub_generation) return AMT_AMAGIC(amtp); if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */ int i; @@ -997,10 +997,10 @@ HV* stash; if ( cp = (char *)AMG_names[0] ) { /* Try to find via inheritance. */ - gv = gv_fetchmeth(stash, "()", 2, 0); /* A cooky: "()". */ + gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */ if (gv) sv = GvSV(gv); - if (!sv) /* Empty */; + if (!gv) goto no_table; else if (SvTRUE(sv)) amt.fallback=AMGfallYES; else if (SvOK(sv)) amt.fallback=AMGfallNEVER; } @@ -1009,7 +1009,7 @@ HV* stash; cv = 0; cp = (char *)AMG_names[i]; - *buf = '('; /* A cooky: "(". */ + *buf = '('; /* A cookie: "(". */ strcpy(buf + 1, cp); DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n", cp, HvNAME(stash)) ); @@ -1057,6 +1057,7 @@ HV* stash; } } /* Here we have no table: */ + no_table: AMT_AMAGIC_off(&amt); sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS)); return FALSE; @@ -1221,9 +1222,11 @@ int flags; } else if (cvp && (cv=cvp[nomethod_amg])) { notfound = 1; lr = 1; } else { - if (off==-1) off=method; - sprintf(buf, "Operation `%s': no method found,\n\tleft argument %s%.256s,\n\tright argument %s%.256s", + if (off==-1) off=method; + sprintf(buf, + "Operation `%s': no method found,%sargument %s%.256s%s%.256s", AMG_names[method + assignshift], + (flags & AMGf_unary ? " " : "\n\tleft "), SvAMAGIC(left)? "in overloaded package ": "has no overloaded magic", @@ -1231,8 +1234,10 @@ int flags; HvNAME(SvSTASH(SvRV(left))): "", SvAMAGIC(right)? - "in overloaded package ": - "has no overloaded magic", + ",\n\tright argument in overloaded package ": + (flags & AMGf_unary + ? "" + : ",\n\tright argument has no overloaded magic"), SvAMAGIC(right)? HvNAME(SvSTASH(SvRV(right))): ""); @@ -1246,7 +1251,8 @@ int flags; } } if (!notfound) { - DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n", + DEBUG_o( deb( + "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n", AMG_names[off], method+assignshift==off? "" : " (initially `", diff --git a/hints/dcosx.sh b/hints/dcosx.sh new file mode 100644 index 0000000000..3b8a300fa9 --- /dev/null +++ b/hints/dcosx.sh @@ -0,0 +1,188 @@ +# hints/dcosx.sh +# Last modified: Thu Jan 16 11:38:12 EST 1996 +# Stephen Zander <stephen.zander@interlock.mckesson.com> +# hints for DC/OSx (Pyramid) & SINIX (Seimens: dc/osx rebadged) +# Based on the hints/solaris_2.sh file + +# See man vfork. +usevfork=false + +d_suidsafe=define + +# Avoid all libraries in /usr/ucblib. +set `echo $glibpth | sed -e 's@/usr/ucblib@@'` +glibpth="$*" + +# Remove bad libraries. +# -lucb contains incompatible routines. +set `echo " $libswanted " | sed -e 's@ ucb @ @'` +libswanted="$*" + +# Here's another draft of the perl5/solaris/gcc sanity-checker. + +case $PATH in +*/usr/ucb*:/usr/bin:*|*/usr/ucb*:/usr/bin) cat <<END + +NOTE: /usr/ucb/cc does not function properly. +Remove /usr/ucb from your PATH. + +END +;; +esac + + +# Check that /dev/fd is mounted. If it is not mounted, let the +# user know that suid scripts may not work. +/usr/bin/df /dev/fd 2>&1 > /dev/null +case $? in +0) ;; +*) + cat <<END + +NOTE: Your system does not have /dev/fd mounted. If you want to +be able to use set-uid scripts you must ask your system administrator +to mount /dev/fd. + +END + ;; +esac + + +# See if libucb can be found in /usr/lib. If it is, warn the user +# that this may cause problems while building Perl extensions. +/usr/bin/ls /usr/lib/libucb* >/dev/null 2>&1 +case $? in +0) + cat <<END + +NOTE: libucb has been found in /usr/lib. libucb should reside in +/usr/ucblib. You may have trouble while building Perl extensions. + +END +;; +esac + + +# See if make(1) is GNU make(1). +# If it is, make sure the setgid bit is not set. +make -v > make.vers 2>&1 +if grep GNU make.vers > /dev/null 2>&1; then + tmp=`/usr/bin/ksh -c "whence make"` + case "`/usr/bin/ls -l $tmp`" in + ??????s*) + cat <<END + +NOTE: Your PATH points to GNU make, and your GNU make has the set-group-id +bit set. You must either rearrange your PATH to put /usr/ccs/bin before the +GNU utilities or you must ask your system administrator to disable the +set-group-id bit on GNU make. + +END + ;; + esac +fi +rm -f make.vers + +# If the C compiler is gcc: +# - check the fixed-includes +# - check as(1) and ld(1), they should not be GNU +# If the C compiler is not gcc: +# - check as(1) and ld(1), they should not be GNU +# - increase the optimizing level to prevent object size warnings +# +# Watch out in case they have not set $cc. +case "`${cc:-cc} -v 2>&1`" in +*gcc*) + # + # Using gcc. + # + #echo Using gcc + + # Get gcc to share its secrets. + echo 'main() { return 0; }' > try.c + verbose=`${cc:-cc} -v -o try try.c 2>&1` + rm -f try try.c + tmp=`echo "$verbose" | grep '^Reading' | + awk '{print $NF}' | sed 's/specs$/include/'` + + # Determine if the fixed-includes look like they'll work. + # Doesn't work anymore for gcc-2.7.2. + + # See if as(1) is GNU as(1). GNU as(1) won't work for this job. + case $verbose in + */usr/ccs/bin/as*) ;; + *) + cat <<END + +NOTE: You are using GNU as(1). GNU as(1) will not build Perl. +You must arrange to use /usr/ccs/bin/as, perhaps by setting +GCC_EXEC_PREFIX or by including -B/usr/ccs/bin in your cc command. + +END + ;; + esac + + # See if ld(1) is GNU ld(1). GNU ld(1) won't work for this job. + case $verbose in + */usr/ccs/bin/ld*) ;; + *) + cat <<END + +NOTE: You are using GNU ld(1). GNU ld(1) will not build Perl. +You must arrange to use /usr/ccs/bin/ld, perhaps by setting +GCC_EXEC_PREFIX or by including -B/usr/ccs/bin in your cc command. + +END + ;; + esac + + ;; #using gcc +*) + optimize='-O -K Olimit:3064' + # + # Not using gcc. + # + #echo Not using gcc + + # See if as(1) is GNU as(1). GNU as(1) won't work for this job. + case `as --version < /dev/null 2>&1` in + *GNU*) + cat <<END + +NOTE: You are using GNU as(1). GNU as(1) will not build Perl. +You must arrange to use /usr/ccs/bin, perhaps by adding it to the +beginning of your PATH. + +END + ;; + esac + + # See if ld(1) is GNU ld(1). GNU ld(1) won't work for this job. + case `ld --version < /dev/null 2>&1` in + *GNU*) + cat <<END + +NOTE: You are using GNU ld(1). GNU ld(1) will not build Perl. +You must arrange to use /usr/ccs/bin, perhaps by adding it to the +beginning of your PATH + +END + ;; + esac + + ;; #not using gcc +esac + +# as --version or ld --version might dump core. +rm -f core + +# DC/OSx hides certain functions in a libc that looks dynamic but isn't +# because of this we reinclude -lc when building dynamic extenstions +libc='/usr/ccs/lib/libc.so' +cccdlflags='-lc' + +# DC/OSx gets overenthusiastic with symbol removal when building dynamically +ccdlflags='-Blargedynsym' + +# System malloc is safer when using third part libs +usemymalloc='n' diff --git a/hints/hpux.sh b/hints/hpux.sh index b103cf5bd3..a310a2dfc6 100644 --- a/hints/hpux.sh +++ b/hints/hpux.sh @@ -113,6 +113,9 @@ usemymalloc='y' alignbytes=8 selecttype='int *' +# When HP-UX runs a script with "#!", it sets argv[0] to the script name. +toke_cflags='ccflags="$ccflags -DARG_ZERO_IS_SCRIPT"' + # If your compile complains about FLT_MIN, uncomment the next line # POSIX_cflags='ccflags="$ccflags -DFLT_MIN=1.17549435E-38"' diff --git a/hints/lynxos.sh b/hints/lynxos.sh index 5f8991bc45..ddffcbe3cc 100644 --- a/hints/lynxos.sh +++ b/hints/lynxos.sh @@ -7,6 +7,5 @@ # cc='gcc' -ccflags='-D_filbuf=_fillbuf' so='none' usemymalloc='n' diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 13383e9411..1e39e118fc 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -6,7 +6,7 @@ # Author: Charles Bailey bailey@genetics.upenn.edu package ExtUtils::MM_VMS; -$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.38 (19-Nov-1996)'; +$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.39 (16-Jan-1997)'; unshift @MM::ISA, 'ExtUtils::MM_VMS'; use Config; @@ -1055,6 +1055,7 @@ CP = $self->{CP} MV = $self->{MV} RM_F = $self->{RM_F} RM_RF = $self->{RM_RF} +SAY = Write Sys\$Output UMASK_NULL = $self->{UMASK_NULL} NOOP = $self->{NOOP} NOECHO = $self->{NOECHO} @@ -1064,7 +1065,7 @@ EQUALIZE_TIMESTAMP = \$(PERL) -we "open F,qq{>\$ARGV[1]};close F;utime(0,(stat(\ qq!WARN_IF_OLD_PACKLIST = \$(PERL) -e "if (-f \$ARGV[0]){print qq[WARNING: Old package found (\$ARGV[0]); please check for collisions\\n]}" MOD_INSTALL = \$(PERL) "-I\$(PERL_LIB)" "-MExtUtils::Install" -e "install({split(' ',<STDIN>)},1);" DOC_INSTALL = \$(PERL) -e "\@ARGV=split(/\\|/,<STDIN>);print '=head2 ',scalar(localtime),': C<',shift,qq[>\\n\\n=over 4\\n\\n];while(\$key=shift && \$val=shift){print qq[=item *\\n\\nC<\$key: \$val>\\n\\n];}print qq[=back\\n\\n]" -UNINSTALL = \$(PERL) "-I\$(PERL_LIB)" "-MExtUtils::Install" -e "uninstall(\$ARGV[0],1);" +UNINSTALL = \$(PERL) "-I\$(PERL_LIB)" "-MExtUtils::Install" -e "uninstall(\$ARGV[0],1,1);" !); } @@ -1335,7 +1336,7 @@ BOOTSTRAP = '."$self->{BASEEXT}.bs".' # we use touch to prevent make continually trying to remake it. # The DynaLoader only reads a non-empty file. $(BOOTSTRAP) : $(MAKEFILE) '."$self->{BOOTDEP}".' $(INST_ARCHAUTODIR).exists - $(NOECHO) Write Sys$Output "Running mkbootstrap for $(NAME) ($(BSLOADLIBS))" + $(NOECHO) $(SAY) "Running mkbootstrap for $(NAME) ($(BSLOADLIBS))" $(NOECHO) $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" - -e "use ExtUtils::Mkbootstrap; Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');" $(NOECHO) $(TOUCH) $(MMS$TARGET) @@ -1790,19 +1791,19 @@ install_site :: all pure_site_install doc_site_install $(NOECHO) $(NOOP) install_ :: install_site - $(NOECHO) Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + $(NOECHO) $(SAY) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" pure_install :: pure_$(INSTALLDIRS)_install $(NOECHO) $(NOOP) doc_install :: doc_$(INSTALLDIRS)_install - $(NOECHO) Write Sys$Output "Appending installation info to $(INSTALLARCHLIB)perllocal.pod" + $(NOECHO) $(SAY) "Appending installation info to $(INSTALLARCHLIB)perllocal.pod" pure__install : pure_site_install - $(NOECHO) Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + $(NOECHO) $(SAY) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" doc__install : doc_site_install - $(NOECHO} Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + $(NOECHO} $(SAY) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" # This hack brought to you by DCL's 255-character command line limit pure_perl_install :: @@ -1866,9 +1867,16 @@ uninstall :: uninstall_from_$(INSTALLDIRS)dirs uninstall_from_perldirs :: $(NOECHO) $(UNINSTALL) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ + $(NOECHO) $(SAY) "Uninstall is now deprecated and makes no actual changes." + $(NOECHO) $(SAY) "Please check the list above carefully for errors, and manually remove" + $(NOECHO) $(SAY) "the appropriate files. Sorry for the inconvenience." uninstall_from_sitedirs :: - $(NOECHO) $(UNINSTALL) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist')."\n"; + $(NOECHO) $(UNINSTALL) ],$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist'),"\n",q[ + $(NOECHO) $(SAY) "Uninstall is now deprecated and makes no actual changes." + $(NOECHO) $(SAY) "Please check the list above carefully for errors, and manually remove" + $(NOECHO) $(SAY) "the appropriate files. Sorry for the inconvenience." +]; join('',@m); } @@ -1951,13 +1959,13 @@ $(OBJECT) : $(FIRST_MAKEFILE) # We take a very conservative approach here, but it\'s worth it. # We move $(MAKEFILE) to $(MAKEFILE)_old here to avoid gnu make looping. $(MAKEFILE) : Makefile.PL $(CONFIGDEP) - $(NOECHO) Write Sys$Output "$(MAKEFILE) out-of-date with respect to $(MMS$SOURCE_LIST)" - $(NOECHO) Write Sys$Output "Cleaning current config before rebuilding $(MAKEFILE) ..." + $(NOECHO) $(SAY) "$(MAKEFILE) out-of-date with respect to $(MMS$SOURCE_LIST)" + $(NOECHO) $(SAY) "Cleaning current config before rebuilding $(MAKEFILE) ..." - $(MV) $(MAKEFILE) $(MAKEFILE)_old - $(MMS) $(USEMAKEFILE)$(MAKEFILE)_old clean $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL ],join(' ',map(qq["$_"],@ARGV)),q[ - $(NOECHO) Write Sys$Output "$(MAKEFILE) has been rebuilt." - $(NOECHO) Write Sys$Output "Please run $(MMS) to build the extension." + $(NOECHO) $(SAY) "$(MAKEFILE) has been rebuilt." + $(NOECHO) $(SAY) "Please run $(MMS) to build the extension." ]; join('',@m); @@ -1991,7 +1999,7 @@ testdb :: testdb_\$(LINKTYPE) push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir ',"'$vmsdir'", '; print `$(MMS) $(PASTHRU2) test`'."\n"); } - push(@m, "\t\$(NOECHO) Write Sys\$Output \"No tests defined for \$(NAME) extension.\"\n") + push(@m, "\t\$(NOECHO) \$(SAY) \"No tests defined for \$(NAME) extension.\"\n") unless $tests or -f "test.pl" or @{$self->{DIR}}; push(@m, "\n"); @@ -2074,7 +2082,7 @@ MAP_TARGET = $target unless ($self->{MAKEAPERL}) { push @m, q{ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) - $(NOECHO) Write Sys$Output "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)" + $(NOECHO) $(SAY) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)" $(NOECHO) $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \ Makefile.PL DIR=}, $dir, q{ \ MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ @@ -2226,10 +2234,10 @@ $(MAP_SHRTARGET) : $(MAP_LIBPERL) $(MAP_STATIC) ',"${libperldir}Perlshr_Attr.Opt $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_OPTS), $(MAP_EXTRA), $(MAP_LIBPERL) ',"${libperldir}Perlshr_Attr.Opt",' $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmp}perlmain\$(OBJ_EXT) ${tmp}PerlShr.Opt",' $(MAP_LINKCMD) ',"${tmp}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option - $(NOECHO) Write Sys$Output "To install the new ""$(MAP_TARGET)"" binary, say" - $(NOECHO) Write Sys$Output " $(MMS)$(USEMAKEFILE)$(MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)" - $(NOECHO) Write Sys$Output "To remove the intermediate files, say - $(NOECHO) Write Sys$Output " $(MMS)$(USEMAKEFILE)$(MAKEFILE) map_clean" + $(NOECHO) $(SAY) "To install the new ""$(MAP_TARGET)"" binary, say" + $(NOECHO) $(SAY) " $(MMS)$(USEMAKEFILE)$(MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)" + $(NOECHO) $(SAY) "To remove the intermediate files, say + $(NOECHO) $(SAY) " $(MMS)$(USEMAKEFILE)$(MAKEFILE) map_clean" '; push @m,' ',"${tmp}perlmain.c",' : $(MAKEFILE) diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 76e45d6d99..74e325013c 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -75,11 +75,14 @@ perl(1), perlxs(1), perlxstut(1), perlxs(1) =cut -# Global Constants -$XSUBPP_version = "1.940"; require 5.002; +use Cwd; use vars '$cplusplus'; +# Global Constants +$XSUBPP_version = "1.94001"; +$Is_VMS = $^O eq 'VMS'; + sub Q ; $FH = 'File0000' ; @@ -118,10 +121,7 @@ else or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)# or ($dir, $filename) = ('.', $ARGV[0]); chdir($dir); -# Check for VMS; Config.pm may not be installed yet, but this routine -# is built into VMS perl -if (defined(&VMS::Filespec::vmsify)) { $Is_VMS = 1; $pwd = $ENV{DEFAULT}; } -else { $Is_VMS = 0; chomp($pwd = `pwd`); } +$pwd = cwd(); ++ $IncludedFiles{$ARGV[0]} ; diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index cca05b7291..ddf80c953f 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -48,8 +48,12 @@ sub runtests { my $bad = 0; my $good = 0; my $total = @tests; + + # pass -I flags to children my $old5lib = $ENV{PERL5LIB}; - local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC); # pass -I flags to children + local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC); + + if ($Is_VMS) { $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g } my $t_start = new Benchmark; while ($test = shift(@tests)) { @@ -150,7 +154,14 @@ sub runtests { } my $t_total = timediff(new Benchmark, $t_start); - if ($^O eq 'VMS' and defined($old5lib)) { $ENV{PERL5LIB} = $old5lib; } + if ($^O eq 'VMS') { + if (defined $old5lib) { + $ENV{PERL5LIB} = $old5lib; + } + else { + delete $ENV{PERL5LIB}; + } + } if ($bad == 0 && $totmax) { print "All tests successful.\n"; } elsif ($total==0){ diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index b00349f7b0..89d7467c4f 100644 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -326,8 +326,9 @@ EOFUNC #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/; $lhs =~ s/\377([^\377]*)$/\Q$1\E/; $lhs =~ s/\377//g; + $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all } - $transmo .= " s{^$lhs}\n {\Q$rhs\E}\n\t&& return 1;\n"; + $transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n"; } else { $transmo .= " m{^\Q$header\E} && return 1;\n"; } @@ -506,7 +507,7 @@ sub unescape { sub shorten { my $line = $_[0]; - if (length $line > 79) { + if (length($line) > 79 and index($line, "\n") == -1) { my $space_place = rindex($line, ' ', 79); if ($space_place != -1) { substr($line, $space_place, 1) = "\n\t"; diff --git a/lib/lib.pm b/lib/lib.pm index 8ca28de3ea..4d32f96355 100644 --- a/lib/lib.pm +++ b/lib/lib.pm @@ -1,10 +1,10 @@ package lib; +use vars qw(@ORIG_INC); use Config; my $archname = $Config{'archname'}; -@ORIG_INC = (); # (avoid typo warning) @ORIG_INC = @INC; # take a handy copy of 'original' value @@ -15,13 +15,16 @@ sub import { next unless defined($_); if ($_ eq '') { require Carp; - Carp::carp("Empty compile time value given to use lib"); # at foo.pl line ... + Carp::carp("Empty compile time value given to use lib"); + # at foo.pl line ... } unshift(@INC, $_); # Put a corresponding archlib directory infront of $_ if it # looks like $_ has an archlib directory below it. - unshift(@INC, "$_/$archname/$]") if -d "$_/$archname/$]/auto"; - unshift(@INC, "$_/$archname") if -d "$_/$archname/auto"; + if (-d "$_/$archname") { + unshift(@INC, "$_/$archname") if -d "$_/$archname/auto"; + unshift(@INC, "$_/$archname/$]") if -d "$_/$archname/$]/auto"; + } } } @@ -67,7 +70,6 @@ It is typically used to add extra directories to perl's search path so that later C<use> or C<require> statements will find modules which are not located on perl's default search path. - =head2 ADDING DIRECTORIES TO @INC The parameters to C<use lib> are added to the start of the perl search @@ -87,7 +89,6 @@ architecture specific directory and is added to @INC in front of $dir. If LIST includes both $dir and $dir/$archname then $dir/$archname will be added to @INC twice (if $dir/$archname/auto exists). - =head2 DELETING DIRECTORIES FROM @INC You should normally only add directories to @INC. If you need to @@ -113,7 +114,6 @@ architecture specific directory and is also deleted from @INC. If LIST includes both $dir and $dir/$archname then $dir/$archname will be deleted from @INC twice (if $dir/$archname/auto exists). - =head2 RESTORING ORIGINAL @INC When the lib module is first loaded it records the current value of @INC diff --git a/lib/overload.pm b/lib/overload.pm index 049545995c..0eb9702f82 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -149,9 +149,10 @@ the "class" C<Number> (or one of its base classes) for the assignment form C<*=> of multiplication. Arguments of this directive come in (key, value) pairs. Legal values -are values legal inside a C<&{ ... }> call, so the name of a subroutine, -a reference to a subroutine, or an anonymous subroutine will all work. -Legal keys are listed below. +are values legal inside a C<&{ ... }> call, so the name of a +subroutine, a reference to a subroutine, or an anonymous subroutine +will all work. Note that values specified as strings are +interpreted as methods, not subroutines. Legal keys are listed below. The subroutine C<add> will be called to execute C<$a+$b> if $a is a reference to an object blessed into the package C<Number>, or if $a is @@ -161,6 +162,10 @@ C<$a+=7>, or C<$a++>. See L<MAGIC AUTOGENERATION>. (Mathemagical methods refer to methods triggered by an overloaded mathematical operator.) +Since overloading respects inheritance via the @ISA hierarchy, the +above declaration would also trigger overloading of C<+> and C<*=> in +all the packages which inherit from C<Number>. + =head2 Calling Conventions for Binary Operations The functions specified in the C<use overload ...> directive are called @@ -269,12 +274,46 @@ see L<SPECIAL SYMBOLS FOR C<use overload>>. See L<"Fallback"> for an explanation of when a missing method can be autogenerated. +=head2 Inheritance and overloading + +Inheritance interacts with overloading in two ways. + +=over + +=item Strings as values of C<use overload> directive + +If C<value> in + + use overload key => value; + +is a string, it is interpreted as a method name. + +=item Overloading of an operation is inherited by derived classes + +Any class derived from an overloaded class is also overloaded. The +set of overloaded methods is the union of overloaded methods of all +the ancestors. If some method is overloaded in several ancestor, then +which description will be used is decided by the usual inheritance +rules: + +If C<A> inherits from C<B> and C<C> (in this order), C<B> overloads +C<+> with C<\&D::plus_sub>, and C<C> overloads C<+> by C<"plus_meth">, +then the subroutine C<D::plus_sub> will be called to implement +operation C<+> for an object in package C<A>. + +=back + +Note that since the value of the C<fallback> key is not a subroutine, +its inheritance is not governed by the above rules. In the current +implementation, the value of C<fallback> in the first overloaded +ancestor is used, but this is accidental and subject to change. + =head1 SPECIAL SYMBOLS FOR C<use overload> Three keys are recognized by Perl that are not covered by the above description. -=head2 Last Resort +=head2 Last Resort C<"nomethod"> should be followed by a reference to a function of four parameters. If defined, it is called when the overloading mechanism @@ -321,6 +360,9 @@ C<"nomethod"> value, and if this is missing, raises an exception. =back +B<Note.> C<"fallback"> inheritance via @ISA is not carved in stone +yet, see L<"Inheritance and overloading">. + =head2 Copy Constructor The value for C<"="> is a reference to a function with three @@ -484,31 +526,40 @@ Returns C<undef> or a reference to the method that implements C<op>. What follows is subject to change RSN. -The table of methods for all operations is cached as magic in the -symbol table hash for the package. The table is rechecked for changes due to -C<use overload>, C<no overload>, and @ISA only during -C<bless>ing; so if they are changed dynamically, you'll need an -additional fake C<bless>ing to update the table. - -(Every SVish thing has a magic queue, and magic is an entry in that queue. -This is how a single variable may participate in multiple forms of magic -simultaneously. For instance, environment variables regularly have two -forms at once: their %ENV magic and their taint magic.) +The table of methods for all operations is cached in magic for the +symbol table hash for the package. The cache is invalidated during +processing of C<use overload>, C<no overload>, new function +definitions, and changes in @ISA. However, this invalidation remains +unprocessed until the next C<bless>ing into the package. Hence if you +want to change overloading structure dynamically, you'll need an +additional (fake) C<bless>ing to update the table. + +(Every SVish thing has a magic queue, and magic is an entry in that +queue. This is how a single variable may participate in multiple +forms of magic simultaneously. For instance, environment variables +regularly have two forms at once: their %ENV magic and their taint +magic. However, the magic which implements overloading is applied to +the stashes, which are rarely used directly, thus should not slow down +Perl.) If an object belongs to a package using overload, it carries a special flag. Thus the only speed penalty during arithmetic operations without overloading is the checking of this flag. -In fact, if C<use overload> is not present, there is almost no overhead for -overloadable operations, so most programs should not suffer measurable -performance penalties. A considerable effort was made to minimize the overhead -when overload is used and the current operation is overloadable but -the arguments in question do not belong to packages using overload. When -in doubt, test your speed with C<use overload> and without it. So far there -have been no reports of substantial speed degradation if Perl is compiled -with optimization turned on. - -There is no size penalty for data if overload is not used. +In fact, if C<use overload> is not present, there is almost no overhead +for overloadable operations, so most programs should not suffer +measurable performance penalties. A considerable effort was made to +minimize the overhead when overload is used in some package, but the +arguments in question do not belong to packages using overload. When +in doubt, test your speed with C<use overload> and without it. So far +there have been no reports of substantial speed degradation if Perl is +compiled with optimization turned on. + +There is no size penalty for data if overload is not used. The only +size penalty if overload is used in some package is that I<all> the +packages acquire a magic during the next C<bless>ing into the +package. This magic is three-words-long for packages without +overloading, and carries the cache tabel if the package is overloaded. Copying (C<$a=$b>) is shallow; however, a one-level-deep copying is carried out before any operation that can imply an assignment to the @@ -527,6 +578,14 @@ Ilya Zakharevich E<lt>F<ilya@math.mps.ohio-state.edu>E<gt>. When Perl is run with the B<-Do> switch or its equivalent, overloading induces diagnostic messages. +Using the C<m> command of Perl debugger (see L<perldebug>) one can +deduce which operations are overloaded (and which ancestor triggers +this overloading). Say, if C<eq> is overloaded, then the method C<(eq> +is shown by debugger. The method C<()> corresponds to the C<fallback> +key (in fact a presence of this method shows that this package has +overloading enabled, and it is what is used by the C<Overloaded> +function). + =head1 BUGS Because it is used for overloading, the per-package associative array @@ -212,7 +212,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) SvNVX(sv) = (double)curcop->cop_seq; SvIVX(sv) = 999999999; /* A ref, intro immediately */ SvFLAGS(sv) |= SVf_FAKE; - if (CvANON(compcv) || CvFORMAT(compcv)) { + if (CvANON(compcv) || SvTYPE(compcv) == SVt_PVFM) { /* "It's closures all the way down." */ CvCLONE_on(compcv); if (cv != startcv) { @@ -223,7 +223,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) if (CvANON(bcv)) CvCLONE_on(bcv); else { - if (dowarn) + if (dowarn && !CvUNIQUE(cv)) warn( "Variable \"%s\" may be unavailable", name); @@ -2637,8 +2637,10 @@ OP *block; if (expr) { if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) return block; /* do {} while 0 does once */ - else if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB) - expr = newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr); + if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB) { + expr = newUNOP(OP_DEFINED, 0, + newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) ); + } } listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); diff --git a/os2/OS2/ExtAttr/t/os2_ea.t b/os2/OS2/ExtAttr/t/os2_ea.t index dc6f996564..a1da398d45 100644 --- a/os2/OS2/ExtAttr/t/os2_ea.t +++ b/os2/OS2/ExtAttr/t/os2_ea.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } @@ -76,4 +76,4 @@ print "ok 12\n"; } print "ok 21\n"; - +unlink 't.out'; diff --git a/os2/OS2/PrfDB/t/os2_prfdb.t b/os2/OS2/PrfDB/t/os2_prfdb.t index 4c0883db50..a8c9752d36 100644 --- a/os2/OS2/PrfDB/t/os2_prfdb.t +++ b/os2/OS2/PrfDB/t/os2_prfdb.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::PrfDB\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)PrfDB\b/) { print "1..0\n"; exit 0; } @@ -183,3 +183,6 @@ tie %hash2, 'OS2::PrfDB', $inifile; print "ok 47\n"; print ($hash2{nnn}->{mmm} eq "67" ? "ok 48\n" : "not ok 48\n# `$val'\n"); + +untie %hash2; +unlink $inifile; diff --git a/os2/OS2/REXX/t/rx_cmprt.t b/os2/OS2/REXX/t/rx_cmprt.t index a73e43e36e..f2113e3aa3 100644 --- a/os2/OS2/REXX/t/rx_cmprt.t +++ b/os2/OS2/REXX/t/rx_cmprt.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_dllld.t b/os2/OS2/REXX/t/rx_dllld.t index 317743f3cb..9d81bf3e56 100644 --- a/os2/OS2/REXX/t/rx_dllld.t +++ b/os2/OS2/REXX/t/rx_dllld.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_objcall.t b/os2/OS2/REXX/t/rx_objcall.t index b4f04c308a..cb3c52a8b6 100644 --- a/os2/OS2/REXX/t/rx_objcall.t +++ b/os2/OS2/REXX/t/rx_objcall.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_sql.test b/os2/OS2/REXX/t/rx_sql.test index 4f984250a3..602c76dc47 100644 --- a/os2/OS2/REXX/t/rx_sql.test +++ b/os2/OS2/REXX/t/rx_sql.test @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib'; require Config; import Config; - if ($Config{'extensions'} !~ /\bOS2::REXX\b/) { + if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_tiesql.test b/os2/OS2/REXX/t/rx_tiesql.test index 2947516755..c85a1e990b 100644 --- a/os2/OS2/REXX/t/rx_tiesql.test +++ b/os2/OS2/REXX/t/rx_tiesql.test @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib'; require Config; import Config; - if ($Config{'extensions'} !~ /\bOS2::REXX\b/) { + if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_tievar.t b/os2/OS2/REXX/t/rx_tievar.t index 6132e23f80..77f90c2f59 100644 --- a/os2/OS2/REXX/t/rx_tievar.t +++ b/os2/OS2/REXX/t/rx_tievar.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_tieydb.t b/os2/OS2/REXX/t/rx_tieydb.t index 8251051265..30a2dafb62 100644 --- a/os2/OS2/REXX/t/rx_tieydb.t +++ b/os2/OS2/REXX/t/rx_tieydb.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_varset.t b/os2/OS2/REXX/t/rx_varset.t index 9d4f3b2e56..166cf53623 100644 --- a/os2/OS2/REXX/t/rx_varset.t +++ b/os2/OS2/REXX/t/rx_varset.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/OS2/REXX/t/rx_vrexx.t b/os2/OS2/REXX/t/rx_vrexx.t index a40749f55f..04ca6636db 100644 --- a/os2/OS2/REXX/t/rx_vrexx.t +++ b/os2/OS2/REXX/t/rx_vrexx.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't/lib'; @INC = '../lib' if -d 'lib'; require Config; import Config; - if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { print "1..0\n"; exit 0; } diff --git a/os2/diff.configure b/os2/diff.configure index d19bf4a823..863bdf555a 100644 --- a/os2/diff.configure +++ b/os2/diff.configure @@ -1,6 +1,6 @@ ---- perl5.003_06/Configure Fri Oct 4 11:08:50 1996 -+++ Configure Wed Oct 9 17:53:14 1996 -@@ -1451,7 +1451,7 @@ +--- Configure.dist Fri Jan 24 10:22:24 1997 ++++ Configure Fri Jan 24 10:22:27 1997 +@@ -1465,7 +1465,7 @@ *) echo "I don't know where '$file' is, and my life depends on it." >&4 echo "Go find a public domain implementation or fix your PATH setting!" >&4 @@ -9,7 +9,7 @@ ;; esac done -@@ -1460,7 +1460,9 @@ +@@ -1474,7 +1474,9 @@ say=offhand for file in $trylist; do xxx=`./loc $file $file $pth` @@ -20,7 +20,7 @@ eval _$file=$xxx case "$xxx" in /*) -@@ -3091,7 +3093,7 @@ +@@ -3161,7 +3163,7 @@ exit(0); } EOM @@ -29,7 +29,7 @@ gccversion=`./gccvers` case "$gccversion" in '') echo "You are not using GNU cc." ;; -@@ -3275,6 +3277,12 @@ +@@ -3364,6 +3366,12 @@ *"-l$thislib "*);; *) dflt="$dflt -l$thislib";; esac @@ -42,7 +42,7 @@ else echo "No -l$thislib." fi -@@ -3387,7 +3395,7 @@ +@@ -3912,7 +3920,7 @@ esac ;; esac @@ -51,7 +51,7 @@ case "$libs" in '') ;; *) for thislib in $libs; do -@@ -3583,6 +3593,10 @@ +@@ -4114,6 +4122,10 @@ eval $xscan;\ $contains '^fprintf$' libc.list >/dev/null 2>&1; then eval $xrun @@ -62,7 +62,7 @@ else nm -p $* 2>/dev/null >libc.tmp $grep fprintf libc.tmp > libc.ptf -@@ -3593,23 +3607,33 @@ +@@ -4124,23 +4136,33 @@ eval $xrun else echo " " @@ -103,7 +103,7 @@ done echo "Ok." >&4 else -@@ -5606,7 +5630,7 @@ +@@ -5738,7 +5760,7 @@ exit(0); } EOCP @@ -112,7 +112,7 @@ intsize=`./try` echo "Your integers are $intsize bytes long." else -@@ -5686,7 +5710,7 @@ +@@ -5818,7 +5840,7 @@ exit(result); } EOCP @@ -121,7 +121,7 @@ ./try yyy=$? else -@@ -5767,7 +5791,7 @@ +@@ -5899,7 +5921,7 @@ } EOCP @@ -130,7 +130,7 @@ ./try castflags=$? else -@@ -5806,7 +5830,7 @@ +@@ -5938,7 +5960,7 @@ exit((unsigned long)vsprintf(buf,"%s",args) > 10L); } EOF @@ -139,7 +139,7 @@ echo "Your vsprintf() returns (int)." >&4 val2="$undef" else -@@ -6148,7 +6172,7 @@ +@@ -6283,7 +6305,7 @@ EOCP : check sys/file.h first to get FREAD on Sun if $test `./findhdr sys/file.h` && \ @@ -148,7 +148,7 @@ h_sysfile=true; echo "<sys/file.h> defines the O_* constants..." >&4 if ./open3; then -@@ -6159,7 +6183,7 @@ +@@ -6294,7 +6316,7 @@ val="$undef" fi elif $test `./findhdr fcntl.h` && \ @@ -157,7 +157,7 @@ h_fcntl=true; echo "<fcntl.h> defines the O_* constants..." >&4 if ./open3; then -@@ -6642,7 +6666,7 @@ +@@ -6800,7 +6822,7 @@ y*|true) usemymalloc='y' mallocsrc='malloc.c' @@ -166,7 +166,7 @@ d_mymalloc="$define" case "$libs" in *-lmalloc*) -@@ -7867,7 +7891,7 @@ +@@ -8053,7 +8075,7 @@ printf("%d\n", (char *)&try.bar - (char *)&try.foo); } EOCP @@ -175,7 +175,7 @@ dflt=`./try` else dflt='8' -@@ -7915,7 +7939,7 @@ +@@ -8101,7 +8123,7 @@ } EOCP xxx_prompt=y @@ -184,7 +184,7 @@ dflt=`./try` case "$dflt" in [1-4][1-4][1-4][1-4]|12345678|87654321) -@@ -8337,7 +8361,7 @@ +@@ -8523,7 +8545,7 @@ printf("%d\n",i); } EOCP @@ -193,7 +193,7 @@ dflt=`try` else dflt='?' -@@ -8447,7 +8471,7 @@ +@@ -8633,7 +8655,7 @@ '') $echo $n ".$c" if $cc $ccflags \ $i_time $i_systime $i_systimek $sysselect $s_timeval $s_timezone \ @@ -202,7 +202,7 @@ set X $i_time $i_systime $i_systimek $sysselect $s_timeval shift flags="$*" -@@ -8517,7 +8541,7 @@ +@@ -8702,7 +8724,7 @@ #endif } EOCP @@ -211,7 +211,7 @@ d_fds_bits="$define" d_fd_set="$define" echo "Well, your system knows about the normal fd_set typedef..." >&4 -@@ -8534,7 +8558,7 @@ +@@ -8719,7 +8741,7 @@ $cat <<'EOM' Hmm, your compiler has some difficulty with fd_set. Checking further... EOM @@ -220,7 +220,7 @@ d_fds_bits="$undef" d_fd_set="$define" echo "Well, your system has some sort of fd_set available..." >&4 -@@ -9272,7 +9296,7 @@ +@@ -9458,7 +9480,7 @@ else echo "false" fi @@ -229,7 +229,7 @@ EOP chmod +x varargs -@@ -9596,7 +9620,7 @@ +@@ -9785,7 +9807,7 @@ echo " " echo "Stripping down executable paths..." >&4 for file in $loclist $trylist; do diff --git a/os2/os2ish.h b/os2/os2ish.h index ade419912f..7cf56fe79b 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -140,7 +140,6 @@ void *emx_realloc (void *, size_t); /* This guy is needed for quick stdstd */ #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) -# define _filbuf _fill /* Perl uses ungetc only with successful return */ # define ungetc(c,fp) \ (FILE_ptr(fp) > FILE_base(fp) && c == (int)*(FILE_ptr(fp) - 1) \ diff --git a/patchlevel.h b/patchlevel.h index d43d8035b7..2603bc141a 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,5 +1,5 @@ #define PATCHLEVEL 3 -#define SUBVERSION 22 +#define SUBVERSION 23 /* local_patches -- list of locally applied less-than-subversion patches. @@ -59,7 +59,7 @@ dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n"; static void find_beginning _((void)); static void forbid_setid _((char *)); -static void incpush _((char *)); +static void incpush _((char *, int)); static void init_ids _((void)); static void init_debugger _((void)); static void init_lexer _((void)); @@ -561,10 +561,10 @@ setuid perl scripts securely.\n"); sv_catpv(sv,s); sv_catpv(sv," "); if (*++s) { - av_push(GvAVn(incgv),newSVpv(s,0)); + incpush(s, TRUE); } else if (argv[1]) { - av_push(GvAVn(incgv),newSVpv(argv[1],0)); + incpush(argv[1], TRUE); sv_catpv(sv,argv[1]); argc--,argv++; sv_catpv(sv," "); @@ -881,7 +881,7 @@ I32 create; { GV* gv = gv_fetchpv(name, create, SVt_PVCV); if (create && !GvCVu(gv)) - return newSUB(start_subparse(0), + return newSUB(start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, newSVpv(name,0)), Nullop, Nullop); @@ -1190,47 +1190,6 @@ I32 namlen; sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen); } -#if defined(DOSISH) -# define PERLLIB_SEP ';' -#else -# if defined(VMS) -# define PERLLIB_SEP '|' -# else -# define PERLLIB_SEP ':' -# endif -#endif -#ifndef PERLLIB_MANGLE -# define PERLLIB_MANGLE(s,n) (s) -#endif - -static void -incpush(p) -char *p; -{ - char *s; - - if (!p) - return; - - /* Break at all separators */ - while (*p) { - /* First, skip any consecutive separators */ - while ( *p == PERLLIB_SEP ) { - /* Uncomment the next line for PATH semantics */ - /* av_push(GvAVn(incgv), newSVpv(".", 1)); */ - p++; - } - if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) { - av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)), - (STRLEN)(s - p))); - p = s + 1; - } else { - av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0)); - break; - } - } -} - static void usage(name) /* XXX move this out into a module ? */ char *name; @@ -1346,9 +1305,11 @@ char *s; case 'I': forbid_setid("-I"); if (*++s) { - char *e; + char *e, *p; for (e = s; *e && !isSPACE(*e); e++) ; - av_push(GvAVn(incgv),newSVpv(s,e-s)); + p = savepvn(s, e-s); + incpush(p, TRUE); + Safefree(p); if (*e) return e; } @@ -1444,7 +1405,6 @@ char *s; #endif printf("\n\nCopyright 1987-1997, Larry Wall\n"); - printf("\n\t+ suidperl security patch"); #ifdef MSDOS printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif @@ -2298,9 +2258,9 @@ init_perllib() #ifndef VMS s = getenv("PERL5LIB"); if (s) - incpush(s); + incpush(s, TRUE); else - incpush(getenv("PERLLIB")); + incpush(getenv("PERLLIB"), FALSE); #else /* VMS */ /* Treat PERL5?LIB as a possible search list logical name -- the * "natural" VMS idiom for a Unix path string. We allow each @@ -2309,9 +2269,9 @@ init_perllib() char buf[256]; int idx = 0; if (my_trnlnm("PERL5LIB",buf,0)) - do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx)); + do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx)); else - while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf); + while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE); #endif /* VMS */ } @@ -2319,29 +2279,116 @@ init_perllib() ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB */ #ifdef APPLLIB_EXP - incpush(APPLLIB_EXP); + incpush(APPLLIB_EXP, FALSE); #endif #ifdef ARCHLIB_EXP - incpush(ARCHLIB_EXP); + incpush(ARCHLIB_EXP, FALSE); #endif #ifndef PRIVLIB_EXP #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" #endif - incpush(PRIVLIB_EXP); + incpush(PRIVLIB_EXP, FALSE); #ifdef SITEARCH_EXP - incpush(SITEARCH_EXP); + incpush(SITEARCH_EXP, FALSE); #endif #ifdef SITELIB_EXP - incpush(SITELIB_EXP); + incpush(SITELIB_EXP, FALSE); #endif #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */ - incpush(OLDARCHLIB_EXP); + incpush(OLDARCHLIB_EXP, FALSE); #endif if (!tainting) - incpush("."); + incpush(".", FALSE); +} + +#if defined(DOSISH) +# define PERLLIB_SEP ';' +#else +# if defined(VMS) +# define PERLLIB_SEP '|' +# else +# define PERLLIB_SEP ':' +# endif +#endif +#ifndef PERLLIB_MANGLE +# define PERLLIB_MANGLE(s,n) (s) +#endif + +static void +incpush(p, addsubdirs) +char *p; +int addsubdirs; +{ + SV *subdir = Nullsv; + static char *archpat_auto; + + if (!p) + return; + + if (addsubdirs) { + subdir = newSV(0); + if (!archpat_auto) { + STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel) + + sizeof("//auto")); + New(55, archpat_auto, len, char); + sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel); + } + } + + /* Break at all separators */ + while (p && *p) { + SV *libdir = newSV(0); + char *s; + + /* skip any consecutive separators */ + while ( *p == PERLLIB_SEP ) { + /* Uncomment the next line for PATH semantics */ + /* av_push(GvAVn(incgv), newSVpv(".", 1)); */ + p++; + } + + if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) { + sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)), + (STRLEN)(s - p)); + p = s + 1; + } + else { + sv_setpv(libdir, PERLLIB_MANGLE(p, 0)); + p = Nullch; /* break out */ + } + + /* + * BEFORE pushing libdir onto @INC we may first push version- and + * archname-specific sub-directories. + */ + if (addsubdirs) { + struct stat tmpstatbuf; + + /* .../archname/version if -d .../archname/auto */ + sv_setsv(subdir, libdir); + sv_catpv(subdir, archpat_auto); + if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + S_ISDIR(tmpstatbuf.st_mode)) + av_push(GvAVn(incgv), + newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); + + /* .../archname/version if -d .../archname/version/auto */ + sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME), + strlen(patchlevel) + 1, "", 0); + if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + S_ISDIR(tmpstatbuf.st_mode)) + av_push(GvAVn(incgv), + newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); + } + + /* finally push this lib directory on the end of @INC */ + av_push(GvAVn(incgv), libdir); + } + + SvREFCNT_dec(subdir); } void @@ -1706,15 +1706,15 @@ case 52: break; case 53: #line 280 "perly.y" -{ yyval.ival = start_subparse(0); } +{ yyval.ival = start_subparse(FALSE, 0); } break; case 54: #line 284 "perly.y" -{ yyval.ival = start_subparse(CVf_ANON); } +{ yyval.ival = start_subparse(FALSE, CVf_ANON); } break; case 55: #line 288 "perly.y" -{ yyval.ival = start_subparse(CVf_FORMAT); } +{ yyval.ival = start_subparse(TRUE, 0); } break; case 56: #line 291 "perly.y" @@ -277,15 +277,15 @@ subrout : SUB startsub subname proto subbody ; startsub: /* NULL */ /* start a regular subroutine scope */ - { $$ = start_subparse(0); } + { $$ = start_subparse(FALSE, 0); } ; startanonsub: /* NULL */ /* start an anonymous subroutine scope */ - { $$ = start_subparse(CVf_ANON); } + { $$ = start_subparse(FALSE, CVf_ANON); } ; startformsub: /* NULL */ /* start a format subroutine scope */ - { $$ = start_subparse(CVf_FORMAT); } + { $$ = start_subparse(TRUE, 0); } ; subname : WORD { char *name = SvPVx(((SVOP*)$1)->op_sv, na); diff --git a/plan9/config.plan9 b/plan9/config.plan9 index b10c75852f..a900df34a9 100644 --- a/plan9/config.plan9 +++ b/plan9/config.plan9 @@ -51,6 +51,12 @@ */ #define BIN "/_P9P_OBJTYPE/bin" /* */ +/* BINCOMPAT3: + * This symbol, if defined, indicates that Perl 5.004 should be + * binary-compatible with Perl 5.003. + */ +#undef BINCOMPAT3 /**/ + /* CPPSTDIN: * This symbol contains the first part of the string which will invoke * the C preprocessor on the standard input and produce to standard @@ -298,6 +304,15 @@ */ #undef HAS_GETPRIORITY /**/ +/* HAS_GETTIMEOFDAY: + * This symbol, if defined, indicates that the gettimeofday() system + * call is available for a sub-second accuracy clock. Usually, the file + * <sys/resource.h> needs to be included (see I_SYS_RESOURCE). + * The type "Timeval" should be used to refer to "struct timeval". + */ +#define HAS_GETTIMEOFDAY /**/ +#define Timeval struct timeval /* Structure used by gettimeofday() */ /* config-skip */ + /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and * friends htons() ntohl() ntohs()) are available to do network @@ -326,6 +341,13 @@ #define HAS_NTOHS /**/ +/* HAS_INET_ATON: + * This symbol, if defined, indicates to the C program that the + * inet_aton() function is available to parse IP address "dotted-quad" + * strings. + */ +#undef HAS_INET_ATON /**/ + /* HAS_ISASCII: * This manifest constant lets the C program know that isascii * is available. @@ -484,6 +506,13 @@ */ #define HAS_READDIR /**/ +/* HAS_SANE_MEMCMP: + * This symbol, if defined, indicates that the memcmp routine is available + * and can be used to compare relative magnitudes of chars with their high + * bits set. If it is not defined, roll your own version. + */ +#define HAS_SANE_MEMCMP /**/ + /* HAS_SEEKDIR: * This symbol, if defined, indicates that the seekdir routine is * available. You may have to include <dirent.h>. See I_DIRENT. @@ -693,6 +722,24 @@ #define HAS_SOCKET /**/ #define HAS_SOCKETPAIR /**/ +/* HAS_STRTOD: + * This symbol, if defined, indicates that the strtod routine is + * available to provide better numeric string conversion than atof(). + */ +#define HAS_STRTOD /**/ + +/* HAS_STRTOL: + * This symbol, if defined, indicates that the strtol routine is available + * to provide better numeric string conversion than atoi() and friends. + */ +#define HAS_STRTOL /**/ + +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +#define HAS_STRTOUL /**/ + /* USE_STAT_BLOCKS: * This symbol is defined if this system has a stat structure declaring * st_blksize and st_blocks. @@ -759,15 +806,6 @@ #define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) #endif -/* FILE_filbuf: - * This macro is used to access the internal stdio _filbuf function - * (or equivalent), if STDIO_CNT_LVALUE and STDIO_PTR_LVALUE - * are defined. It is typically either _filbuf or __filbuf. - * This macro will only be defined if both STDIO_CNT_LVALUE and - * STDIO_PTR_LVALUE are defined. - */ -#undef FILE_filbuf - /* HAS_STRCHR: * This symbol is defined to indicate that the strchr()/strrchr() * functions are available for string searching. If not, try the @@ -1347,6 +1385,14 @@ #define ARCHLIB_EXP "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION" #define ARCHLIB "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION" +/* ARCHNAME: + * This symbol holds a string representing the architecture name. + * It may be used to construct an architecture-dependant pathname + * where library files may be held under a private library, for + * instance. + */ +#define ARCHNAME "plan9__P9P_OBJTYPE" /**/ + /* BYTEORDER: * This symbol hold the hexadecimal constant defined in byteorder, * i.e. 0x1234 or 0x4321, etc... diff --git a/plan9/mkfile b/plan9/mkfile index e3102f5ef0..e56aa3c472 100644 --- a/plan9/mkfile +++ b/plan9/mkfile @@ -26,8 +26,8 @@ libpods = ${podnames:%=pod/%.pod} perlpods = $libpods -extensions = IO Socket Opcode DynaLoader Fcntl FileHandle POSIX -ext_xs = IO.xs Socket.xs Opcode.xs dl_none.xs Fcntl.xs FileHandle.xs POSIX.xs +extensions = IO Socket Opcode DynaLoader Fcntl POSIX +ext_xs = IO.xs Socket.xs Opcode.xs dl_none.xs Fcntl.xs POSIX.xs ext_c = ${ext_xs:%.xs=%.c} ext_obj = ${ext_xs:%.xs=%.$O} @@ -98,10 +98,6 @@ Fcntl.c: miniperl ext/Fcntl/Fcntl.xs ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/Fcntl/Fcntl.xs > $target cp ext/Fcntl/Fcntl.pm $privlib -FileHandle.c: miniperl ext/FileHandle/FileHandle.xs - ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/FileHandle/FileHandle.xs > $target - cp ext/FileHandle/FileHandle.pm $privlib - POSIX.c: miniperl ext/POSIX/POSIX.xs ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/POSIX/POSIX.xs > $target cp ext/POSIX/POSIX.pm $privlib diff --git a/pod/Makefile b/pod/Makefile index cd01028069..cf1e7a49d5 100644 --- a/pod/Makefile +++ b/pod/Makefile @@ -5,7 +5,7 @@ PERL = ../miniperl POD = \ perl.pod \ - perlnews.pod \ + perldelta.pod \ perldata.pod \ perlsyn.pod \ perlop.pod \ @@ -42,7 +42,7 @@ POD = \ MAN = \ perl.man \ - perlnews.man \ + perldelta.man \ perldata.man \ perlsyn.man \ perlop.man \ @@ -79,7 +79,7 @@ MAN = \ HTML = \ perl.html \ - perlnews.html \ + perldelta.html \ perldata.html \ perlsyn.html \ perlop.html \ @@ -116,7 +116,7 @@ HTML = \ TEX = \ perl.tex \ - perlnews.tex \ + perldelta.tex \ perldata.tex \ perlsyn.tex \ perlop.tex \ diff --git a/pod/buildtoc b/pod/buildtoc index da458568da..b0e514ee05 100644 --- a/pod/buildtoc +++ b/pod/buildtoc @@ -5,11 +5,11 @@ use Text::Wrap; sub output ($); @pods = qw( - perl perlnews perldata perlsyn perlop perlre perlrun perlfunc + perl perldelta perldata perlsyn perlop perlre perlrun perlfunc perlvar perlsub perlmod perlform perllocale perlref perldsc perllol perltoot perlobj perltie perlbot perlipc perldebug - perldiag perlsec perltrap perlstyle perlpod perlbook - perlembed perlapio perlxs perlxstut perlguts perlcall + perldiag perlsec perltrap perlstyle perlpod perlbook perlembed + perlapio perlxs perlxstut perlguts perlcall ); for (@pods) { s/$/.pod/ } diff --git a/pod/checkpods.PL b/pod/checkpods.PL index c4721a6118..4bec4da609 100644 --- a/pod/checkpods.PL +++ b/pod/checkpods.PL @@ -14,6 +14,7 @@ use File::Basename qw(&basename &dirname); # This is so that make depend always knows where to find PL derivatives. chdir dirname($0); $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; diff --git a/pod/perl.pod b/pod/perl.pod index 7ac7094f57..dcab07a37b 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -19,7 +19,7 @@ For ease of access, the Perl manual has been split up into a number of sections: perl Perl overview (this section) - perlnews Perl news about changes from previous version + perldelta Perl changes since previous version perldata Perl data structures perlsyn Perl syntax diff --git a/pod/perldebug.pod b/pod/perldebug.pod index 77502f27d3..0c61b74350 100644 --- a/pod/perldebug.pod +++ b/pod/perldebug.pod @@ -60,12 +60,17 @@ it's run through your pager, as in DB> |h +You may change the pager which is used via C<O pager=...> command. + =item p expr Same as C<print {$DB::OUT} expr> in the current package. In particular, because this is just Perl's own B<print> function, this means that nested data structures and objects are not dumped, unlike with the C<x> command. +The C<DB::OUT> filehandle is opened to F</dev/tty>, regardless of +where STDOUT may be redirected to. + =item x expr Evaluates its expression in list context and dumps out the result @@ -105,10 +110,12 @@ Single step. Executes until it reaches the beginning of another statement, descending into subroutine calls. If an expression is supplied that includes function calls, it too will be single-stepped. -=item n +=item n [expr] Next. Executes over subroutine calls, until it reaches the beginning -of the next statement. +of the next statement. If an expression is supplied that includes +function calls, those functions will be executed with stops before +each statement. =item E<lt>CRE<gt> @@ -129,7 +136,7 @@ List C<incr+1> lines starting at C<min>. =item l min-max -List lines C<min> through C<max>. +List lines C<min> through C<max>. C<l -> is synonymous to C<->. =item l line @@ -154,7 +161,9 @@ print it out. =item f filename -Switch to viewing a different file. +Switch to viewing a different file or eval statement. If C<filename> +is not a full filename as found in values of %INC, it is considered as +a regexp. =item /pattern/ @@ -235,7 +244,13 @@ Set breakpoint at first line of subroutine after it is compiled. =item b load filename -Set breakpoint at the first executed line of the file. +Set breakpoint at the first executed line of the file. Filename should +be a full name as found in values of %INC. + +=item b compile subname + +Sets breakpoint at the first statement executed after the subroutine +is compiled. =item d [line] @@ -273,34 +288,41 @@ be abbreviated. Several options can be listed. =over 12 -=item recallCommand, ShellBang +=item C<recallCommand>, C<ShellBang> The characters used to recall command or spawn shell. By default, these are both set to C<!>. -=item pager +=item C<pager> Program to use for output of pager-piped commands (those beginning with a C<|> character.) By default, C<$ENV{PAGER}> will be used. -=item tkRunning +=item C<tkRunning> Run Tk while prompting (with ReadLine). -=item signalLevel, warnLevel, dieLevel +=item C<signalLevel>, C<warnLevel>, C<dieLevel> + +Level of verbosity. By default the debugger is in a sane verbose mode, +thus it will print backtraces on all the warnings and die-messages +which are going to be printed out, and will print a message when +interesting uncaught signals arrive. -Level of verbosity. +To disable this behaviour, set these values to 0. If C<dieLevel> is 2, +then the messages which will be caught by surrounding C<eval> are also +printed. -=item AutoTrace +=item C<AutoTrace> -Where to print all the breakable points in the executed program -(similar to C<t> command, but can be put into C<PERLDB_OPTS>). +Trace mode (similar to C<t> command, but can be put into +C<PERLDB_OPTS>). -=item LineInfo +=item C<LineInfo> -File or pipe to print line number info to. If it is a -pipe, then a short, "emacs like" message is used. +File or pipe to print line number info to. If it is a pipe (say, +C<|visual_perl_db>), then a short, "emacs like" message is used. =item C<inhibit_exit> @@ -317,7 +339,14 @@ C<frame & 2> is false, messages are printed on entry only. (Printing on exit may be useful if inter(di)spersed with other messages.) If C<frame & 4>, arguments to functions are printed as well as the -context and caller info. +context and caller info. If C<frame & 8>, overloaded C<stringify> and +C<tie>d C<FETCH> are enabled on the printed arguments. The length at +which the argument list is truncated is governed by the next option: + +=item C<maxTraceLen> + +length at which the argument list is truncated when C<frame> option's +bit 4 is set. =back @@ -326,29 +355,38 @@ commands: =over 12 -=item arrayDepth, hashDepth +=item C<arrayDepth>, C<hashDepth> Print only first N elements ('' for all). -=item compactDump, veryCompact +=item C<compactDump>, C<veryCompact> -Change style of array and hash dump. +Change style of array and hash dump. If C<compactDump>, short array +may be printed on one line. -=item globPrint +=item C<globPrint> Whether to print contents of globs. -=item DumpDBFiles +=item C<DumpDBFiles> Dump arrays holding debugged files. -=item DumpPackages +=item C<DumpPackages> Dump symbol tables of packages. -=item quote, HighBit, undefPrint +=item C<quote>, C<HighBit>, C<undefPrint> + +Change style of string dump. Default value of C<quote> is C<auto>, one +can enable either double-quotish dump, or single-quotish by setting it +to C<"> or C<'>. By default, characters with high bit set are printed +I<as is>. + +=item C<UsageOnly> -Change style of string dump. +I<very> rudimentally per-package memory usage dump. Calculates total +size of strings in variables in the package. =back @@ -358,7 +396,7 @@ C<ReadLine>, and C<NonStop> there. Example rc file: - &parse_options("NonStop=1 LineInfo=db.out AutoTrace"); + &parse_options("NonStop=1 LineInfo=db.out AutoTrace"); The script will run without human intervention, putting trace information into the file I<db.out>. (If you interrupt it, you would better reset @@ -370,16 +408,9 @@ C<LineInfo> to something "interactive"!) The TTY to use for debugging I/O. -=item noTTY - -If set, goes in C<NonStop> mode. On interrupt if TTY is not set uses the -value of C<noTTY> or "/tmp/perldbtty$$" to find TTY using -C<Term::Rendezvous>. Current variant is to have the name of TTY in this -file. - =item C<noTTY> -If set, goes in C<NonStop> mode, and would not connect to a TTY. If +If set, goes in C<NonStop> mode, and would not connect to a TTY. If interrupt (or if control goes to debugger via explicit setting of $DB::signal or $DB::single from the Perl script), connects to a TTY specified by the C<TTY> option at startup, or to a TTY found at @@ -387,7 +418,7 @@ runtime using C<Term::Rendezvous> module of your choice. This module should implement a method C<new> which returns an object with two methods: C<IN> and C<OUT>, returning two filehandles to use -for debugging input and output correspondingly. Method C<new> may +for debugging input and output correspondingly. Method C<new> may inspect an argument which is a value of C<$ENV{PERLDB_NOTTY}> at startup, or is C<"/tmp/perldbtty$$"> otherwise. @@ -405,18 +436,18 @@ programmatically by setting $DB::signal or $DB::single. Here's an example of using the C<$ENV{PERLDB_OPTS}> variable: - $ PERLDB_OPTS="N f=2" perl -d myprogram + $ PERLDB_OPTS="N f=2" perl -d myprogram will run the script C<myprogram> without human intervention, printing out the call tree with entry and exit points. Note that C<N f=2> is -equivalent to C<NonStop=1 frame=2>. Note also that at the moment when +equivalent to C<NonStop=1 frame=2>. Note also that at the moment when this documentation was written all the options to the debugger could be uniquely abbreviated by the first letter (with exception of C<Dump*> options). Other examples may include - $ PERLDB_OPTS="N f A L=listing" perl -d myprogram + $ PERLDB_OPTS="N f A L=listing" perl -d myprogram - runs script non-interactively, printing info on each entry into a subroutine and each executed line into the file F<listing>. (If you @@ -424,13 +455,13 @@ interrupt it, you would better reset C<LineInfo> to something "interactive"!) - $ env "PERLDB_OPTS=R=0 TTY=/dev/ttyc" perl -d myprogram + $ env "PERLDB_OPTS=R=0 TTY=/dev/ttyc" perl -d myprogram may be useful for debugging a program which uses C<Term::ReadLine> -itself. Do not forget detach shell from the TTY in the window which +itself. Do not forget detach shell from the TTY in the window which corresponds to F</dev/ttyc>, say, by issuing a command like - $ sleep 1000000 + $ sleep 1000000 See L<"Debugger Internals"> below for more details. @@ -500,7 +531,7 @@ Quit. ("quit" doesn't work for this.) This is the only supported way to exit the debugger, though typing C<exit> twice may do it too. Set an C<O>ption C<inhibit_exit> to 0 if you want to be able to I<step -off> the end the script. You may also need to set C<$finished> to 0 at +off> the end the script. You may also need to set C<$finished> to 0 at some moment if you want to step through global destruction. =item R @@ -527,20 +558,34 @@ output, such as =item = [alias value] -Define a command alias, or list current aliases. +Define a command alias, like + + = quit q + +or list current aliases. =item command Execute command as a Perl statement. A missing semicolon will be supplied. -=item p expr +=item m expr -Same as C<print DB::OUT expr>. The DB::OUT filehandle is opened to -/dev/tty, regardless of where STDOUT may be redirected to. +The expression is evaluated, and the methods which may be applied to +the result are listed. + +=item m package + +The methods which may be applied to objects in the C<package> are listed. =back +=head2 Debugger input/output + +=over 8 + +=item Prompt + The debugger prompt is something like DB<8> @@ -557,9 +602,12 @@ you'd already at a breakpoint and then printed out the result of a function call that itself also has a breakpoint, or you step into an expression via C<s/n/t expression> command. +=item Multi-line commands + If you want to enter a multi-line command, such as a subroutine -definition with several statements, you may escape the newline that would -normally end the debugger command with a backslash. Here's an example: +definition with several statements, or a format, you may escape the +newline that would normally end the debugger command with a backslash. +Here's an example: DB<1> for (1..4) { \ cont: print "ok\n"; \ @@ -572,7 +620,10 @@ normally end the debugger command with a backslash. Here's an example: Note that this business of escaping a newline is specific to interactive commands typed into the debugger. -Here's an example of what a stack back-trace might look like: +=item Stack backtrace + +Here's an example of what a stack back-trace via C<T> command might +look like: $ = main::infested called from file `Ambulation.pm' line 10 @ = Ambulation::legs(1, 2, 3, 4) called from file `camel_flea' line 7 @@ -589,6 +640,160 @@ I<camel_flea> file with four arguments. The last stack frame shows that C<main::pests> was called in a scalar context, also from I<camel_flea>, but from line 4. +Note that if you execute C<T> command from inside an active C<use> +statement, the backtrace will contain both C<L<perlfunc/require>> +frame and an C<L<perlfunc/eval EXPR>>) frame. + +=item Listing + +Listing given via different flavors of C<l> command looks like this: + + DB<<13>> l + 101: @i{@i} = (); + 102:b @isa{@i,$pack} = () + 103 if(exists $i{$prevpack} || exists $isa{$pack}); + 104 } + 105 + 106 next + 107==> if(exists $isa{$pack}); + 108 + 109:a if ($extra-- > 0) { + 110: %isa = ($pack,1); + +Note that the breakable lines are marked with C<:>, lines with +breakpoints are marked by C<b>, with actions by C<a>, and the +next executed line is marked by C<==E<gt>>. + +=item Frame listing + +When C<frame> option is set, debugger would print entered (and +optionally exited) subroutines in different styles. + +What follows is the start of the listing of + + env "PERLDB_OPTS=f=1 N" perl -d -V + +=over 4 + +=item 1 + + entering main::BEGIN + entering Config::BEGIN + Package lib/Exporter.pm. + Package lib/Carp.pm. + Package lib/Config.pm. + entering Config::TIEHASH + entering Exporter::import + entering Exporter::export + entering Config::myconfig + entering Config::FETCH + entering Config::FETCH + entering Config::FETCH + entering Config::FETCH + +=item 2 + + entering main::BEGIN + entering Config::BEGIN + Package lib/Exporter.pm. + Package lib/Carp.pm. + exited Config::BEGIN + Package lib/Config.pm. + entering Config::TIEHASH + exited Config::TIEHASH + entering Exporter::import + entering Exporter::export + exited Exporter::export + exited Exporter::import + exited main::BEGIN + entering Config::myconfig + entering Config::FETCH + exited Config::FETCH + entering Config::FETCH + exited Config::FETCH + entering Config::FETCH + +=item 4 + + in $=main::BEGIN() from /dev/nul:0 + in $=Config::BEGIN() from lib/Config.pm:2 + Package lib/Exporter.pm. + Package lib/Carp.pm. + Package lib/Config.pm. + in $=Config::TIEHASH('Config') from lib/Config.pm:644 + in $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0 + in $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from li + in @=Config::myconfig() from /dev/nul:0 + in $=Config::FETCH(ref(Config), 'package') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'baserev') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'PATCHLEVEL') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'SUBVERSION') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'osname') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'osvers') from lib/Config.pm:574 + +=item 6 + + in $=main::BEGIN() from /dev/nul:0 + in $=Config::BEGIN() from lib/Config.pm:2 + Package lib/Exporter.pm. + Package lib/Carp.pm. + out $=Config::BEGIN() from lib/Config.pm:0 + Package lib/Config.pm. + in $=Config::TIEHASH('Config') from lib/Config.pm:644 + out $=Config::TIEHASH('Config') from lib/Config.pm:644 + in $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0 + in $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from lib/ + out $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from lib/ + out $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0 + out $=main::BEGIN() from /dev/nul:0 + in @=Config::myconfig() from /dev/nul:0 + in $=Config::FETCH(ref(Config), 'package') from lib/Config.pm:574 + out $=Config::FETCH(ref(Config), 'package') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'baserev') from lib/Config.pm:574 + out $=Config::FETCH(ref(Config), 'baserev') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'PATCHLEVEL') from lib/Config.pm:574 + out $=Config::FETCH(ref(Config), 'PATCHLEVEL') from lib/Config.pm:574 + in $=Config::FETCH(ref(Config), 'SUBVERSION') from lib/Config.pm:574 + +=item 14 + + in $=main::BEGIN() from /dev/nul:0 + in $=Config::BEGIN() from lib/Config.pm:2 + Package lib/Exporter.pm. + Package lib/Carp.pm. + out $=Config::BEGIN() from lib/Config.pm:0 + Package lib/Config.pm. + in $=Config::TIEHASH('Config') from lib/Config.pm:644 + out $=Config::TIEHASH('Config') from lib/Config.pm:644 + in $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0 + in $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from lib/E + out $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from lib/E + out $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0 + out $=main::BEGIN() from /dev/nul:0 + in @=Config::myconfig() from /dev/nul:0 + in $=Config::FETCH('Config=HASH(0x1aa444)', 'package') from lib/Config.pm:574 + out $=Config::FETCH('Config=HASH(0x1aa444)', 'package') from lib/Config.pm:574 + in $=Config::FETCH('Config=HASH(0x1aa444)', 'baserev') from lib/Config.pm:574 + out $=Config::FETCH('Config=HASH(0x1aa444)', 'baserev') from lib/Config.pm:574 + +=back + +In all the cases indentation of lines shows the call tree, if bit 2 of +C<frame> is set, then a line is printed on exit from a subroutine as +well, if bit 4 is set, then the arguments are printed as well as the +caller info, if bit 8 is set, the arguments are printed even if they +are tied or references. + +When a package is compiled, a line like this + + Package lib/Carp.pm. + +is printed with proper indentation. + +=back + +=head2 Debugging compile-time statements + If you have any compile-time executable statements (code within a BEGIN block or a C<use> statement), these will C<NOT> be stopped by debugger, although C<require>s will (and compile-time statements can be traced @@ -604,10 +809,19 @@ just typed the C<n> command, whereas a value of 1 means the C<s> command. The C<$DB::trace> variable should be set to 1 to simulate having typed the C<t> command. +Another way to debug compile-time code is to start debugger, set a +breakpoint on I<load> of some module thusly + + DB<7> b load f:/perllib/lib/Carp.pm + Will stop on load of `f:/perllib/lib/Carp.pm'. + +and restart debugger by C<R> command (if possible). One can use C<b +compile subname> for the same purpose. + =head2 Debugger Customization Most probably you not want to modify the debugger, it contains enough -hooks to satisfy most needs. You may change the behaviour of debugger +hooks to satisfy most needs. You may change the behaviour of debugger from the debugger itself, using C<O>ptions, from the command line via C<PERLDB_OPTS> environment variable, and from I<customization files>. @@ -624,10 +838,10 @@ One changes options from F<.perldb> file via calls like this one; parse_options("NonStop=1 LineInfo=db.out AutoTrace=1 frame=2"); -(the code is executed in the package C<DB>). Note that F<.perldb> is -processed before processing C<PERLDB_OPTS>. If F<.perldb> defines the +(the code is executed in the package C<DB>). Note that F<.perldb> is +processed before processing C<PERLDB_OPTS>. If F<.perldb> defines the subroutine C<afterinit>, it is called after all the debugger -initialization ends. F<.perldb> may be contained in the current +initialization ends. F<.perldb> may be contained in the current directory, or in the C<LOGDIR>/C<HOME> directory. If you want to modify the debugger, copy F<perl5db.pl> from the Perl @@ -647,6 +861,10 @@ the Term::ReadKey and Term::ReadLine modules from CPAN, you will have full editing capabilities much like GNU I<readline>(3) provides. Look for these in the F<modules/by-module/Term> directory on CPAN. +A rudimentary command-line completion is also available. +Unfortunately, the names of lexical variables are not available for +completion. + =head2 Editor Support for Debugging If you have GNU B<emacs> installed on your system, it can interact with @@ -683,9 +901,9 @@ in that profile. =head2 Debugger support in perl -When you call the B<caller> function from package DB, Perl sets the -C<@DB::args> array to contain the arguments that stack frame was called -with. +When you call the B<caller> function (see L<perlfunc/caller>) from the +package DB, Perl sets the array @DB::args to contain the arguments the +corresponding stack frame was called with. If perl is run with B<-d> option, the following additional features are enabled: @@ -701,48 +919,48 @@ application. =item * The array C<@{"_<$filename"}> is the line-by-line contents of -$filename for all the compiled files. Same for C<eval>ed strings which -contain subroutines, or which are currently executed. The C<$filename> +$filename for all the compiled files. Same for C<eval>ed strings which +contain subroutines, or which are currently executed. The C<$filename> for C<eval>ed strings looks like C<(eval 34)>. =item * The hash C<%{"_<$filename"}> contains breakpoints and action (it is keyed by line number), and individual entries are settable (as opposed -to the whole hash). Only true/false is important to Perl, though the +to the whole hash). Only true/false is important to Perl, though the values used by F<perl5db.pl> have the form -C<"$break_condition\0$action">. Values are magical in numeric context: +C<"$break_condition\0$action">. Values are magical in numeric context: they are zeros if the line is not breakable. Same for evaluated strings which contain subroutines, or which are -currently executed. The C<$filename> for C<eval>ed strings looks like +currently executed. The C<$filename> for C<eval>ed strings looks like C<(eval 34)>. =item * -The scalar C<${"_<$filename"}> contains C<"_<$filename">. Same for +The scalar C<${"_<$filename"}> contains C<"_<$filename">. Same for evaluated strings which contain subroutines, or which are currently -executed. The C<$filename> for C<eval>ed strings looks like C<(eval +executed. The C<$filename> for C<eval>ed strings looks like C<(eval 34)>. =item * After each C<require>d file is compiled, but before it is executed, C<DB::postponed(*{"_<$filename"})> is called (if subroutine -C<DB::postponed> exists). Here the $filename is the expanded name of +C<DB::postponed> exists). Here the $filename is the expanded name of the C<require>d file (as found in values of C<%INC>). =item * After each subroutine C<subname> is compiled existence of -C<$DB::postponed{subname}> is checked. If this key exists, +C<$DB::postponed{subname}> is checked. If this key exists, C<DB::postponed(subname)> is called (if subroutine C<DB::postponed> exists). =item * A hash C<%DB::sub> is maintained, with keys being subroutine names, -values having the form C<filename:startline-endline>. C<filename> has +values having the form C<filename:startline-endline>. C<filename> has the form C<(eval 31)> for subroutines defined inside C<eval>s. =item * @@ -752,7 +970,7 @@ a breakpoint, a call to C<DB::DB()> is performed if any one of variables $DB::trace, $DB::single, or $DB::signal is true. (Note that these variables are not C<local>izable.) This feature is disabled when the control is inside C<DB::DB()> or functions called from it (unless -C<$^D & 1 E<lt>E<lt> 30>). +C<$^D & (1E<lt>E<lt>30)>). =item * @@ -764,10 +982,42 @@ in the package C<DB>.) =back Note that no subroutine call is possible until C<&DB::sub> is defined -(for subroutines outside of package C<DB>). (In fact, for the -standard debugger the same is true if C<$DB::deep> (how many levels of -recursion deep into the debugger you can go before a mandatory break) -is not defined.) +(for subroutines outside of package C<DB>). (This restriction is +recently lifted.) + +(In fact, for the standard debugger the same is true if C<$DB::deep> +(how many levels of recursion deep into the debugger you can go before +a mandatory break) is not defined.) + +With the recent updates the minimal possible debugger consists of one +line + + sub DB::DB {} + +which is quite handy as contents of C<PERL5DB> environment +variable: + + env "PERL5DB=sub DB::DB {}" perl -d your-script + +Another (a little bit more useful) minimal debugger can be created +with the only line being + + sub DB::DB {print ++$i; scalar <STDIN>} + +This debugger would print the sequential number of encountered +statement, and would wait for your C<CR> to continue. + +The following debugger is quite functional: + + { + package DB; + sub DB {} + sub sub {print ++$i, " $sub\n"; &$sub} + } + +It prints the sequential number of subroutine call and the name of the +called subroutine. Note that C<&DB::sub> should be compiled into the +package C<DB>. =head2 Debugger Internals @@ -781,21 +1031,21 @@ PERLDB_OPTS and parses it as a rest of C<O ...> line in debugger prompt. It also maintains magical internal variables, such as C<@DB::dbline>, C<%DB::dbline>, which are aliases for C<@{"::_<current_file"}> -C<%{"::_<current_file"}>. Here C<current_file> is the currently +C<%{"::_<current_file"}>. Here C<current_file> is the currently selected (with the debugger's C<f> command, or by flow of execution) file. -Some functions are provided to simplify customization. See L<"Debugger -Customization"> for description of C<DB::parse_options(string)>. The +Some functions are provided to simplify customization. See L<"Debugger +Customization"> for description of C<DB::parse_options(string)>. The function C<DB::dump_trace(skip[, count])> skips the specified number of frames, and returns an array containing info about the caller -frames (all if C<count> is missing). Each entry is a hash with keys +frames (all if C<count> is missing). Each entry is a hash with keys C<context> (C<$> or C<@>), C<sub> (subroutine name, or info about eval), C<args> (C<undef> or a reference to an array), C<file>, and C<line>. The function C<DB::print_trace(FH, skip[, count[, short]])> prints -formatted info about caller frames. The last two functions may be +formatted info about caller frames. The last two functions may be convenient as arguments to C<E<lt>>, C<E<lt>E<lt>> commands. =head2 Other resources diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 3cd71de7d1..b33f1ff81f 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -1,6 +1,6 @@ =head1 NAME -perlnews - what's new for perl5.004 +perldelta - what's new for perl5.004 =head1 DESCRIPTION @@ -24,7 +24,8 @@ There is a new Configure question that asks if you want to maintain binary compatibility with Perl 5.003. If you choose binary compatibility, you do not have to recompile your extensions, but you might have symbol conflicts if you embed Perl in another application, -just as in the 5.003 release. +just as in the 5.003 release. By default, binary compatibility +is preserved at the expense of symbol table pollution. =head2 New Opcode Module and Revised Safe Module @@ -33,11 +34,26 @@ application of opcode masks. The revised Safe module has a new API and is implemented using the new Opcode module. Please read the new Opcode and Safe documentation. +=head2 Extended Fcntl Module + +The Fcntl module now supports these new constants + + F_GETOWN F_SETOWN + O_ASYNC O_DEFER O_DSYNC O_RSYNC O_SYNC + O_EXLOCK O_SHLOCK + +provided that your operating system supports these constants. The +constants are for use with the Perl sysopen() and fcntl(). These +constants are also visible for the basic database modules like the +SDBM_File. For the exact meaning of these contants and other Fcntl +constants please refer to the fcntl() documentation of your operating +system. Unsupported constants will cause run-time errors. + =head2 Internal Change: FileHandle Deprecated Filehandles are now stored internally as type IO::Handle. Although C<use FileHandle> and C<*STDOUT{FILEHANDLE}> -are still supported for backwards compatibility +are still supported for backwards compatibility, C<use IO::Handle> (or C<IO::Seekable> or C<IO::File>) and C<*STDOUT{IO}> are the way of the future. @@ -73,7 +89,7 @@ compiled with -DEMERGENCY_SBRK and used Perl's malloc. Then $^M = 'a' x (1<<16); -would allocate 64K buffer for use when in emergency. +would allocate a 64K buffer for use when in emergency. See the F<INSTALL> file for information on how to enable this option. As a disincentive to casual use of this advanced feature, there is no C<use English> long name for this variable. @@ -121,13 +137,13 @@ expressions of control structures such as: print $line; } - if ((my $answer = <STDIN>) =~ /^yes$/i) { + if ((my $answer = <STDIN>) =~ /^y(es)?$/i) { user_agrees(); - } elsif ($answer =~ /^no$/i) { + } elsif ($answer =~ /^n(o)?$/i) { user_disagrees(); } else { chomp $answer; - die "'$answer' is neither 'yes' nor 'no'"; + die "`$answer' is neither `yes' nor `no'"; } Also, you can declare a foreach loop control variable as lexical by @@ -156,10 +172,12 @@ which bit eight is clear. If the first argument to C<use> is a number, it is treated as a version number instead of a module name. If the version of the Perl interpreter is less than VERSION, then an error message is printed and Perl exits -immediately. This is often useful if you need to check the current -Perl version before C<use>ing library modules which have changed in -incompatible ways from older versions of Perl. (We try not to do -this more than we have to.) +immediately. Because C<use> occurs at compile time, this check happens +immediately during the compilation process, unlike C<require VERSION>, +which waits until run-time for the check. This is often useful if you +need to check the current Perl version before C<use>ing library modules +which have changed in incompatible ways from older versions of Perl. +(We try not to do this more than we have to.) =item use Module VERSION LIST @@ -187,7 +205,7 @@ function whose prototype you want to retrieve. Functions documented in the Camel to default to $_ now in fact do, and all those that do are so documented in L<perlfunc>. -=head2 C<m//g> does not trigger a pos() reset on failure +=item C<m//g> does not trigger a pos() reset on failure The C<m//g> match iteration construct used to reset the iteration when it failed to match (so that the next C<m//g> match would start at @@ -197,6 +215,27 @@ string in some way. This change makes it practical to chain C<m//g> matches together in conjunction with ordinary matches using the C<\G> zero-width assertion. See L<perlop> and L<perlre>. +=item nested C<sub{}> closures work now + +Prior to the 5.004 release, nested anonymous functions +didn't work right. They do now. + +=item formats work right on changing lexicals + +Just like anonymous functions that contain lexical variables +that change (like a lexical index variable for a C<foreach> loop), +formats now work properly. For example, this silently failed +before, and is fine now: + + my $i; + foreach $i ( 1 .. 10 ) { + format = + my i is @# + $i + . + write; + } + =back =head2 New Built-in Methods @@ -255,10 +294,21 @@ class, false if its object is the class (package) itself. Example $ref = bless [], 'A'; $ref->is_instance(); # True +This can be useful for methods that wish to easily distinguish +whether they were invoked as class or as instance methods. + + sub some_meth { + my $classname = shift; + if ($classname->is_instance()) { + die "unexpectedly called as instance not class method"; + } + ..... + } + =back B<NOTE:> C<can> directly uses Perl's internal code for method lookup, and -C<isa> uses a very similar method and cache-ing strategy. This may cause +C<isa> uses a very similar method and caching strategy. This may cause strange effects if the Perl code dynamically changes @ISA in any package. You may add other methods to the UNIVERSAL class via Perl or XS code. @@ -268,6 +318,8 @@ have C<isa> available as a plain subroutine in the current package. =head2 TIEHANDLE Now Supported +See L<perltie> for other kinds of tie()s. + =over =item TIEHANDLE classname, LIST @@ -276,7 +328,11 @@ This is the constructor for the class. That means it is expected to return an object of some sort. The reference can be used to hold some internal information. - sub TIEHANDLE { print "<shout>\n"; my $i; bless \$i, shift } + sub TIEHANDLE { + print "<shout>\n"; + my $i; + return bless \$i, shift; + } =item PRINT this, LIST @@ -284,14 +340,21 @@ This method will be triggered every time the tied handle is printed to. Beyond its self reference it also expects the list that was passed to the print function. - sub PRINT { $r = shift; $$r++; print join($,,map(uc($_),@_)),$\ } + sub PRINT { + $r = shift; + $$r++; + return print join( $, => map {uc} @_), $\; + } =item READLINE this This method will be called when the handle is read from. The method should return undef when there is no more data. - sub READLINE { $r = shift; "PRINT called $$r times\n"; } + sub READLINE { + $r = shift; + return "PRINT called $$r times\n"; + } =item DESTROY this @@ -299,10 +362,21 @@ As with the other types of ties, this method will be called when the tied handle is about to be destroyed. This is useful for debugging and possibly for cleaning up. - sub DESTROY { print "</shout>\n" } + sub DESTROY { + print "</shout>\n"; + } =back +=item Efficiency Enhancements + +All hash keys with the same string are only allocated once, so +even if you have 100 copies of the same hash, the immutable keys +never have to be re-allocated. + +Functions that have an empty prototype and that do nothing but return +a fixed value are now inlined (e.g. C<sub PI () { 3.14159 }>). + =head1 Pragmata Three new pragmatic modules exist: @@ -311,6 +385,8 @@ Three new pragmatic modules exist: =item use blib +=item use blib 'dir' + Looks for MakeMaker-like I<'blib'> directory structure starting in I<dir> (or current directory) and working back up to five levels of parent directories. @@ -344,9 +420,23 @@ Disable unsafe opcodes, or any named opcodes, when compiling Perl code. =head1 Modules +=head2 Fcntl + +New constants in the existing Fcntl modules are now supported, +provided that your operating system happens to support them: + + F_GETOWN F_SETOWN + O_ASYNC O_DEFER O_DSYNC O_FSYNC O_SYNC + O_EXLOCK O_SHLOCK + =head2 Module Information Summary -Brand new modules: +Brand new modules, arranged by topic rather than strictly +alphabetically: + + CPAN interface to Comprehensive Perl Archive Network + CPAN::FirstTime create a CPAN configuration file + CPAN::Nox run CPAN while avoiding compiled extensions IO.pm Top-level interface to IO::* classes IO/File.pm IO::File extension Perl module @@ -376,7 +466,7 @@ Brand new modules: User/grent.pm Object-oriented wrapper around CORE::getgr* User/pwent.pm Object-oriented wrapper around CORE::getpw* - lib/Tie/RefHash.pm Base class for tied hashes with references as keys + Tie/RefHash.pm Base class for tied hashes with references as keys UNIVERSAL.pm Base class for *ALL* classes @@ -430,14 +520,28 @@ For example, you can now say use User::pwent; $his = (stat($filename)->st_uid == pwent($whoever)->pw_uid); -=head1 Efficiency Enhancements +=head1 Utility Changes -All hash keys with the same string are only allocated once, so -even if you have 100 copies of the same hash, the immutable keys -never have to be re-allocated. +=head2 xsubpp -Functions that have an empty prototype and that do nothing but return -a fixed value are now inlined (e.g. C<sub PI () { 3.14159 }>). +=item C<void> XSUBs now default to returning nothing + +Due to a documentation/implementation bug in previous versions of +Perl, XSUBs with a return type of C<void> have actually been +returning one value. Usually that value was the GV for the XSUB, +but sometimes it was some already freed or reused value, which would +sometimes lead to program failure. + +In Perl 5.004, if an XSUB is declared as returning C<void>, it +actually returns no value, i.e. an empty list (though there is a +backward-compatibility exception; see below). If your XSUB really +does return an SV, you should give it a return type of C<SV *>. + +For backward compatibility, I<xsubpp> tries to guess whether a +C<void> XSUB is really C<void> or if it wants to return an C<SV *>. +It does so by examining the text of the XSUB: if I<xsubpp> finds +what looks like an assignment to C<ST(0)>, it assumes that the +XSUB's return type is really C<SV *>. =head1 Documentation Changes @@ -446,7 +550,7 @@ new pods are included in section 1: =over 4 -=item L<perlnews> +=item L<perldelta> This document. @@ -476,8 +580,17 @@ Although not new, this has been massively updated. Several new conditions will trigger warnings that were silent before. Some only affect certain platforms. -The following new warnings and errors -outline these: +The following new warnings and errors outline these. +These messages are classified as follows (listed in +increasing order of desperation): + + (W) A warning (optional). + (D) A deprecation (optional). + (S) A severe warning (mandatory). + (F) A fatal error (trappable). + (P) An internal error you should never see (trappable). + (X) A very fatal error (non-trappable). + (A) An alien error message (not generated by Perl). =over 4 @@ -489,6 +602,18 @@ a typographical error. Note that the earlier variable will still exist until the end of the scope or until all closure referents to it are destroyed. +=item %s argument is not a HASH element or slice + +(F) The argument to delete() must be either a hash element, such as + + $foo{$bar} + $ref->[12]->{"susie"} + +or a hash slice, such as + + @foo{$bar, $baz, $xyzzy} + @{$ref->[12]}{"susie", "queue"} + =item Allocation too large: %lx (X) You can't allocate more than 64K on an MSDOS machine. @@ -527,6 +652,22 @@ appear in %ENV. This may be a benign occurrence, as some software packages might directly modify logical name tables and introduce non-standard names, or it may indicate that a logical name table has been corrupted. +=item Can't use bareword ("%s") as %s ref while "strict refs" in use + +(F) Only hard references are allowed by "strict refs". Symbolic references +are disallowed. See L<perlref>. + +=item Constant subroutine %s redefined + +(S) You redefined a subroutine which had previously been eligible for +inlining. See L<perlsub/"Constant Functions"> for commentary and +workarounds. + +=item Died + +(F) You passed die() an empty string (the equivalent of C<die "">) or +you called it with no args and both C<$@> and C<$_> were empty. + =item Integer overflow in hex number (S) The literal hex number you have specified is too big for your @@ -539,6 +680,13 @@ architecture. On a 32-bit architecture the largest hex literal is architecture. On a 32-bit architecture the largest octal literal is 037777777777. +=item Name "%s::%s" used only once: possible typo + +(W) Typographical errors often show up as unique variable names. +If you had a good reason for having a unique name, then just mention +it again somehow to suppress the message (the C<use vars> pragma is +provided for just this purpose). + =item Null picture in formline (F) The first argument to formline must be a valid format picture @@ -552,6 +700,17 @@ pointing outside the buffer. This is difficult to imagine. The sole exception to this is that C<sysread()>ing past the buffer will extend the buffer and zero pad the new area. +=item Stub found while resolving method `%s' overloading `%s' in package `%s' + +(P) Overloading resolution over @ISA tree may be broken by importing stubs. +Stubs should never be implicitely created, but explicit calls to C<can> +may break this. + +=item Cannot resolve method `%s' overloading `%s' in package `s' + +(P) Internal error trying to resolve overloading specified by a method +name (as opposed to a subroutine reference). + =item Out of memory! (X|F) The malloc() function returned 0, indicating there was insufficient @@ -572,37 +731,125 @@ a possibility to shut down by trapping this error is granted. =item Possible attempt to put comments in qw() list -(W) You probably wrote something like this: +(W) qw() lists contain items separated by whitespace; as with literal +strings, comment characters are not ignored, but are instead treated +as literal data. (You may have used different delimiters than the +exclamation marks parentheses shown here; braces are also frequently +used.) + +You probably wrote something like this: - qw( a # a comment + @list = qw( + a # a comment b # another comment - ) ; + ); when you should have written this: - qw( a + @list = qw( + a b - ) ; + ); + +If you really want comments, build your list the +old-fashioned way, with quotes and commas: + + @list = ( + 'a', # a comment + 'b', # another comment + ); =item Possible attempt to separate words with commas -(W) You probably wrote something like this: +(W) qw() lists contain items separated by whitespace; therefore commas +aren't needed to separate the items. (You may have used different +delimiters than the parentheses shown here; braces are also frequently +used.) - qw( a, b, c ); +You probably wrote something like this: -when you should have written this: + qw! a, b, c !; + +which puts literal commas into some of the list items. Write it without +commas if you don't want them to appear in your data: + + qw! a b c !; - qw( a b c ); +=item Scalar value @%s{%s} better written as $%s{%s} + +(W) You've used a hash slice (indicated by @) to select a single element of +a hash. Generally it's better to ask for a scalar value (indicated by $). +The difference is that C<$foo{&bar}> always behaves like a scalar, both when +assigning to it and when evaluating its argument, while C<@foo{&bar}> behaves +like a list when you assign to it, and provides a list context to its +subscript, which can do weird things if you're expecting only one subscript. =item untie attempted while %d inner references still exist (W) A copy of the object returned from C<tie> (or C<tied>) was still valid when C<untie> was called. -=item Got an error from DosAllocMem: +=item Value of %s construct can be "0"; test with defined() + +(W) In a conditional expression, you used <HANDLE>, <*> (glob), or +C<readdir> as a boolean value. Each of these constructs can return a +value of "0"; that would make the conditional expression false, which +is probably not what you intended. When using these constructs in +conditional expressions, test their values with the C<defined> operator. + +=item Variable "%s" may be unavailable + +(W) An inner (nested) I<anonymous> subroutine is inside a I<named> +subroutine, and outside that is another subroutine; and the anonymous +(innermost) subroutine is referencing a lexical variable defined in +the outermost subroutine. For example: + + sub outermost { my $a; sub middle { sub { $a } } } + +If the anonymous subroutine is called or referenced (directly or +indirectly) from the outermost subroutine, it will share the variable +as you would expect. But if the anonymous subroutine is called or +referenced when the outermost subroutine is not active, it will see +the value of the shared variable as it was before and during the +*first* call to the outermost subroutine, which is probably not what +you want. + +In these circumstances, it is usually best to make the middle +subroutine anonymous, using the C<sub {}> syntax. Perl has specific +support for shared variables in nested anonymous subroutines; a named +subroutine in between interferes with this feature. + +=item Variable "%s" will not stay shared + +(W) An inner (nested) I<named> subroutine is referencing a lexical +variable defined in an outer subroutine. + +When the inner subroutine is called, it will probably see the value of +the outer subroutine's variable as it was before and during the +*first* call to the outer subroutine; in this case, after the first +call to the outer subroutine is complete, the inner and outer +subroutines will no longer share a common value for the variable. In +other words, the variable will no longer be shared. + +Furthermore, if the outer subroutine is anonymous and references a +lexical variable outside itself, then the outer and inner subroutines +will I<never> share the given variable. + +This problem can usually be solved by making the inner subroutine +anonymous, using the C<sub {}> syntax. When inner anonymous subs that +reference variables in outer subroutines are called or referenced, +they are automatically re-bound to the current values of such +variables. + +=item Warning: something's wrong + +(W) You passed warn() an empty string (the equivalent of C<warn "">) or +you called it with no args and C<$_> was empty. + +=item Got an error from DosAllocMem -(P) An error peculiar to OS/2. Most probably you use an obsolete version -of Perl, and should not happen anyway. +(P) An error peculiar to OS/2. Most probably you're using an obsolete +version of Perl, and this should not happen anyway. =item Malformed PERLLIB_PREFIX @@ -634,10 +881,10 @@ L<perlipc/"Signals">. See L<perlos2/"Process terminated by SIGTERM/SIGINT">. =head1 BUGS -If you find what you think is a bug, you might check the headers -of recently posted articles -in the comp.lang.perl.misc newsgroup. There may also be -information at http://www.perl.com/perl/, the Perl Home Page. +If you find what you think is a bug, you might check the headers of +recently posted articles in the comp.lang.perl.misc newsgroup. +There may also be information at http://www.perl.com/perl/, the Perl +Home Page. If you believe you have an unreported bug, please run the B<perlbug> program included with your release. Make sure you trim your bug diff --git a/pod/perldiag.pod b/pod/perldiag.pod index d08d2dc452..0f204a868a 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -799,6 +799,12 @@ Perhaps you need to copy the value to a temporary, and repeat that. (F) The create routine failed for some reason while trying to process a B<-e> switch. Maybe your /tmp partition is full, or clobbered. +=item Cannot resolve method `%s' overloading `%s' in package `%s' + +(F|P) Error resolving overloading specified by a method name (as +opposed to a subroutine reference): no such method callable via the +package. If method name is C<???>, this is an internal error. + =item chmod: mode argument is missing initial 0 (W) A novice will sometimes say @@ -823,6 +829,10 @@ the return value of your socket() call? See L<perlfunc/connect>. inlining. See L<perlsub/"Constant Functions"> for commentary and workarounds. +=item Copy method did not return a reference + +(F) The method which overloads "=" is buggy. See L<overload/Copy Constructor>. + =item Corrupt malloc ptr 0x%lx at 0x%lx (P) The malloc package that comes with Perl had an internal failure. @@ -1177,7 +1187,7 @@ assume that an unbackslashed @ interpolates an array.) =item Method for operation %s not found in package %s during blessing (F) An attempt was made to specify an entry in an overloading table that -doesn't somehow point to a valid method. See L<overload>. +doesn't resolve to a valid subroutine. See L<overload>. =item Might be a runaway multi-line %s string starting on line %d @@ -1420,7 +1430,7 @@ subroutine), but found a reference to something else instead. You can use the ref() function to find out what kind of ref it really was. See also L<perlref>. -=item Not a subroutine reference in %OVERLOAD +=item Not a subroutine reference in overload table (F) An attempt was made to specify an entry in an overloading table that doesn't somehow point to a valid subroutine. See L<overload>. @@ -1487,21 +1497,13 @@ will extend the buffer and zero pad the new area. (S) An internal warning that the grammar is screwed up. -=item Operation `%s' %s: no method found, - -(F) An attempt was made to use an entry in an overloading table that -somehow no longer points to a valid method. See L<overload>. - -=item Stub found while resolving method `%s' overloading `%s' in package `%s' - -(P) Overloading resolution over @ISA tree may be broken by importing stubs. -Stubs should never be implicitely created, but explicit calls to C<can> -may break this. - -=item Cannot resolve method `%s' overloading `%s' in package `s' +=item Operation `%s': no method found,%s -(P) Internal error trying to resolve overloading specified by a method -name (as opposed to a subroutine reference). +(F) An attempt was made to perform an overloaded operation for which +no handler was defined. While some handlers can be autogenerated in +terms of other handlers, there is no default handler for any +operation, unless C<fallback> overloading key is specified to be +true. See L<overload>. =item Operator or semicolon missing before %s @@ -1714,27 +1716,49 @@ the BSD version, which takes a pid. =item Possible attempt to put comments in qw() list -(W) You probably wrote something like this: +(W) qw() lists contain items separated by whitespace; as with literal +strings, comment characters are not ignored, but are instead treated +as literal data. (You may have used different delimiters than the +exclamation marks parentheses shown here; braces are also frequently +used.) - qw( a # a comment +You probably wrote something like this: + + @list = qw( + a # a comment b # another comment - ) ; + ); when you should have written this: - qw( a + @list = qw( + a b - ) ; + ); + +If you really want comments, build your list the +old-fashioned way, with quotes and commas: + + @list = ( + 'a', # a comment + 'b', # another comment + ); =item Possible attempt to separate words with commas -(W) You probably wrote something like this: +(W) qw() lists contain items separated by whitespace; therefore commas +aren't needed to separate the items. (You may have used different +delimiters than the parentheses shown here; braces are also frequently +used.) - qw( a, b, c ); +You probably wrote something like this: -when you should have written this: + qw! a, b, c !; + +which puts literal commas into some of the list items. Write it without +commas if you don't want them to appear in your data: - qw( a b c ); + qw! a b c !; =item Possible memory corruption: %s overflowed 3rd argument @@ -2002,6 +2026,12 @@ there was a failure. You probably wanted to use system() instead, which does return. To suppress this warning, put the exec() in a block by itself. +=item Stub found while resolving method `%s' overloading `%s' in package `%s' + +(P) Overloading resolution over @ISA tree may be broken by importation stubs. +Stubs should never be implicitely created, but explicit calls to C<can> +may break this. + =item Subroutine %s redefined (W) You redefined a subroutine. To suppress this warning, say @@ -2558,10 +2588,10 @@ streams, such as } close OUT; -=item Got an error from DosAllocMem: +=item Got an error from DosAllocMem -(P) An error peculiar to OS/2. Most probably you use an obsolete version -of perl, and this should not happen anyway. +(P) An error peculiar to OS/2. Most probably you're using an obsolete +version of Perl, and this should not happen anyway. =item Malformed PERLLIB_PREFIX diff --git a/pod/perlembed.pod b/pod/perlembed.pod index e55ee633c9..2a9ce58f30 100644 --- a/pod/perlembed.pod +++ b/pod/perlembed.pod @@ -930,7 +930,8 @@ B<ExtUtils::Embed> can also automate writing the I<xs_init> glue code. % perl -MExtUtils::Embed -e xsinit -o perlxsi.c % cc -c perlxsi.c `perl -MExtUtils::Embed -e ccopts` % cc -c interp.c `perl -MExtUtils::Embed -e ccopts` - % cc -o interp perlxsi.o interp.o `perl -MExtUtils::Embed -e ldopts` + % cc -o interp perlxsi.o interp.o \ + `perl -MExtUtils::Embed -e ccdlflags -e ldopts` Consult L<perlxs> and L<perlguts> for more details. diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 488c797c65..99231b9ffd 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -408,8 +408,17 @@ With EXPR, it returns some extra information that the debugger uses to print a stack trace. The value of EXPR indicates how many call frames to go back before the current one. - ($package, $filename, $line, - $subroutine, $hasargs, $wantarray) = caller($i); + ($package, $filename, $line, $subroutine, + $hasargs, $wantarray, $evaltext, $is_require) = caller($i); + +Here $subroutine may be C<"(eval)"> if the frame is not a subroutine +call, but C<L<eval>>. In such a case additional elements $evaltext and +$is_require are set: $is_require is true if the frame is created by +C<L<require>> or C<L<use>> statement, $evaltext contains the text of +C<L<eval EXPR>> statement. In particular, for C<L<eval BLOCK>> +statement $filename is C<"(eval)">, but $evaltext is undefined. (Note +also that C<L<use>> statement creates a C<L<require>> frame inside +an C<L<eval EXPR>>) frame. Furthermore, when called from within the DB package, caller returns more detailed information: it sets the list variable @DB::args to be the @@ -774,6 +783,12 @@ produce, respectively See also exit() and warn(). +You can arrange for a callback to be called just before the die() does +its deed, by setting the C<$SIG{__DIE__}> hook. The associated handler +will be called with the error text and can change the error message, if +it sees fit, by calling die() again. See L<perlvar> for details on +setting C<%SIG> entries, and eval() for some examples. + =item do BLOCK Not really a function. Returns the value of the last command in the @@ -919,8 +934,11 @@ context of the eval. If there is a syntax error or runtime error, or a die() statement is executed, an undefined value is returned by eval(), and C<$@> is set to the error message. If there was no error, C<$@> is guaranteed to be a null -string. If EXPR is omitted, evaluates $_. The final semicolon, if -any, may be omitted from the expression. +string. If EXPR is omitted, evaluates C<$_>. The final semicolon, if +any, may be omitted from the expression. Beware that using eval() +neither silences perl from printing warnings to STDERR, nor does it +stuff the text of warning messages into C<$@>. To do either of those, +you have to use the C<$SIG{__WARN__}> facility. See warn() and L<perlvar>. Note that, because eval() traps otherwise-fatal errors, it is useful for determining whether a particular feature (such as socket() or symlink()) @@ -944,6 +962,24 @@ Examples: # a run-time error eval '$answer ='; # sets $@ +When using the eval{} form as an exception trap in libraries, you may +wish not to trigger any C<__DIE__> hooks that user code may have +installed. You can use the C<local $SIG{__DIE__}> construct for this +purpose, as shown in this example: + + # a very private exception trap for divide-by-zero + eval { local $SIG{'__DIE__'}; $answer = $a / $b; }; warn $@ if $@; + +This is especially significant, given that C<__DIE__> hooks can call +die() again, which has the effect of changing their error messages: + + # __DIE__ hooks may modify error messages + { + local $SIG{'__DIE__'} = sub { (my $x = $_[0]) =~ s/foo/bar/g; die $x }; + eval { die "foo foofs here" }; + print $@ if $@; # prints "bar barfs here" + } + With an eval(), you should be especially careful to remember what's being looked at when: @@ -3045,7 +3081,7 @@ meaning of the fields: size total size of file, in bytes atime last access time since the epoch mtime last modify time since the epoch - ctime inode change time (NOT creation type!) since the epoch + ctime inode change time (NOT creation time!) since the epoch blksize preferred block size for file system I/O blocks actual number of blocks allocated @@ -3640,8 +3676,38 @@ for a scalar. =item warn LIST -Produces a message on STDERR just like die(), but doesn't exit or -on an exception. +Produces a message on STDERR just like die(), but doesn't exit or throw +an exception. + +No message is printed if there is a C<$SIG{__WARN__}> handler +installed. It is the handler's responsibility to deal with the message +as it sees fit (like, for instance, converting it into a die()). Most +handlers must therefore make arrangements to actually display the +warnings that they are not prepared to deal with, by calling warn() +again in the handler. Note that this is quite safe and will not +produce an endless loop, since C<__WARN__> hooks are not called from +inside one. + +You will find this behavior is slightly different from that of +C<$SIG{__DIE__}> handlers (which don't suppress the error text, but can +instead call die() again to change it). + +Using a C<__WARN__> handler provides a powerful way to silence all +warnings (even the so-called mandatory ones). An example: + + # wipe out *all* compile-time warnings + BEGIN { $SIG{'__WARN__'} = sub { warn $_[0] if $DOWARN } } + my $foo = 10; + my $foo = 20; # no warning about duplicate my $foo, + # but hey, you asked for it! + # no compile-time or run-time warnings before here + $DOWARN = 1; + + # run-time warnings enabled after here + warn "\$foo is alive and $foo!"; # does show up + +See L<perlvar> for details on setting C<%SIG> entries, and for more +examples. =item write FILEHANDLE diff --git a/pod/perlop.pod b/pod/perlop.pod index dd3aeab663..55108f0328 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -737,6 +737,32 @@ The last example should print: Note how C<m//g> matches change the value reported by C<pos()>, but the non-global match doesn't. +A useful idiom for C<lex>-like scanners is C</\G.../g>. You can +combine several regexps like this to process a string part-by-part, +doing different actions depending on which regexp matched. The next +regexp would step in at the place the previous one left off. + + $_ = <<'EOL'; + $url = new URI::URL "http://www/"; die if $url eq "xXx"; +EOL + LOOP: + { + print(" digits"), redo LOOP if /\G\d+\b[,.;]?\s*/g; + print(" lowercase"), redo LOOP if /\G[a-z]+\b[,.;]?\s*/g; + print(" UPPERCASE"), redo LOOP if /\G[A-Z]+\b[,.;]?\s*/g; + print(" Capitalized"), redo LOOP if /\G[A-Z][a-z]+\b[,.;]?\s*/g; + print(" MiXeD"), redo LOOP if /\G[A-Za-z]+\b[,.;]?\s*/g; + print(" alphanumeric"), redo LOOP if /\G[A-Za-z0-9]+\b[,.;]?\s*/g; + print(" line-noise"), redo LOOP if /\G[^A-Za-z0-9]+/g; + print ". That's all!\n"; + } + +Here is the output (split into several lines): + + line-noise lowercase line-noise lowercase UPPERCASE line-noise + UPPERCASE line-noise lowercase line-noise lowercase line-noise + lowercase lowercase line-noise lowercase lowercase line-noise + MiXeD line-noise. That's all! =item q/STRING/ diff --git a/pod/perlre.pod b/pod/perlre.pod index a4c0a7d9de..cb3ce032d0 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -175,7 +175,11 @@ just like "^" and "$" except that they won't match multiple times when the C</m> modifier is used, while "^" and "$" will match at every internal line boundary. To match the actual end of the string, not ignoring newline, you can use C<\Z(?!\n)>. The C<\G> assertion can be used to mix global -matches (using C<m//g>) and non-global ones, as described in L<perlop>. +matches (using C<m//g>) and non-global ones, as described in +L<perlop/"Regexp Quote-Like Operators">. +It is also useful when writing C<lex>-like scanners, when you have several +regexps which you want to match against consequent substrings of your +string, see the previous reference. The actual location where C<\G> will match can also be influenced by using C<pos()> as an lvalue. See L<perlfunc/pos>. diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 083b567e19..da355c17be 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -420,10 +420,12 @@ prints warnings about variable names that are mentioned only once, and scalar variables that are used before being set. Also warns about redefined subroutines, and references to undefined filehandles or filehandles opened read-only that you are attempting to write on. Also -warns you if you use values as a number that doesn't look like numbers, using -an array as though it were a scalar, if -your subroutines recurse more than 100 deep, and innumerable other things. -See L<perldiag> and L<perltrap>. +warns you if you use values as a number that doesn't look like numbers, +using an array as though it were a scalar, if your subroutines recurse +more than 100 deep, and innumerable other things. + +You can disable specific warnings using C<__WARN__> hooks, as described +in L<perlvar> and L<perlfunc/warn>. See also L<perldiag> and L<perltrap>. =item B<-x> I<directory> diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod index 91a601aebb..8bb557e7f5 100644 --- a/pod/perlsyn.pod +++ b/pod/perlsyn.pod @@ -508,3 +508,47 @@ ignored by both the compiler and the translators. You probably shouldn't rely upon the warn() being podded out forever. Not all pod translators are well-behaved in this regard, and perhaps the compiler will become pickier. + +One may also use pod directives to quickly comment out a section +of code. + +=head2 Plain Old Comments (Not!) + +Much like the C preprocessor, perl can process line directives. Using +this, one can control perl's idea of filenames and line numbers in +error or warning messages (especially for strings that are processed +with eval()). The syntax for this mechanism is the same as for most +C preprocessors: it matches the regular expression +C</^#\s*line\s+(\d+)\s*(?:\s"([^"])*")?/> with C<$1> being the line +number for the next line, and C<$2> being the optional filename +(specified within quotes). + +Here are some examples that you should be able to type into your command +shell: + + % perl + # line 200 "bzzzt" + # the `#' on the previous line must be the first char on line + die 'foo'; + __END__ + foo at bzzzt line 201. + + % perl + # line 200 "bzzzt" + eval qq[\n#line 2001 ""\ndie 'foo']; print $@; + __END__ + foo at - line 2001. + + % perl + eval qq[\n#line 200 "foo bar"\ndie 'foo']; print $@; + __END__ + foo at foo bar line 200. + + % perl + # line 345 "goop" + eval "\n#line " . __LINE__ . ' "' . __FILE__ ."\"\ndie 'foo'"; + print $@; + __END__ + foo at goop line 345. + +=cut diff --git a/pod/perltoc.pod b/pod/perltoc.pod index b8353fcdb1..f451606df5 100644 --- a/pod/perltoc.pod +++ b/pod/perltoc.pod @@ -40,7 +40,7 @@ HOME, LOGDIR, PATH, PERL5LIB, PERL5DB, PERL_DESTRUCT_LEVEL, PERLLIB =item NOTES -=head2 perlnews - what's new for perl5.004 +=head2 perldelta - what's new for perl5.004 =item DESCRIPTION @@ -54,6 +54,8 @@ HOME, LOGDIR, PATH, PERL5LIB, PERL5DB, PERL_DESTRUCT_LEVEL, PERLLIB =item New Opcode Module and Revised Safe Module +=item Extended Fcntl Module + =item Internal Change: FileHandle Deprecated =item Internal Change: PerlIO internal IO abstraction interface @@ -66,9 +68,9 @@ $^E, $^H, $^M delete on slices, flock, keys as an lvalue, my() in Control Structures, unpack() and pack(), use VERSION, use Module VERSION LIST, -prototype(FUNCTION), $_ as Default - -=item C<m//g> does not trigger a pos() reset on failure +prototype(FUNCTION), $_ as Default, C<m//g> does not trigger a pos() reset +on failure, nested C<sub{}> closures work now, formats work right on +changing lexicals =item New Built-in Methods @@ -76,18 +78,21 @@ isa(CLASS), can(METHOD), VERSION( [NEED] ), class(), is_instance() =item TIEHANDLE Now Supported -TIEHANDLE classname, LIST, PRINT this, LIST, READLINE this, DESTROY this +TIEHANDLE classname, LIST, PRINT this, LIST, READLINE this, DESTROY this, +Efficiency Enhancements =back =item Pragmata -use blib, use locale, use ops +use blib, use blib 'dir', use locale, use ops =item Modules =over +=item Fcntl + =item Module Information Summary =item IO @@ -98,25 +103,40 @@ use blib, use locale, use ops =back -=item Efficiency Enhancements +=item Utility Changes + +=over + +=item xsubpp + +C<void> XSUBs now default to returning nothing + +=back =item Documentation Changes -L<perlnews>, L<perllocale>, L<perltoot>, L<perlapio>, L<perldebug>, +L<perldelta>, L<perllocale>, L<perltoot>, L<perlapio>, L<perldebug>, L<perlsec> =item New Diagnostics -"my" variable %s masks earlier declaration in same scope, Allocation too -large: %lx, Allocation too large, Attempt to free non-existent shared -string, Attempt to use reference as lvalue in substr, Unsupported function -fork, Ill-formed logical name |%s| in prime_env_iter, Integer overflow in -hex number, Integer overflow in octal number, Null picture in formline, -Offset outside string, Out of memory!, Out of memory during request for %s, -Possible attempt to put comments in qw() list, Possible attempt to separate -words with commas, untie attempted while %d inner references still exist, -Got an error from DosAllocMem:, Malformed PERLLIB_PREFIX, PERL_SH_DIR too -long, Process terminated by SIG%s +"my" variable %s masks earlier declaration in same scope, %s argument is +not a HASH element or slice, Allocation too large: %lx, Allocation too +large, Attempt to free non-existent shared string, Attempt to use reference +as lvalue in substr, Unsupported function fork, Ill-formed logical name +|%s| in prime_env_iter, Can't use bareword ("%s") as %s ref while "strict +refs" in use, Constant subroutine %s redefined, Died, Integer overflow in +hex number, Integer overflow in octal number, Name "%s::%s" used only once: +possible typo, Null picture in formline, Offset outside string, Stub found +while resolving method `%s' overloading `%s' in package `%s', Cannot +resolve method `%s' overloading `%s' in package `s', Out of memory!, Out of +memory during request for %s, Possible attempt to put comments in qw() +list, Possible attempt to separate words with commas, Scalar value @%s{%s} +better written as $%s{%s}, untie attempted while %d inner references still +exist, Value of %s construct can be "0"; test with defined(), Variable "%s" +may be unavailable, Variable "%s" will not stay shared, Warning: +something's wrong, Got an error from DosAllocMem, Malformed PERLLIB_PREFIX, +PERL_SH_DIR too long, Process terminated by SIG%s =item BUGS @@ -168,6 +188,8 @@ long, Process terminated by SIG%s =item PODs: Embedded Documentation +=item Plain Old Comments (Not!) + =back =head2 perlop - Perl operators and precedence @@ -1007,19 +1029,27 @@ safe subprocesses, sockets, and semaphores) =item Debugger Commands -h [command], p expr, x expr, V [pkg [vars]], X [vars], T, s [expr], n, -E<lt>CRE<gt>, c [line|sub], l, l min+incr, l min-max, l line, l subname, -, -w [line], f filename, /pattern/, ?pattern?, L, S [[!]pattern], t, t expr, b -[line] [condition], b subname [condition], b postpone subname [condition], -b load filename, d [line], D, a [line] command, A, O [opt[=val]] [opt"val"] -[opt?].., recallCommand, ShellBang, pager, tkRunning, signalLevel, -warnLevel, dieLevel, AutoTrace, LineInfo, C<inhibit_exit>, C<PrintRet>, -C<frame>, arrayDepth, hashDepth, compactDump, veryCompact, globPrint, -DumpDBFiles, DumpPackages, quote, HighBit, undefPrint, C<TTY>, noTTY, -C<noTTY>, C<ReadLine>, C<NonStop>, E<lt> [ command ], E<lt>E<lt> command, -E<gt> command, E<gt>E<gt> command, { [ command ], {{ command, ! number, ! --number, ! pattern, !! cmd, H -number, q or ^D, R, |dbcmd, ||dbcmd, = -[alias value], command, p expr +h [command], p expr, x expr, V [pkg [vars]], X [vars], T, s [expr], n +[expr], E<lt>CRE<gt>, c [line|sub], l, l min+incr, l min-max, l line, l +subname, -, w [line], f filename, /pattern/, ?pattern?, L, S [[!]pattern], +t, t expr, b [line] [condition], b subname [condition], b postpone subname +[condition], b load filename, b compile subname, d [line], D, a [line] +command, A, O [opt[=val]] [opt"val"] [opt?].., C<recallCommand>, +C<ShellBang>, C<pager>, C<tkRunning>, C<signalLevel>, C<warnLevel>, +C<dieLevel>, C<AutoTrace>, C<LineInfo>, C<inhibit_exit>, C<PrintRet>, +C<frame>, C<maxTraceLen>, C<arrayDepth>, C<hashDepth>, C<compactDump>, +C<veryCompact>, C<globPrint>, C<DumpDBFiles>, C<DumpPackages>, C<quote>, +C<HighBit>, C<undefPrint>, C<UsageOnly>, C<TTY>, C<noTTY>, C<ReadLine>, +C<NonStop>, E<lt> [ command ], E<lt>E<lt> command, E<gt> command, +E<gt>E<gt> command, { [ command ], {{ command, ! number, ! -number, ! +pattern, !! cmd, H -number, q or ^D, R, |dbcmd, ||dbcmd, = [alias value], +command, m expr, m package + +=item Debugger input/output + +Prompt, Multi-line commands, Stack backtrace, Listing, Frame listing + +=item Debugging compile-time statements =item Debugger Customization @@ -1422,7 +1452,7 @@ av_shift, av_store, av_undef, av_unshift, CLASS, Copy, croak, CvSTASH, DBsingle, DBsub, DBtrace, dMARK, dORIGMARK, dowarn, dSP, dXSARGS, dXSI32, dXSI32, ENTER, EXTEND, FREETMPS, G_ARRAY, G_DISCARD, G_EVAL, GIMME, G_NOARGS, G_SCALAR, gv_fetchmeth, gv_fetchmethod, gv_stashpv, gv_stashsv, -he_free, he_delayfree, hv_clear, hv_delete, hv_exists, hv_fetch, +GvSV, he_delayfree, he_free, hv_clear, hv_delete, hv_exists, hv_fetch, hv_iterinit, hv_iterkey, hv_iternext, hv_iternextsv, hv_iterval, hv_magic, HvNAME, hv_store, hv_undef, isALNUM, isALPHA, isDIGIT, isLOWER, isSPACE, isUPPER, items, ix, LEAVE, MARK, mg_clear, mg_copy, mg_find, mg_free, @@ -1643,13 +1673,18 @@ I<Arithmetic operations>, I<Comparison operations>, I<Bit operations>, I<Increment and decrement>, I<Transcendental functions>, I<Boolean, string and numeric conversion>, I<Special> +=item Inheritance and overloading + +Strings as values of C<use overload> directive, Overloading of an operation +is inherited by derived classes + =back =item SPECIAL SYMBOLS FOR C<use overload> =over -=item Last Resort +=item Last Resort =item Fallback @@ -1818,19 +1853,26 @@ timeit(COUNT, CODE), timethis, timethese, timediff, timestr =item Interactive Mode Searching for authors, bundles, distribution files and modules, make, test, -install, clean modules or distributions +install, clean modules or distributions, readme, look module or +distribution =item CPAN::Shell +=item autobundle + +=item recompile + =item ProgrammerE<39>s interface =item Cache Manager =item Bundles -=item autobundle +=item Prerequisites -=item recompile +=item Debugging + +=item Floppy, Zip, and all that Jazz =back @@ -1845,13 +1887,7 @@ E<lt>listE<gt> =item EXPORT -=item Debugging - -=over - -=item Prerequisites - -=back +=item BUGS =item AUTHOR @@ -2028,9 +2064,11 @@ $value, $flags) ;>, B<$status = $X-E<gt>sync([$flags]) ;> =item DESCRIPTION -@dl_library_path, @dl_resolve_using, @dl_require_symbols, dl_error(), -$dl_debug, dl_findfile(), dl_expandspec(), dl_load_file(), -dl_find_symbol(), dl_undef_symbols(), dl_install_xsub(), bootstrap() +@dl_library_path, @dl_resolve_using, @dl_require_symbols, @dl_librefs, +@dl_modules, dl_error(), $dl_debug, dl_findfile(), dl_expandspec(), +dl_load_file(), dl_loadflags(), dl_find_symbol(), +dl_find_symbol_anywhere(), dl_undef_symbols(), dl_install_xsub(), +bootstrap() =item AUTHOR diff --git a/pod/perlvar.pod b/pod/perlvar.pod index de9bd22348..248c378614 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -729,7 +729,8 @@ is about to be thrown. The error message is passed as the first argument. When a __DIE__ hook routine returns, the exception processing continues as it would have in the absence of the hook, unless the hook routine itself exits via a C<goto>, a loop exit, or a die(). -The __DIE__ handler is explicitly disabled during the call, so that you -can die from a __DIE__ handler. Similarly for __WARN__. +The C<__DIE__> handler is explicitly disabled during the call, so that you +can die from a C<__DIE__> handler. Similarly for C<__WARN__>. See +L<perlfunc/die>, L<perlfunc/warn> and L<perlfunc/eval>. =back diff --git a/pod/perlxs.pod b/pod/perlxs.pod index 26418b51a9..35d74e9eed 100644 --- a/pod/perlxs.pod +++ b/pod/perlxs.pod @@ -167,7 +167,21 @@ be received by Perl as the return value of the XSUB. If the XSUB has a return type of C<void> then the compiler will not supply a RETVAL variable for that function. When using -the PPCODE: directive the RETVAL variable may not be needed. +the PPCODE: directive the RETVAL variable is not needed, unless used +explicitly. + +If PPCODE: directive is not used, C<void> return value should be used +only for subroutines which do not return a value, I<even if> CODE: +directive is used which sets ST(0) explicitly. + +Older versions of this document recommended to use C<void> return +value in such cases. It was discovered that this could lead to +segfaults in cases when XSUB was I<truely> C<void>. This practice is +now deprecated, and may be not supported at some future version. Use +the return value C<SV *> in such cases. (Currently C<xsubpp> contains +some heuristic code which tries to disambiguate between "truely-void" +and "old-practice-declared-as-void" functions. Hence your code is at +mercy of this heuristics unless you use C<SV *> as return value.) =head2 The MODULE Keyword @@ -570,13 +584,13 @@ of $timep will either be undef or it will be a valid time. $timep = rpcb_gettime( "localhost" ); -The following XSUB uses the C<void> return type to disable the generation of -the RETVAL variable and uses a CODE: block to indicate to the compiler +The following XSUB uses the C<SV *> return type as a mneumonic only, +and uses a CODE: block to indicate to the compiler that the programmer has supplied all the necessary code. The sv_newmortal() call will initialize the return value to undef, making that the default return value. - void + SV * rpcb_gettime(host) char * host PREINIT: @@ -590,7 +604,7 @@ the default return value. The next example demonstrates how one would place an explicit undef in the return value, should the need arise. - void + SV * rpcb_gettime(host) char * host PREINIT: @@ -1102,7 +1116,7 @@ File C<RPC.xs>: Interface to some ONC+ RPC bind library functions. MODULE = RPC PACKAGE = RPC - void + SV * rpcb_gettime(host="localhost") char *host PREINIT: diff --git a/pod/pod2html.PL b/pod/pod2html.PL index 816fb6ba4c..602a866e42 100644 --- a/pod/pod2html.PL +++ b/pod/pod2html.PL @@ -14,6 +14,7 @@ use File::Basename qw(&basename &dirname); # This is so that make depend always knows where to find PL derivatives. chdir dirname($0); $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; @@ -502,7 +503,7 @@ sub gensym { sub pre_escapes { # twiddle these, and stay up late :-) my($thing) = @_; for ($$thing) { - s/([\200-\377])/noremap("&".ord($1).";")/ge; + s/([\200-\377])/noremap("&#".ord($1).";")/ge; s/"(.*?)"/``$1''/gs; s/&/noremap("&")/ge; s/<</noremap("<<")/eg; diff --git a/pod/pod2latex.PL b/pod/pod2latex.PL index 9702614ffa..3d0b55b32f 100644 --- a/pod/pod2latex.PL +++ b/pod/pod2latex.PL @@ -14,6 +14,7 @@ use File::Basename qw(&basename &dirname); # This is so that make depend always knows where to find PL derivatives. chdir dirname($0); $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; diff --git a/pod/pod2man.PL b/pod/pod2man.PL index 5d1e193a34..c03e73db26 100644 --- a/pod/pod2man.PL +++ b/pod/pod2man.PL @@ -14,6 +14,7 @@ use File::Basename qw(&basename &dirname); # This is so that make depend always knows where to find PL derivatives. chdir dirname($0); $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; diff --git a/pod/pod2text.PL b/pod/pod2text.PL index 586da04e0f..da645b554e 100644 --- a/pod/pod2text.PL +++ b/pod/pod2text.PL @@ -14,6 +14,7 @@ use File::Basename qw(&basename &dirname); # This is so that make depend always knows where to find PL derivatives. chdir dirname($0); $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; diff --git a/pod/roffitall b/pod/roffitall index 7e33326ca7..06b39188f2 100755 --- a/pod/roffitall +++ b/pod/roffitall @@ -30,7 +30,7 @@ esac toroff=` echo \ $mandir/perl.1 \ - $mandir/perlnews.1 \ + $mandir/perldelta.1 \ $mandir/perldata.1 \ $mandir/perlsyn.1 \ $mandir/perlop.1 \ @@ -519,8 +519,10 @@ PP(pp_undef) dSP; SV *sv; - if (!op->op_private) + if (!op->op_private) { + EXTEND(SP, 1); RETPUSHUNDEF; + } sv = POPs; if (!sv) @@ -1393,15 +1395,28 @@ PP(pp_sqrt) PP(pp_int) { dSP; dTARGET; - double value; - value = POPn; - if (value >= 0.0) - (void)modf(value, &value); - else { - (void)modf(-value, &value); - value = -value; + { + double value = TOPn; + IV iv; + + if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) { + iv = SvIVX(TOPs); + SETi(iv); + } + else { + if (value >= 0.0) + (void)modf(value, &value); + else { + (void)modf(-value, &value); + value = -value; + } + iv = I_V(value); + if (iv == value) + SETi(iv); + else + SETn(value); + } } - XPUSHn(value); RETURN; } @@ -1409,15 +1424,22 @@ PP(pp_abs) { dSP; dTARGET; tryAMAGICun(abs); { - double value; - value = POPn; - - if (value < 0.0) - value = -value; - - XPUSHn(value); - RETURN; + double value = TOPn; + IV iv; + + if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) && + (iv = SvIVX(TOPs)) != IV_MIN) { + if (iv < 0) + iv = -iv; + SETi(iv); + } + else { + if (value < 0.0) + value = -value; + SETn(value); + } } + RETURN; } PP(pp_hex) @@ -612,6 +612,7 @@ PP(pp_aassign) magic = SvMAGICAL(ary) != 0; av_clear(ary); + av_extend(ary, lastrelem - relem); i = 0; while (relem <= lastrelem) { /* gobble up all the rest */ sv = NEWSV(28,0); @@ -1677,12 +1678,6 @@ PP(pp_leavesub) /* in case LEAVE wipes old return values */ } - if (cx->blk_sub.hasargs) { /* You don't exist; go away. */ - AV* av = cx->blk_sub.argarray; - - av_clear(av); - AvREAL_off(av); - } curpm = newpm; /* Don't pop $1 et al till now */ LEAVE; @@ -420,7 +420,7 @@ char* sharepvn _((char* sv, I32 len, U32 hash)); HEK* share_hek _((char* sv, I32 len, U32 hash)); Signal_t sighandler _((int sig)); SV** stack_grow _((SV** sp, SV**p, int n)); -int start_subparse _((U32 flags)); +int start_subparse _((I32 is_format, U32 flags)); void sub_crush_depth _((CV* cv)); bool sv_2bool _((SV* sv)); CV* sv_2cv _((SV* sv, HV** st, GV** gvp, I32 lref)); @@ -228,18 +228,23 @@ PMOP* pm; regkind[(U8)OP(first)] == NBOUND) r->regstclass = first; else if (regkind[(U8)OP(first)] == BOL) { - r->reganch = ROPT_ANCH; + r->reganch |= ROPT_ANCH_BOL; first = NEXTOPER(first); - goto again; + goto again; + } + else if (OP(first) == GPOS) { + r->reganch |= ROPT_ANCH_GPOS; + first = NEXTOPER(first); + goto again; } else if ((OP(first) == STAR && regkind[(U8)OP(NEXTOPER(first))] == ANY) && !(r->reganch & ROPT_ANCH) ) { /* turn .* into ^.* with an implied $*=1 */ - r->reganch = ROPT_ANCH | ROPT_IMPLICIT; + r->reganch |= ROPT_ANCH_BOL | ROPT_IMPLICIT; first = NEXTOPER(first); - goto again; + goto again; } if (sawplus && (!sawopen || !regsawback)) r->reganch |= ROPT_SKIP; /* x+ must match 1st of run */ @@ -783,7 +788,7 @@ tryagain: nextchar(); break; case 'G': - ret = regnode(GBOL); + ret = regnode(GPOS); *flagp |= SIMPLE; nextchar(); break; @@ -1499,8 +1504,14 @@ regexp *r; PerlIO_printf(Perl_debug_log, "start `%s' ", SvPVX(r->regstart)); if (r->regstclass) PerlIO_printf(Perl_debug_log, "stclass `%s' ", regprop(r->regstclass)); - if (r->reganch & ROPT_ANCH) - PerlIO_printf(Perl_debug_log, "anchored "); + if (r->reganch & ROPT_ANCH) { + PerlIO_printf(Perl_debug_log, "anchored"); + if (r->reganch & ROPT_ANCH_BOL) + PerlIO_printf(Perl_debug_log, "(BOL)"); + if (r->reganch & ROPT_ANCH_GPOS) + PerlIO_printf(Perl_debug_log, "(GPOS)"); + PerlIO_putc(Perl_debug_log, ' '); + } if (r->reganch & ROPT_SKIP) PerlIO_printf(Perl_debug_log, "plus "); if (r->reganch & ROPT_IMPLICIT) @@ -1613,8 +1624,8 @@ char *op; case MINMOD: p = "MINMOD"; break; - case GBOL: - p = "GBOL"; + case GPOS: + p = "GPOS"; break; case UNLESSM: p = "UNLESSM"; @@ -76,7 +76,7 @@ #define OPEN 25 /* num Mark this point in input as start of #n. */ #define CLOSE 26 /* num Analogous to OPEN. */ #define MINMOD 27 /* no Next operator is not greedy. */ -#define GBOL 28 /* no Matches where last m//g left off. */ +#define GPOS 28 /* no Matches where last m//g left off. */ #define IFMATCH 29 /* no Succeeds if the following matches. */ #define UNLESSM 30 /* no Fails if the following matches. */ #define SUCCEED 31 /* no Return from a subroutine, basically. */ @@ -158,7 +158,7 @@ EXT char regkind[] = { OPEN, CLOSE, MINMOD, - BOL, + GPOS, BRANCH, BRANCH, END, @@ -207,7 +207,8 @@ I32 safebase; /* no need to remember string in subbase */ /* If there is a "must appear" string, look for it. */ s = startpos; if (prog->regmust != Nullsv && - (!(prog->reganch & ROPT_ANCH) + !(prog->reganch & ROPT_ANCH_GPOS) && + (!(prog->reganch & ROPT_ANCH_BOL) || (multiline && prog->regback >= 0)) ) { if (stringarg == strbeg && screamer) { @@ -250,11 +251,13 @@ I32 safebase; /* no need to remember string in subbase */ regtill = startpos+minend; /* Simplest case: anchored match need be tried only once. */ - /* [unless multiline is set] */ + /* [unless only anchor is BOL and multiline is set] */ if (prog->reganch & ROPT_ANCH) { if (regtry(prog, startpos)) goto got_it; - else if (multiline || (prog->reganch & ROPT_IMPLICIT)) { + else if (!(prog->reganch & ROPT_ANCH_GPOS) && + (multiline || (prog->reganch & ROPT_IMPLICIT))) + { if (minlen) dontbother = minlen - 1; strend -= dontbother; @@ -662,7 +665,7 @@ char *prog; if (locinput == regbol && regprev == '\n') break; sayNO; - case GBOL: + case GPOS: if (locinput == regbol) break; sayNO; @@ -30,6 +30,8 @@ typedef struct regexp { char program[1]; /* Unwarranted chumminess with compiler. */ } regexp; -#define ROPT_ANCH 1 -#define ROPT_SKIP 2 -#define ROPT_IMPLICIT 4 +#define ROPT_ANCH 3 +#define ROPT_ANCH_BOL 1 +#define ROPT_ANCH_GPOS 2 +#define ROPT_SKIP 4 +#define ROPT_IMPLICIT 8 @@ -3090,11 +3090,8 @@ I32 append; PerlIO_get_ptr(fp), PerlIO_get_cnt(fp), PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)); /* This used to call 'filbuf' in stdio form, but as that behaves like - getc when cnt <= 0 we use PerlIO_getc here to avoid another - abstraction. This may also avoid issues with different named - 'filbuf' equivalents, though Configure tries to handle them now - anyway. - */ + getc when cnt <= 0 we use PerlIO_getc here to avoid introducing + another abstraction. */ i = PerlIO_getc(fp); /* get more characters */ DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: post: FILE * thinks ptr=%d, cnt=%d, base=%d\n", @@ -3593,7 +3590,7 @@ I32 lref; ENTER; tmpsv = NEWSV(704,0); gv_efullname3(tmpsv, gv, Nullch); - newSUB(start_subparse(0), + newSUB(start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, tmpsv), Nullop, Nullop); @@ -4029,9 +4026,12 @@ SV* sv; switch (type) { case SVt_PVCV: - if (CvANON(sv)) strcat(d, "ANON,"); - if (CvCLONE(sv)) strcat(d, "CLONE,"); - if (CvCLONED(sv)) strcat(d, "CLONED,"); + case SVt_PVFM: + if (CvANON(sv)) strcat(d, "ANON,"); + if (CvUNIQUE(sv)) strcat(d, "UNIQUE,"); + if (CvCLONE(sv)) strcat(d, "CLONE,"); + if (CvCLONED(sv)) strcat(d, "CLONED,"); + if (CvNODEBUG(sv)) strcat(d, "NODEBUG,"); break; case SVt_PVHV: if (HvSHAREKEYS(sv)) strcat(d, "SHAREKEYS,"); @@ -8,4 +8,9 @@ If you put out extra lines with a '#' character on the front, you don't have to worry about removing the extra print statements later since TEST ignores lines beginning with '#'. -If you come up with new tests, send them to larry@wall.org. +If you know that Perl is basically working but expect that some tests +will fail, you may want to use Test::Harness thusly: + ./perl -I../lib harness +This method pinpoints failed tests automatically. + +If you come up with new tests, please send them to larry@wall.org. diff --git a/t/cmd/while.t b/t/cmd/while.t index 4c8c10e990..c6e464d444 100755 --- a/t/cmd/while.t +++ b/t/cmd/while.t @@ -90,6 +90,7 @@ loop: while (<fh>) { if (!eof || $bad) {print "not ok 8\n";} else {print "ok 8\n";} if (!$badcont) {print "ok 9\n";} else {print "not ok 9\n";} +close(fh) || die "Can't close Cmd_while.tmp."; unlink 'Cmd_while.tmp' || `/bin/rm Cmd_While.tmp`; #$x = 0; diff --git a/t/comp/colon.t b/t/comp/colon.t index 2a37367d75..d2c64fe4c5 100755 --- a/t/comp/colon.t +++ b/t/comp/colon.t @@ -110,7 +110,7 @@ ok 18, (not eval "qw:1" and not eval "qw:echo:ohce: >= 0"); ok 19, (not eval "qx:1" and - eval "qx:echo: eq qx|echo|" and + eval "qx:echo 1: eq qx|echo 1|" and # echo without args may warn not eval "qx:echo:ohce: >= 0"); ok 20, (not eval "s:1" and diff --git a/t/comp/multiline.t b/t/comp/multiline.t index 634b06a7a8..0e022e9992 100755 --- a/t/comp/multiline.t +++ b/t/comp/multiline.t @@ -35,6 +35,8 @@ if ($count == 3) {print "ok 3\n";} else {print "not ok 3\n";} $_ = `cat Comp.try`; if (/.*\n.*\n.*\n$/) {print "ok 4\n";} else {print "not ok 4\n";} + +close(try) || (die "Can't close temp file."); unlink 'Comp.try' || `/bin/rm -f Comp.try`; if ($_ eq $y) {print "ok 5\n";} else {print "not ok 5\n";} diff --git a/t/io/argv.t b/t/io/argv.t index 40ed23b373..02cdc27536 100755 --- a/t/io/argv.t +++ b/t/io/argv.t @@ -33,4 +33,4 @@ if ($y eq "1a line\n2a line\n3a line\n") else {print "not ok 5\n";} -`/bin/rm -f Io.argv.tmp` if -x '/bin/rm'; +unlink 'Io.argv.tmp'; diff --git a/t/io/pipe.t b/t/io/pipe.t index 95df4dccb6..d70b2ab258 100755 --- a/t/io/pipe.t +++ b/t/io/pipe.t @@ -2,6 +2,16 @@ # $RCSfile: pipe.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:31 $ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + unless ($Config{'d_fork'}) { + print "1..0\n"; + exit 0; + } +} + $| = 1; print "1..8\n"; diff --git a/t/lib/anydbm.t b/t/lib/anydbm.t index 80b39df141..52ab22b13e 100755 --- a/t/lib/anydbm.t +++ b/t/lib/anydbm.t @@ -111,4 +111,5 @@ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); +untie %h; unlink 'Op.dbmx.dir', $Dfile; diff --git a/t/lib/filehand.t b/t/lib/filehand.t index 11836f1c52..14a17704b9 100755 --- a/t/lib/filehand.t +++ b/t/lib/filehand.t @@ -64,7 +64,7 @@ print "ok 10\n"; ($rd,$wr) = FileHandle::pipe; -if ($^O eq 'VMS' || $^O eq 'os2') { +if ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'amigaos') { $wr->autoflush; $wr->printf("ok %d\n",11); print $rd->getline; diff --git a/t/lib/gdbm.t b/t/lib/gdbm.t index c888c00f85..62bb936ff1 100755 --- a/t/lib/gdbm.t +++ b/t/lib/gdbm.t @@ -114,4 +114,5 @@ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); +untie %h; unlink 'Op.dbmx.dir', $Dfile; diff --git a/t/lib/io_pipe.t b/t/lib/io_pipe.t index 1d050ff4bd..eee374149c 100755 --- a/t/lib/io_pipe.t +++ b/t/lib/io_pipe.t @@ -1,6 +1,5 @@ #!./perl - BEGIN { unless(grep /blib/, @INC) { chdir 't' if -d 't'; @@ -12,7 +11,9 @@ use Config; BEGIN { if(-d "lib" && -f "TEST") { - if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + if (! $Config{'d_fork'} || + ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS')) + { print "1..0\n"; exit 0; } @@ -21,8 +22,24 @@ BEGIN { use IO::Pipe; +my $perl = './perl'; + $| = 1; -print "1..6\n"; +print "1..10\n"; + +$pipe = new IO::Pipe->reader($perl, '-e', 'print "not ok 1\n"'); +while (<$pipe>) { + s/^not //; + print; +} +$pipe->close or print "# \$!=$!\nnot "; +print "ok 2\n"; + +$cmd = 'BEGIN{$SIG{ALRM} = sub {print "not ok 4\n"; exit}; alarm 10} s/not //'; +$pipe = new IO::Pipe->writer($perl, '-pe', $cmd); +print $pipe "not ok 3\n" ; +$pipe->close or print "# \$!=$!\nnot "; +print "ok 4\n"; $pipe = new IO::Pipe; @@ -31,8 +48,8 @@ $pid = fork(); if($pid) { $pipe->writer; - print $pipe "Xk 1\n"; - print $pipe "oY 2\n"; + print $pipe "Xk 5\n"; + print $pipe "oY 6\n"; $pipe->close; wait; } @@ -45,7 +62,7 @@ elsif(defined $pid) } else { - die; + die "# error = $!"; } $pipe = new IO::Pipe; @@ -67,8 +84,8 @@ elsif(defined $pid) $stdout = bless \*STDOUT, "IO::Handle"; $stdout->fdopen($pipe,"w"); - print STDOUT "not ok 3\n"; - exec 'echo', 'not ok 4'; + print STDOUT "not ok 7\n"; + exec 'echo', 'not ok 8'; } else { @@ -81,12 +98,12 @@ $pipe->writer; $SIG{'PIPE'} = 'broken_pipe'; sub broken_pipe { - print "ok 5\n"; + print "ok 9\n"; } -print $pipe "not ok 5\n"; +print $pipe "not ok 9\n"; $pipe->close; -print "ok 6\n"; +print "ok 10\n"; diff --git a/t/lib/io_sock.t b/t/lib/io_sock.t index c3701c5655..06a973cc70 100755 --- a/t/lib/io_sock.t +++ b/t/lib/io_sock.t @@ -10,10 +10,11 @@ BEGIN { use Config; BEGIN { - if(-d "lib" && -f "TEST") { - if ( ($Config{'extensions'} !~ /\bSocket\b/ || - $Config{'extensions'} !~ /\bIO\b/) && - !(($^O eq 'VMS') && $Config{d_socket})) { + if (-d "lib" && -f "TEST") { + if (!$Config{'d_fork'} || + (($Config{'extensions'} !~ /\bSocket\b/ || + $Config{'extensions'} !~ /\bIO\b/) && + !(($^O eq 'VMS') && $Config{d_socket}))) { print "1..0\n"; exit 0; } diff --git a/t/lib/ndbm.t b/t/lib/ndbm.t index 15aa93a725..8e2ba8164a 100755 --- a/t/lib/ndbm.t +++ b/t/lib/ndbm.t @@ -117,4 +117,5 @@ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); +untie %h; unlink 'Op.dbmx.dir', $Dfile; diff --git a/t/lib/odbm.t b/t/lib/odbm.t index 0b1fa50cb9..0c530d2238 100755 --- a/t/lib/odbm.t +++ b/t/lib/odbm.t @@ -117,4 +117,5 @@ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); +untie %h; unlink 'Op.dbmx.dir', $Dfile; diff --git a/t/lib/open2.t b/t/lib/open2.t index 1cf325a875..a2e6a07a7b 100755 --- a/t/lib/open2.t +++ b/t/lib/open2.t @@ -3,6 +3,11 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require Config; import Config; + unless ($Config{'d_fork'}) { + print "1..0\n"; + exit 0; + } # make warnings fatal $SIG{__WARN__} = sub { die @_ }; } @@ -12,6 +17,8 @@ use IO::Handle; use IPC::Open2; #require 'open2.pl'; use subs 'open2'; +my $perl = './perl'; + sub ok { my ($n, $result, $info) = @_; if ($result) { @@ -29,7 +36,7 @@ STDERR->autoflush; print "1..7\n"; -ok 1, $pid = open2 'READ', 'WRITE', $^X, '-e', 'print scalar <STDIN>'; +ok 1, $pid = open2 'READ', 'WRITE', $perl, '-e', 'print scalar <STDIN>'; ok 2, print WRITE "hi kid\n"; ok 3, <READ> eq "hi kid\n"; ok 4, close(WRITE), $!; diff --git a/t/lib/open3.t b/t/lib/open3.t index a5d7f2e8ee..4258eec401 100755 --- a/t/lib/open3.t +++ b/t/lib/open3.t @@ -3,6 +3,11 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require Config; import Config; + unless ($Config{'d_fork'}) { + print "1..0\n"; + exit 0; + } # make warnings fatal $SIG{__WARN__} = sub { die @_ }; } @@ -12,6 +17,8 @@ use IO::Handle; use IPC::Open3; #require 'open3.pl'; use subs 'open3'; +my $perl = './perl'; + sub ok { my ($n, $result, $info) = @_; if ($result) { @@ -30,7 +37,7 @@ STDERR->autoflush; print "1..21\n"; # basic -ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $^X, '-e', <<'EOF'; +ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', <<'EOF'; $| = 1; print scalar <STDIN>; print STDERR "hi error\n"; @@ -46,7 +53,7 @@ ok 8, $reaped_pid == $pid, $reaped_pid; ok 9, $? == 0, $?; # read and error together, both named -$pid = open3 'WRITE', 'READ', 'READ', $^X, '-e', <<'EOF'; +$pid = open3 'WRITE', 'READ', 'READ', $perl, '-e', <<'EOF'; $| = 1; print scalar <STDIN>; print STDERR scalar <STDIN>; @@ -58,7 +65,7 @@ print scalar <READ>; waitpid $pid, 0; # read and error together, error empty -$pid = open3 'WRITE', 'READ', '', $^X, '-e', <<'EOF'; +$pid = open3 'WRITE', 'READ', '', $perl, '-e', <<'EOF'; $| = 1; print scalar <STDIN>; print STDERR scalar <STDIN>; @@ -72,7 +79,7 @@ waitpid $pid, 0; # dup writer ok 14, pipe PIPE_READ, PIPE_WRITE; $pid = open3 '<&PIPE_READ', 'READ', '', - $^X, '-e', 'print scalar <STDIN>'; + $perl, '-e', 'print scalar <STDIN>'; close PIPE_READ; print PIPE_WRITE "ok 15\n"; close PIPE_WRITE; @@ -81,7 +88,7 @@ waitpid $pid, 0; # dup reader $pid = open3 'WRITE', '>&STDOUT', 'ERROR', - $^X, '-e', 'print scalar <STDIN>'; + $perl, '-e', 'print scalar <STDIN>'; print WRITE "ok 16\n"; waitpid $pid, 0; @@ -89,12 +96,12 @@ waitpid $pid, 0; # stdout but putting stdout somewhere else, is a good case because it # used not to work. $pid = open3 'WRITE', 'READ', '>&STDOUT', - $^X, '-e', 'print STDERR scalar <STDIN>'; + $perl, '-e', 'print STDERR scalar <STDIN>'; print WRITE "ok 17\n"; waitpid $pid, 0; # dup reader and error together, both named -$pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $^X, '-e', <<'EOF'; +$pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $perl, '-e', <<'EOF'; $| = 1; print STDOUT scalar <STDIN>; print STDERR scalar <STDIN>; @@ -104,7 +111,7 @@ print WRITE "ok 19\n"; waitpid $pid, 0; # dup reader and error together, error empty -$pid = open3 'WRITE', '>&STDOUT', '', $^X, '-e', <<'EOF'; +$pid = open3 'WRITE', '>&STDOUT', '', $perl, '-e', <<'EOF'; $| = 1; print STDOUT scalar <STDIN>; print STDERR scalar <STDIN>; diff --git a/t/lib/sdbm.t b/t/lib/sdbm.t index 1bb3fde392..65419f9711 100755 --- a/t/lib/sdbm.t +++ b/t/lib/sdbm.t @@ -116,4 +116,5 @@ print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); +untie %h; unlink 'Op.dbmx.dir', $Dfile; diff --git a/t/op/cmp.t b/t/op/cmp.t index aba7c2e9dc..4a7e68d448 100755 --- a/t/op/cmp.t +++ b/t/op/cmp.t @@ -18,7 +18,7 @@ for my $i (0..$#FOO) { print "ok $ok\n"; } else { - print "not ok $ok ($FOO[$i] <=> $FOO[$j])\n"; + print "not ok $ok ($FOO[$i] <=> $FOO[$j]) gives: '$cmp'\n"; } $ok++; $cmp = $FOO[$i] cmp $FOO[$j]; @@ -29,7 +29,7 @@ for my $i (0..$#FOO) { print "ok $ok\n"; } else { - print "not ok $ok ($FOO[$i] cmp $FOO[$j])\n"; + print "not ok $ok ($FOO[$i] cmp $FOO[$j]) gives '$cmp'\n"; } } } diff --git a/t/op/fork.t b/t/op/fork.t index 598310b63f..9790ff0f8c 100755 --- a/t/op/fork.t +++ b/t/op/fork.t @@ -2,6 +2,16 @@ # $RCSfile: fork.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:53 $ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + unless ($Config{'d_fork'}) { + print "1..0\n"; + exit 0; + } +} + $| = 1; print "1..2\n"; diff --git a/t/op/magic.t b/t/op/magic.t index a050510f38..bb65ae8b7a 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -7,7 +7,7 @@ BEGIN { $| = 1; chdir 't' if -d 't'; @INC = '../lib'; - $SIG{__WARN__} = sub { die @_ }; + $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; } sub ok { @@ -97,19 +97,33 @@ ok 17, $@ eq "foo\n", $@; ok 18, $$ > 0, $$; # $^X and $0 -$script = './show-shebang'; +if ($^O eq 'qnx') { + chomp($wd = `pwd`); +} +else { + $wd = '.'; +} +$script = "$wd/show-shebang"; +if ($^O eq 'os2') { + # Started by ksh, which adds suffixes '.exe' and '.' to perl and script + $s = "\$^X is $wd/perl.exe, \$0 is $script.\n"; +} +else { + $s = "\$^X is $wd/perl, \$0 is $script\n"; +} ok 19, open(SCRIPT, ">$script"), $!; -ok 20, print(SCRIPT <<'EOF'), $!; -#!./perl +ok 20, print(SCRIPT <<EOB . <<'EOF'), $!; +#!$wd/perl +EOB print "\$^X is $^X, \$0 is $0\n"; EOF ok 21, close(SCRIPT), $!; ok 22, chmod(0755, $script), $!; -$s = "\$^X is ./perl, \$0 is $script\n"; $_ = `$script`; -ok 23, $_ eq $s, ":$_:"; -$_ = `./perl $script`; -ok 24, $_ eq $s, ":$_:"; +s{is perl}{is $wd/perl}; # for systems where $^X is only a basename +ok 23, $_ eq $s, ":$_:!=:$s:"; +$_ = `$wd/perl $script`; +ok 24, $_ eq $s, ":$_:!=:$s:"; ok 25, unlink($script), $!; # $], $^O, $^T diff --git a/t/op/misc.t b/t/op/misc.t index 4f47f0f7af..09385b94a4 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -269,3 +269,23 @@ eval q[ my $a = 'inner'; eval q[ print "$a " ] ]; eval { my $x = 'peace'; eval q[ print "$x\n" ] } EXPECT inner peace +######## +-w +$| = 1; +sub foo { + print "In foo1\n"; + eval 'sub foo { print "In foo2\n" }'; + print "Exiting foo1\n"; +} +foo; +foo; +EXPECT +In foo1 +Subroutine foo redefined at (eval 1) line 1. +Exiting foo1 +In foo2 +######## +$s = 0; +map {#this newline here tickles the bug +$s += $_} (1,2,4); +print "eat flaming death\n" unless ($s == 7); diff --git a/t/pragma/locale.t b/t/pragma/locale.t index 0f71da434b..d723590e14 100755 --- a/t/pragma/locale.t +++ b/t/pragma/locale.t @@ -364,6 +364,7 @@ print "ok 101\n"; # Find places where the collation order differs from the default locale. +print "# testing 102\n"; { my (@k, $i, $j, @d); @@ -386,6 +387,7 @@ print "ok 101\n"; for (@d) { ($i, $j) = @$_; if ($i gt $j) { + print "# failed 102 at:\n"; print "# i = $i, j = $j, i ", $i le $j ? 'le' : 'gt', " j\n"; print 'not '; @@ -397,12 +399,15 @@ print "ok 102\n"; # Cross-check whole character set. +print "# testing 103\n"; for (map { chr } 0..255) { if (/\w/ and /\W/) { print 'not '; last } if (/\d/ and /\D/) { print 'not '; last } if (/\s/ and /\S/) { print 'not '; last } if (/\w/ and /\D/ and not /_/ and not (exists $UPPER{$_} or exists $lower{$_})) { + print "# failed 103 at:\n"; + print "# ", ord($_), " '$_'\n"; print 'not '; last; } @@ -411,8 +416,9 @@ print "ok 103\n"; # The @Locale should be internally consistent. +print "# testing 104\n"; { - my ($from, $to, , $lesser, $greater); + my ($from, $to, $lesser, $greater, @test, %test, $test); for (0..9) { # Select a slice. @@ -424,23 +430,42 @@ print "ok 103\n"; $from++; $to++; $to = $#Locale if ($to > $#Locale); $greater = join('', @Locale[$from..$to]); - if (not ($lesser lt $greater) or - not ($lesser le $greater) or - not ($lesser ne $greater) or - ($lesser eq $greater) or - ($lesser ge $greater) or - ($lesser gt $greater) or - ($greater lt $lesser ) or - ($greater le $lesser ) or - not ($greater ne $lesser ) or - ($greater eq $lesser ) or - not ($greater ge $lesser ) or - not ($greater gt $lesser ) or - # Well, these two are sort of redundant because @Locale - # was derived using cmp. - not (($lesser cmp $greater) == -1) or - not (($greater cmp $lesser ) == 1) - ) { + @test = + ( + 'not ($lesser lt $greater)', # 0 + 'not ($lesser le $greater)', # 1 + 'not ($lesser ne $greater)', # 2 + ' ($lesser eq $greater)', # 3 + ' ($lesser ge $greater)', # 4 + ' ($lesser gt $greater)', # 5 + ' ($greater lt $lesser )', # 6 + ' ($greater le $lesser )', # 7 + 'not ($greater ne $lesser )', # 8 + ' ($greater eq $lesser )', # 9 + 'not ($greater ge $lesser )', # 10 + 'not ($greater gt $lesser )', # 11 + # Well, these two are sort of redundant + # because @Locale was derived using cmp. + 'not (($lesser cmp $greater) == -1)', # 12 + 'not (($greater cmp $lesser ) == 1)' # 13 + ); + @test{@test} = 0 x @test; + $test = 0; + for my $ti (@test) { $test{$ti} = eval $ti ; $test ||= $test{$ti} } + if ($test) { + print "# failed 104 at:\n"; + print "# lesser = '$lesser'\n"; + print "# greater = '$greater'\n"; + print "# (greater) from = $from, to = $to\n"; + for my $ti (@test) { + printf("# %-40s %-4s", $ti, + $test{$ti} ? 'FAIL' : 'ok'); + if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) { + printf("(%s == %4d)", $1, eval $1); + } + print "\n"; + } + print 'not '; last; } @@ -1579,35 +1579,31 @@ yylex() #endif /* ALTERNATE_SHEBANG */ } if (d) { - /* - * HP-UX (at least) sets argv[0] to the script name, - * which makes $^X incorrect. And Digital UNIX and Linux, - * at least, set argv[0] to the basename of the Perl - * interpreter. So, having found "#!", we'll set it right. - */ - SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); char *ipath; - char *ibase; + char *ipathend; - while (*d == ' ' || *d == '\t') + while (isSPACE(*d)) d++; ipath = d; - ibase = Nullch; - while (*d && !isSPACE(*d)) { - if (*d++ == '/') - ibase = d; + while (*d && !isSPACE(*d)) + d++; + ipathend = d; + +#ifdef ARG_ZERO_IS_SCRIPT + if (ipathend > ipath) { + /* + * HP-UX (at least) sets argv[0] to the script name, + * which makes $^X incorrect. And Digital UNIX and Linux, + * at least, set argv[0] to the basename of the Perl + * interpreter. So, having found "#!", we'll set it right. + */ + SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); + assert(SvPOK(x) || SvGMAGICAL(x)); + if (sv_eq(x, GvSV(curcop->cop_filegv))) + sv_setpvn(x, ipath, ipathend - ipath); + TAINT_NOT; /* $^X is always tainted, but that's OK */ } - assert(SvPOK(x) || SvGMAGICAL(x)); - if (sv_eq(x, GvSV(curcop->cop_filegv)) - || (ibase - && SvCUR(x) == (d - ibase) - && strnEQ(SvPVX(x), ibase, d - ibase))) - sv_setpvn(x, ipath, d - ipath); - /* - * $^X is always tainted, but taintedness must be off - * when parsing code, so forget we ever saw it. - */ - TAINT_NOT; +#endif /* ARG_ZERO_IS_SCRIPT */ /* * Look for options. @@ -1624,10 +1620,9 @@ yylex() * other interpreter. Similarly, if "perl" is there, but * not in the first 'word' of the line, we assume the line * contains the start of the Perl program. - * This isn't foolproof, but it's generally a good guess. */ if (d && *s != '#') { - char *c = s; + char *c = ipath; while (*c && !strchr("; \t\r\n\f\v#", *c)) c++; if (c < d) @@ -1635,23 +1630,18 @@ yylex() else *s = '#'; /* Don't try to parse shebang line */ } -#endif +#endif /* ALTERNATE_SHEBANG */ if (!d && *s == '#' && + ipathend > ipath && !minus_c && !instr(s,"indir") && instr(origargv[0],"perl")) { char **newargv; - char *cmd; - s += 2; - if (*s == ' ') - s++; - cmd = s; - while (s < bufend && !isSPACE(*s)) - s++; - *s++ = '\0'; + *ipathend = '\0'; + s = ipathend + 1; while (s < bufend && isSPACE(*s)) s++; if (s < bufend) { @@ -1664,9 +1654,9 @@ yylex() } else newargv = origargv; - newargv[0] = cmd; - execv(cmd,newargv); - croak("Can't exec %s", cmd); + newargv[0] = ipath; + execv(ipath, newargv); + croak("Can't exec %s", ipath); } if (d) { int oldpdb = perldb; @@ -4533,9 +4523,10 @@ register PMOP *pm; return; } } - if (!pm->op_pmshort || /* promote the better string */ - ((pm->op_pmflags & PMf_SCANFIRST) && - (SvCUR(pm->op_pmshort) < SvCUR(pm->op_pmregexp->regmust)) )){ + /* promote the better string */ + if ((!pm->op_pmshort && !(pm->op_pmregexp->reganch & ROPT_ANCH)) || + ((pm->op_pmflags & PMf_SCANFIRST) && + (SvCUR(pm->op_pmshort) < SvCUR(pm->op_pmregexp->regmust)))) { SvREFCNT_dec(pm->op_pmshort); /* ok if null */ pm->op_pmshort = pm->op_pmregexp->regmust; pm->op_pmslen = SvCUR(pm->op_pmshort); @@ -4610,10 +4601,11 @@ register char *s; char term; register char *d; char *peek; + int outer = (rsfp && !lex_inwhat); s += 2; d = tokenbuf; - if (!rsfp) + if (!outer) *d++ = '\n'; for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ; if (*peek && strchr("`'\"",*peek)) { @@ -4638,7 +4630,7 @@ register char *s; *d = '\0'; len = d - tokenbuf; d = "\n"; - if (rsfp || !(d=ninstr(s,bufend,d,d+1))) + if (outer || !(d=ninstr(s,bufend,d,d+1))) herewas = newSVpv(s,bufend-s); else s--, herewas = newSVpv(s,d-s); @@ -4659,7 +4651,7 @@ register char *s; multi_start = curcop->cop_line; multi_open = multi_close = '<'; term = *tokenbuf; - if (!rsfp) { + if (!outer) { d = s; while (s < bufend && (*s != term || memNE(s,tokenbuf,len)) ) { @@ -4680,7 +4672,7 @@ register char *s; else sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */ while (s >= bufend) { /* multiple line string? */ - if (!rsfp || + if (!outer || !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) { curcop->cop_line = multi_start; missingterm(tokenbuf); @@ -5069,7 +5061,8 @@ set_csh() } int -start_subparse(flags) +start_subparse(is_format, flags) +I32 is_format; U32 flags; { int oldsavestack_ix = savestack_ix; @@ -5092,7 +5085,7 @@ U32 flags; SAVEI32(pad_reset_pending); compcv = (CV*)NEWSV(1104,0); - sv_upgrade((SV *)compcv, (flags & CVf_FORMAT) ? SVt_PVFM : SVt_PVCV); + sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV); CvFLAGS(compcv) |= flags; comppad = newAV(); @@ -1191,15 +1191,19 @@ die(pat, va_alist) LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; - SV *msg = sv_2mortal(newSVpv(message, 0)); + SV *msg; + + ENTER; + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); PUSHMARK(sp); XPUSHs(msg); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); - /* It's okay for the __DIE__ hook to modify the message. */ - message = SvPV(msg, na); + LEAVE; } } @@ -1243,15 +1247,19 @@ croak(pat, va_alist) LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; - SV *msg = sv_2mortal(newSVpv(message, 0)); + SV *msg; + + ENTER; + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); PUSHMARK(sp); XPUSHs(msg); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); - /* It's okay for the __DIE__ hook to modify the message. */ - message = SvPV(msg, na); + LEAVE; } } if (in_eval) { @@ -1311,10 +1319,19 @@ warn(pat,va_alist) LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; + SV *msg; + + ENTER; + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); + PUSHMARK(sp); - XPUSHs(sv_2mortal(newSVpv(message,0))); + XPUSHs(msg); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); + + LEAVE; return; } } diff --git a/utils/Makefile b/utils/Makefile index 958dc038d7..1f8c5f4764 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -12,7 +12,17 @@ all: $(plextract) $(plextract): $(PERL) -I../lib $@.PL -splain: ../lib/diagnostics.pm +c2ph: c2ph.PL + +h2ph: h2ph.PL + +perlbug: perlbug.PL + +perldoc: perldoc.PL + +pl2pm: pl2pm.PL + +splain: splain.PL ../lib/diagnostics.pm clean: diff --git a/utils/c2ph.PL b/utils/c2ph.PL index 9f80bc04a6..bd4da34b61 100644 --- a/utils/c2ph.PL +++ b/utils/c2ph.PL @@ -14,6 +14,7 @@ use File::Basename qw(&basename &dirname); # This is so that make depend always knows where to find PL derivatives. chdir dirname($0); $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; diff --git a/utils/h2ph.PL b/utils/h2ph.PL index bfd606d399..2aa57ad2f3 100644 --- a/utils/h2ph.PL +++ b/utils/h2ph.PL @@ -15,6 +15,7 @@ use File::Basename qw(&basename &dirname); # This is so that make depend always knows where to find PL derivatives. chdir dirname($0); $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 466fdab9b8..686580918b 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -14,6 +14,7 @@ use File::Basename qw(&basename &dirname); # This is so that make depend always knows where to find PL derivatives. chdir dirname($0); $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; diff --git a/utils/perlbug.PL b/utils/perlbug.PL index b44502bddb..9645195fa1 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -14,6 +14,7 @@ use File::Basename qw(&basename &dirname); # This is so that make depend always knows where to find PL derivatives. chdir dirname($0); $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; @@ -48,7 +49,7 @@ use strict; sub paraprint; -my($Version) = "1.15"; +my($Version) = "1.16"; # Changed in 1.06 to skip Mail::Send and Mail::Util if not available. # Changed in 1.07 to see more sendmail execs, and added pipe output. @@ -66,6 +67,7 @@ my($Version) = "1.15"; # helpful information. Also let file read fail gracefully. # Changed in 1.15 to add warnings to stop people using perlbug for non-bugs. # Also report selected environment variables. +# Changed in 1.16 to include @INC, and allow user to re-edit if no changes. # TODO: Allow the user to re-name the file on mail failure, and # make sure failure (transmission-wise) of Mail::Send is @@ -73,7 +75,7 @@ my($Version) = "1.15"; my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename, $subject, $from, $verbose, $ed, - $fh, $me, $Is_VMS, $msg, $body, $andcc ); + $fh, $me, $Is_VMS, $msg, $body, $andcc, %REP); Init(); @@ -176,7 +178,8 @@ EOF paraprint <<EOF; First of all, please provide a subject for the message. It should be a concise description of -the bug or problem. +the bug or problem. "perl bug" or "perl problem" +is not a concise description. EOF print "Subject: "; @@ -402,12 +405,31 @@ EOF } close(F); } else { - print REP "[Please enter your report here]\n"; + print REP <<EOF; + +----------------------------------------------------------------- +[Please enter your report here] + + + +[Please do not change anything below this line] +----------------------------------------------------------------- +EOF } Dump(*REP); close(REP); + # read in the report template once so that + # we can track whether the user does any editing. + # yes, *all* whitespace is ignored. + open(REP, "<$filename"); + while (<REP>) { + s/\s+//g; + $REP{$_}++; + } + close(REP); + } sub Dump { @@ -415,8 +437,7 @@ sub Dump { print OUT <<EOF; - - +--- Site configuration information for perl $]: EOF @@ -438,7 +459,16 @@ EOF } print OUT <<EOF; +--- +\@INC for perl $]: +EOF + for my $i (@INC) { + print OUT "\t$i\n"; + } + + print OUT <<EOF; +--- Environment for perl $]: EOF for my $env (qw(PATH LD_LIBRARY_PATH @@ -502,6 +532,42 @@ EOF } } } + + # Check that we have a report that has some, eh, report in it. + + my $unseen = 0; + + open(REP, "<$filename"); + # a strange way to check whether any significant editing + # have been done: check whether any new non-empty lines + # have been added. Yes, the below code ignores *any* space + # in *any* line. + while (<REP>) { + s/\s+//g; + $unseen++ if ($_ ne '' and not exists $REP{$_}); + } + + while ($unseen == 0) { + paraprint <<EOF; + +I am sorry but it looks like you did not report anything. + +EOF + print "Action (Retry Edit/Cancel) "; + my ($action) = scalar(<>); + if ($action =~ /^[re]/i) { # <R>etry <E>dit + goto tryagain; + } elsif ($action =~ /^[cq]/i) { # <C>ancel, <Q>uit + Cancel(); + } + } + +} + +sub Cancel { + 1 while unlink($filename); # remove all versions under VMS + print "\nCancelling.\n"; + exit(0); } sub NowWhat { @@ -572,9 +638,7 @@ EOF Edit(); #system("$ed $filename"); } elsif( $action =~ /^[qc]/i ) { # <C>ancel, <Q>uit - 1 while unlink($filename); # remove all versions under VMS - print "\nCancelling.\n"; - exit(0); + Cancel(); } elsif( $action =~ /^s/ ) { paraprint <<EOF; diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 28bb464f85..7945712ef4 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -14,6 +14,7 @@ use File::Basename qw(&basename &dirname); # This is so that make depend always knows where to find PL derivatives. chdir dirname($0); $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; diff --git a/utils/pl2pm.PL b/utils/pl2pm.PL index 7c187ade35..55a8d2ea35 100644 --- a/utils/pl2pm.PL +++ b/utils/pl2pm.PL @@ -14,6 +14,7 @@ use File::Basename qw(&basename &dirname); # This is so that make depend always knows where to find PL derivatives. chdir dirname($0); $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; diff --git a/utils/splain.PL b/utils/splain.PL index ef7c457dda..75b5e2f3f6 100644 --- a/utils/splain.PL +++ b/utils/splain.PL @@ -15,6 +15,7 @@ use File::Basename qw(&basename &dirname); # This is so that make depend always knows where to find PL derivatives. chdir dirname($0); $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; # Open input file before creating output file. $IN = '../lib/diagnostics.pm'; diff --git a/vms/Makefile b/vms/Makefile index bf6a428d8b..f84139ecb5 100644 --- a/vms/Makefile +++ b/vms/Makefile @@ -32,7 +32,7 @@ ARCH = VMS_VAX OBJVAL = $@ # Updated by fndvers.com -- do not edit by hand -PERL_VERSION = 5_00321# +PERL_VERSION = 5_00323# ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] @@ -159,8 +159,10 @@ CRTLOPTS =,$(CRTL)/Options $(XSUBPP) $< >$(MMS$SOURCE_NAME).c $(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c +utils1 = [.lib.pod]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils]h2ph.com [.utils]h2xs.com [.lib]perlbug.com +utils2 = [.lib]splain.com [.utils]pl2pm.com -all : base extras libmods utils podxform archcorefiles preplibrary perlpods +all : base extras x2p archcorefiles preplibrary perlpods @ $(NOOP) base : miniperl perl @ $(NOOP) @@ -168,9 +170,11 @@ extras : Fcntl IO Opcode $(POSIX) libmods utils podxform @ $(NOOP) libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm @ $(NOOP) -utils : [.lib.pod]perldoc [.lib.ExtUtils]Miniperl.pm [.utils]c2ph [.utils]h2ph [.utils]h2xs [.lib]perlbug +utils : $(utils1) $(utils2) @ $(NOOP) -podxform : [.lib.pod]pod2text [.lib.pod]pod2html [.lib.pod]pod2latex [.lib.pod]pod2man +podxform : [.lib.pod]pod2text.com [.lib.pod]pod2html.com [.lib.pod]pod2latex.com [.lib.pod]pod2man.com + @ $(NOOP) +x2p : [.x2p]a2p$(E) [.x2p]s2p.com [.x2p]find2perl.com @ $(NOOP) pod1 = [.lib.pod]perl.pod [.lib.pod]perlapio.pod [.lib.pod]perlbook.pod [.lib.pod]perlbot.pod [.lib.pod]perlcall.pod @@ -377,50 +381,59 @@ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]S [.lib.pod]perldoc : [.utils]perldoc.PL $(ARCHDIR)Config.pm @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) [.utils]perldoc.PL - Copy/Log [.utils]perldoc $@ + Copy/Log [.utils]perldoc.com $@ [.lib.ExtUtils]Miniperl.pm : Minimod.PL miniperlmain.c $(ARCHDIR)Config.pm $(MINIPERL) Minimod.PL >$@ -[.utils]c2ph : [.utils]c2ph.PL $(ARCHDIR)Config.pm +[.utils]c2ph.com : [.utils]c2ph.PL $(ARCHDIR)Config.pm $(MINIPERL) [.utils]c2ph.PL -[.utils]h2ph : [.utils]h2ph.PL $(ARCHDIR)Config.pm +[.utils]h2ph.com : [.utils]h2ph.PL $(ARCHDIR)Config.pm $(MINIPERL) [.utils]h2ph.PL -[.utils]h2xs : [.utils]h2xs.PL $(ARCHDIR)Config.pm +[.utils]h2xs.com : [.utils]h2xs.PL $(ARCHDIR)Config.pm $(MINIPERL) [.utils]h2xs.PL -[.lib]perlbug : [.utils]perlbug.PL $(ARCHDIR)Config.pm +[.lib]perlbug.com : [.utils]perlbug.PL $(ARCHDIR)Config.pm $(MINIPERL) [.utils]perlbug.PL - Rename/Log [.utils]perlbug $@ + Rename/Log [.utils]perlbug.com $@ -[.utils]pl2pm : [.utils]pl2pm.PL $(ARCHDIR)Config.pm +[.utils]pl2pm.com : [.utils]pl2pm.PL $(ARCHDIR)Config.pm $(MINIPERL) [.utils]pl2pm.PL -[.lib]splain : [.utils]splain.PL $(ARCHDIR)Config.pm +[.lib]splain.com : [.utils]splain.PL $(ARCHDIR)Config.pm $(MINIPERL) [.utils]splain.PL - Rename/Log [.utils]splain $@ + Rename/Log [.utils]splain.com $@ + +[.x2p]find2perl.com : [.x2p]find2perl.PL $(ARCHDIR)Config.pm + $(MINIPERL) [.x2p]find2perl.PL + +[.x2p]s2p.com : [.x2p]s2p.PL $(ARCHDIR)Config.pm + $(MINIPERL) [.x2p]s2p.PL -[.lib.pod]pod2html : [.pod]pod2html.PL $(ARCHDIR)Config.pm +[.x2p]$(DBG)a2p$(E) : [.x2p]a2p$(O), [.x2p]hash$(O), [.x2p]str$(O), [.x2p]util$(O), [.x2p]walk$(O) + Link $(LINKFLAGS) /Exe=$@ $(MMS$SOURCE_LIST) $(CRTLOPTS) + +[.lib.pod]pod2html.com : [.pod]pod2html.PL $(ARCHDIR)Config.pm @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) [.pod]pod2html.PL - Rename/Log [.pod]pod2html $@ + Rename/Log [.pod]pod2html.com $@ -[.lib.pod]pod2latex : [.pod]pod2latex.PL $(ARCHDIR)Config.pm +[.lib.pod]pod2latex.com : [.pod]pod2latex.PL $(ARCHDIR)Config.pm @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) [.pod]pod2latex.PL - Rename/Log [.pod]pod2latex $@ + Rename/Log [.pod]pod2latex.com $@ -[.lib.pod]pod2man : [.pod]pod2man.PL $(ARCHDIR)Config.pm +[.lib.pod]pod2man.com : [.pod]pod2man.PL $(ARCHDIR)Config.pm @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) [.pod]pod2man.PL - Rename/Log [.pod]pod2man $@ + Rename/Log [.pod]pod2man.com $@ -[.lib.pod]pod2text : [.pod]pod2text.PL $(ARCHDIR)Config.pm +[.lib.pod]pod2text.com : [.pod]pod2text.PL $(ARCHDIR)Config.pm @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) [.pod]pod2text.PL - Rename/Log [.pod]pod2text $@ + Rename/Log [.pod]pod2text.com $@ preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm $(SOCKPM) @ Write sys$$Output "Autosplitting Perl library . . ." @@ -601,6 +614,9 @@ perly.h : [.vms]perly_h.vms perly$(O) : perly.c, perly.h, $(h) $(CC) $(CFLAGS) perly.c +[.t.lib]vmsfspec.t : [.vms.ext]filespec.t + Copy/Log/NoConfirm [.vms.ext]filespec.t $@ + test : all - @[.VMS]Test.Com "$(E)" @@ -1378,6 +1394,42 @@ globals$(O) : scope.h globals$(O) : sv.h globals$(O) : vmsish.h globals$(O) : util.h +[.x2p]a2p$(O) : [.x2p]a2p.c +[.x2p]a2p$(O) : [.x2p]a2py.c +[.x2p]a2p$(O) : [.x2p]INTERN.h +[.x2p]a2p$(O) : [.x2p]a2p.h +[.x2p]a2p$(O) : [.x2p]hash.h +[.x2p]a2p$(O) : [.x2p]str.h +[.x2p]a2p$(O) : handy.h +[.x2p]hash$(O) : [.x2p]hash.c +[.x2p]hash$(O) : [.x2p]EXTERN.h +[.x2p]hash$(O) : [.x2p]a2p.h +[.x2p]hash$(O) : [.x2p]hash.h +[.x2p]hash$(O) : [.x2p]str.h +[.x2p]hash$(O) : handy.h +[.x2p]hash$(O) : [.x2p]util.h +[.x2p]str$(O) : [.x2p]str.c +[.x2p]str$(O) : [.x2p]EXTERN.h +[.x2p]str$(O) : [.x2p]a2p.h +[.x2p]str$(O) : [.x2p]hash.h +[.x2p]str$(O) : [.x2p]str.h +[.x2p]str$(O) : handy.h +[.x2p]str$(O) : [.x2p]util.h +[.x2p]util$(O) : [.x2p]util.c +[.x2p]util$(O) : [.x2p]EXTERN.h +[.x2p]util$(O) : [.x2p]a2p.h +[.x2p]util$(O) : [.x2p]hash.h +[.x2p]util$(O) : [.x2p]str.h +[.x2p]util$(O) : handy.h +[.x2p]util$(O) : [.x2p]INTERN.h +[.x2p]util$(O) : [.x2p]util.h +[.x2p]walk$(O) : [.x2p]walk.c +[.x2p]walk$(O) : [.x2p]EXTERN.h +[.x2p]walk$(O) : [.x2p]a2p.h +[.x2p]walk$(O) : [.x2p]hash.h +[.x2p]walk$(O) : [.x2p]str.h +[.x2p]walk$(O) : handy.h +[.x2p]walk$(O) : [.x2p]util.h config.h : [.vms]config.vms Copy/Log/NoConfirm [.vms]config.vms []config.h @@ -1442,7 +1494,7 @@ clean : tidy - $(MMS) clean Set Default [--] - If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt - - If f$$Search("*$(O);*") .nes."" Then Delete/NoConfirm/Log *$(O);* + - If f$$Search("[...]*$(O);*") .nes."" Then Delete/NoConfirm/Log [...]*$(O);* - If f$$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;* - If f$$Search("Config.SH").nes."" Then Delete/NoConfirm/Log Config.SH;* - If f$$Search(f$$Parse("sys$$Disk:[]","$(SOCKH)")).nes."" Then Delete/NoConfirm/Log $(SOCKH);* @@ -1484,10 +1536,11 @@ realclean : clean - If f$$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;* - If f$$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;* - If f$$Search("[.utils]*.").nes."" Then Delete/NoConfirm/Log [.utils]*.;*/Exclude=Makefile. + - If f$$Search("[.x2p]*.").nes."" Then Delete/NoConfirm/Log [.x2p]*.;*/Exclude=Makefile. - If f$$Search("[.lib.pod]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pod]*.pod;* - If f$$Search("[.lib.pod]perldoc.").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.;* - - If f$$Search("[.lib.pod]pod2*.").nes."" Then Delete/NoConfirm/Log [.lib.pod]pod2*.;* - - If f$$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);* + - If f$$Search("[.lib.pod]pod2*.com").nes."" Then Delete/NoConfirm/Log [.lib.pod]pod2*.com;* + - If f$$Search("[...]*$(E)").nes."" Then Delete/NoConfirm/Log [...]*$(E);* cleansrc : clean - If f$$Search("*.C;-1").nes."" Then Purge/NoConfirm/Log *.C diff --git a/vms/config.vms b/vms/config.vms index a7460e5cf5..75bf30220f 100644 --- a/vms/config.vms +++ b/vms/config.vms @@ -76,9 +76,17 @@ * when Perl is built. Please do not change it by hand; make * any changes to FndVers.Com instead. */ -#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00321" /**/ +#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00323" /**/ #define ARCHLIB ARCHLIB_EXP /*config-skip*/ +/* ARCHNAME: + * This symbol holds a string representing the architecture name. + * It may be used to construct an architecture-dependant pathname + * where library files may be held under a private library, for + * instance. + */ +#define ARCHNAME "VMS_VAX" /**/ + /* BINCOMPAT3: * This symbol, if defined, indicates that Perl 5.004 should be * binary-compatible with Perl 5.003. @@ -530,16 +538,6 @@ # define FILE_cnt(fp) ((*fp)->_cnt) #endif -/* FILE_filbuf: - * This macro is used to access the internal stdio _filbuf function - * (or equivalent), if STDIO_CNT_LVALUE and STDIO_PTR_LVALUE - * are defined. It is typically either _filbuf or __filbuf. - * This macro will only be defined if both STDIO_CNT_LVALUE and - * STDIO_PTR_LVALUE are defined. - */ -#define FILE_filbuf(fp) do { register int c; if ((c = fgetc(fp)) != EOF) \ - ungetc(c,(fp)); } while (0); - /* FILE_base: * This macro is used to access the _base field (or equivalent) of the * FILE structure pointed to by its argument. This macro will always be diff --git a/vms/descrip.mms b/vms/descrip.mms index 32200a3dfa..c66736f278 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -65,7 +65,7 @@ OBJVAL = $(MMS$TARGET_NAME)$(O) .endif # Updated by fndvers.com -- do not edit by hand -PERL_VERSION = 5_00321# +PERL_VERSION = 5_00323# ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)] @@ -265,8 +265,10 @@ CRTLOPTS =,$(CRTL)/Options $(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c .endif +utils1 = [.lib.pod]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils]h2ph.com [.utils]h2xs.com [.lib]perlbug.com +utils2 = [.lib]splain.com [.utils]pl2pm.com -all : base extras libmods utils podxform archcorefiles preplibrary perlpods +all : base extras x2p archcorefiles preplibrary perlpods @ $(NOOP) base : miniperl perl @ $(NOOP) @@ -274,9 +276,11 @@ extras : Fcntl IO Opcode $(POSIX) libmods utils podxform @ $(NOOP) libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm @ $(NOOP) -utils : [.lib.pod]perldoc [.lib.ExtUtils]Miniperl.pm [.utils]c2ph [.utils]h2ph [.utils]h2xs [.lib]perlbug +utils : $(utils1) $(utils2) @ $(NOOP) -podxform : [.lib.pod]pod2text [.lib.pod]pod2html [.lib.pod]pod2latex [.lib.pod]pod2man +podxform : [.lib.pod]pod2text.com [.lib.pod]pod2html.com [.lib.pod]pod2latex.com [.lib.pod]pod2man.com + @ $(NOOP) +x2p : [.x2p]a2p$(E) [.x2p]s2p.com [.x2p]find2perl.com @ $(NOOP) pod1 = [.lib.pod]perl.pod [.lib.pod]perlapio.pod [.lib.pod]perlbook.pod [.lib.pod]perlbot.pod [.lib.pod]perlcall.pod @@ -498,50 +502,59 @@ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]S [.lib.pod]perldoc : [.utils]perldoc.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) - Copy/Log [.utils]perldoc $(MMS$TARGET) + Copy/Log [.utils]perldoc.com $(MMS$TARGET) [.lib.ExtUtils]Miniperl.pm : Minimod.PL miniperlmain.c $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) >$(MMS$TARGET) -[.utils]c2ph : [.utils]c2ph.PL $(ARCHDIR)Config.pm +[.utils]c2ph.com : [.utils]c2ph.PL $(ARCHDIR)Config.pm + $(MINIPERL) $(MMS$SOURCE) + +[.utils]h2ph.com : [.utils]h2ph.PL $(ARCHDIR)Config.pm + $(MINIPERL) $(MMS$SOURCE) + +[.utils]h2xs.com : [.utils]h2xs.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) -[.utils]h2ph : [.utils]h2ph.PL $(ARCHDIR)Config.pm +[.lib]perlbug.com : [.utils]perlbug.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) + Rename/Log [.utils]perlbug.com $(MMS$TARGET) -[.utils]h2xs : [.utils]h2xs.PL $(ARCHDIR)Config.pm +[.utils]pl2pm.com : [.utils]pl2pm.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) -[.lib]perlbug : [.utils]perlbug.PL $(ARCHDIR)Config.pm +[.lib]splain.com : [.utils]splain.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.utils]perlbug $(MMS$TARGET) + Rename/Log [.utils]splain.com $(MMS$TARGET) -[.utils]pl2pm : [.utils]pl2pm.PL $(ARCHDIR)Config.pm +[.x2p]find2perl.com : [.x2p]find2perl.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) -[.lib]splain : [.utils]splain.PL $(ARCHDIR)Config.pm +[.x2p]s2p.com : [.x2p]s2p.PL $(ARCHDIR)Config.pm $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.utils]splain $(MMS$TARGET) -[.lib.pod]pod2html : [.pod]pod2html.PL $(ARCHDIR)Config.pm +[.x2p]$(DBG)a2p$(E) : [.x2p]a2p$(O), [.x2p]hash$(O), [.x2p]str$(O), [.x2p]util$(O), [.x2p]walk$(O) + Link $(LINKFLAGS) /Exe=$(MMS$TARGET) $(MMS$SOURCE_LIST) $(CRTLOPTS) + +[.lib.pod]pod2html.com : [.pod]pod2html.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.pod]pod2html $(MMS$TARGET) + Rename/Log [.pod]pod2html.com $(MMS$TARGET) -[.lib.pod]pod2latex : [.pod]pod2latex.PL $(ARCHDIR)Config.pm +[.lib.pod]pod2latex.com : [.pod]pod2latex.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.pod]pod2latex $(MMS$TARGET) + Rename/Log [.pod]pod2latex.com $(MMS$TARGET) -[.lib.pod]pod2man : [.pod]pod2man.PL $(ARCHDIR)Config.pm +[.lib.pod]pod2man.com : [.pod]pod2man.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.pod]pod2man $(MMS$TARGET) + Rename/Log [.pod]pod2man.com $(MMS$TARGET) -[.lib.pod]pod2text : [.pod]pod2text.PL $(ARCHDIR)Config.pm +[.lib.pod]pod2text.com : [.pod]pod2text.PL $(ARCHDIR)Config.pm @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] $(MINIPERL) $(MMS$SOURCE) - Rename/Log [.pod]pod2text $(MMS$TARGET) + Rename/Log [.pod]pod2text.com $(MMS$TARGET) preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm $(SOCKPM) @ Write Sys$Output "Autosplitting Perl library . . ." @@ -749,6 +762,9 @@ perly$(O) : perly.c, perly.h, $(h) $(CC) $(CFLAGS) $(MMS$SOURCE) .endif +[.t.lib]vmsfspec.t : [.vms.ext]filespec.t + Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET) + test : all - @[.VMS]Test.Com "$(E)" @@ -1533,6 +1549,42 @@ globals$(O) : scope.h globals$(O) : sv.h globals$(O) : vmsish.h globals$(O) : util.h +[.x2p]a2p$(O) : [.x2p]a2p.c +[.x2p]a2p$(O) : [.x2p]a2py.c +[.x2p]a2p$(O) : [.x2p]INTERN.h +[.x2p]a2p$(O) : [.x2p]a2p.h +[.x2p]a2p$(O) : [.x2p]hash.h +[.x2p]a2p$(O) : [.x2p]str.h +[.x2p]a2p$(O) : handy.h +[.x2p]hash$(O) : [.x2p]hash.c +[.x2p]hash$(O) : [.x2p]EXTERN.h +[.x2p]hash$(O) : [.x2p]a2p.h +[.x2p]hash$(O) : [.x2p]hash.h +[.x2p]hash$(O) : [.x2p]str.h +[.x2p]hash$(O) : handy.h +[.x2p]hash$(O) : [.x2p]util.h +[.x2p]str$(O) : [.x2p]str.c +[.x2p]str$(O) : [.x2p]EXTERN.h +[.x2p]str$(O) : [.x2p]a2p.h +[.x2p]str$(O) : [.x2p]hash.h +[.x2p]str$(O) : [.x2p]str.h +[.x2p]str$(O) : handy.h +[.x2p]str$(O) : [.x2p]util.h +[.x2p]util$(O) : [.x2p]util.c +[.x2p]util$(O) : [.x2p]EXTERN.h +[.x2p]util$(O) : [.x2p]a2p.h +[.x2p]util$(O) : [.x2p]hash.h +[.x2p]util$(O) : [.x2p]str.h +[.x2p]util$(O) : handy.h +[.x2p]util$(O) : [.x2p]INTERN.h +[.x2p]util$(O) : [.x2p]util.h +[.x2p]walk$(O) : [.x2p]walk.c +[.x2p]walk$(O) : [.x2p]EXTERN.h +[.x2p]walk$(O) : [.x2p]a2p.h +[.x2p]walk$(O) : [.x2p]hash.h +[.x2p]walk$(O) : [.x2p]str.h +[.x2p]walk$(O) : handy.h +[.x2p]walk$(O) : [.x2p]util.h .endif # !LINK_ONLY config.h : [.vms]config.vms @@ -1603,7 +1655,7 @@ clean : tidy Set Default [--] .endif - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt - - If F$Search("*$(O);*") .nes."" Then Delete/NoConfirm/Log *$(O);* + - If F$Search("[...]*$(O);*") .nes."" Then Delete/NoConfirm/Log [...]*$(O);* - If F$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;* - If F$Search("Config.SH").nes."" Then Delete/NoConfirm/Log Config.SH;* - If F$Search(F$Parse("Sys$Disk:[]","$(SOCKH)")).nes."" Then Delete/NoConfirm/Log $(SOCKH);* @@ -1650,10 +1702,11 @@ realclean : clean - If F$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;* - If F$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;* - If F$Search("[.utils]*.").nes."" Then Delete/NoConfirm/Log [.utils]*.;*/Exclude=Makefile. + - If F$Search("[.x2p]*.").nes."" Then Delete/NoConfirm/Log [.x2p]*.;*/Exclude=Makefile. - If F$Search("[.lib.pod]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pod]*.pod;* - If F$Search("[.lib.pod]perldoc.").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.;* - - If F$Search("[.lib.pod]pod2*.").nes."" Then Delete/NoConfirm/Log [.lib.pod]pod2*.;* - - If F$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);* + - If F$Search("[.lib.pod]pod2*.com").nes."" Then Delete/NoConfirm/Log [.lib.pod]pod2*.com;* + - If F$Search("[...]*$(E)").nes."" Then Delete/NoConfirm/Log [...]*$(E);* cleansrc : clean - If F$Search("*.C;-1").nes."" Then Purge/NoConfirm/Log *.C diff --git a/vms/fndvers.com b/vms/fndvers.com index f1ddc03eca..2e49ae6fcb 100644 --- a/vms/fndvers.com +++ b/vms/fndvers.com @@ -58,6 +58,11 @@ $ If .not.teststs Then Exit teststs $! $ If teststs.ne.1 ! current values in config.vms are appropriate $ Then +$ token = """""""""VMS_''arch' /**/""""""""" +$ Call update_file "''p2'" "#define ARCHNAME" "''token'" +$ teststs = $Status +$ If .not.teststs Then Exit teststs +$! $ token = """""""""/perl_root/lib/VMS_''arch'"""""""" /**/" $ Call update_file "''p2'" "#define OLDARCHLIB_EXP" "''token'" $ If .not.$Status Then Exit $Status diff --git a/vms/genconfig.pl b/vms/genconfig.pl index 97679d5e48..3680147e47 100644 --- a/vms/genconfig.pl +++ b/vms/genconfig.pl @@ -102,10 +102,9 @@ installprivlib='$installprivlib' installarchlib='$installarchlib' installsitelib='$installsitelib' installsitearch='$installsitearch' -startperl='\$ perl 'f\$env("procedure")' - ! q# - 'p1' 'p2' 'p3' 'p4' 'p5' 'p6' 'p7' 'p8' -$ exit !# -' +path_sep='|' +startperl='\$ perl 'f\$env("procedure")' 'p1' 'p2' 'p3' 'p4' 'p5' 'p6' 'p7' 'p8' ! +$ exit++ + ++$status != 0 and $exit = $status = undef; EndOfIntro foreach (@ARGV) { diff --git a/vms/perly_c.vms b/vms/perly_c.vms index 947d77311d..d6d35bb610 100644 --- a/vms/perly_c.vms +++ b/vms/perly_c.vms @@ -1240,7 +1240,7 @@ dEXT int yyerrflag; dEXT int yychar; dEXT YYSTYPE yyval; dEXT YYSTYPE yylval; -#line 626 "perly.y" +#line 624 "perly.y" /* PROGRAM */ #line 1315 "perly.c" #define YYABORT goto yyabort @@ -1707,317 +1707,315 @@ case 52: break; case 53: #line 280 "perly.y" -{ yyval.ival = start_subparse(); } +{ yyval.ival = start_subparse(FALSE, 0); } break; case 54: #line 284 "perly.y" -{ yyval.ival = start_subparse(); - CvANON_on(compcv); } +{ yyval.ival = start_subparse(FALSE, CVf_ANON); } break; case 55: -#line 289 "perly.y" -{ yyval.ival = start_subparse(); - CvFORMAT_on(compcv); } +#line 288 "perly.y" +{ yyval.ival = start_subparse(TRUE, 0); } break; case 56: -#line 293 "perly.y" +#line 291 "perly.y" { char *name = SvPVx(((SVOP*)yyvsp[0].opval)->op_sv, na); if (strEQ(name, "BEGIN") || strEQ(name, "END")) CvUNIQUE_on(compcv); yyval.opval = yyvsp[0].opval; } break; case 57: -#line 300 "perly.y" +#line 298 "perly.y" { yyval.opval = Nullop; } break; case 59: -#line 304 "perly.y" +#line 302 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 60: -#line 305 "perly.y" +#line 303 "perly.y" { yyval.opval = Nullop; expect = XSTATE; } break; case 61: -#line 309 "perly.y" +#line 307 "perly.y" { package(yyvsp[-1].opval); } break; case 62: -#line 311 "perly.y" +#line 309 "perly.y" { package(Nullop); } break; case 63: -#line 315 "perly.y" +#line 313 "perly.y" { CvUNIQUE_on(compcv); /* It's a BEGIN {} */ } break; case 64: -#line 317 "perly.y" +#line 315 "perly.y" { utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); } break; case 65: -#line 321 "perly.y" +#line 319 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 66: -#line 323 "perly.y" +#line 321 "perly.y" { yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 68: -#line 328 "perly.y" +#line 326 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 69: -#line 330 "perly.y" +#line 328 "perly.y" { yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); } break; case 71: -#line 335 "perly.y" +#line 333 "perly.y" { yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED, prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); } break; case 72: -#line 338 "perly.y" +#line 336 "perly.y" { yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED, prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); } break; case 73: -#line 341 "perly.y" +#line 339 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval), newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); } break; case 74: -#line 346 "perly.y" +#line 344 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval), newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); } break; case 75: -#line 351 "perly.y" +#line 349 "perly.y" { yyval.opval = convert(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval), newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); } break; case 76: -#line 356 "perly.y" +#line 354 "perly.y" { yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 77: -#line 358 "perly.y" +#line 356 "perly.y" { yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 78: -#line 360 "perly.y" +#line 358 "perly.y" { yyvsp[0].opval = newANONSUB(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 79: -#line 362 "perly.y" +#line 360 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); } break; case 82: -#line 372 "perly.y" +#line 370 "perly.y" { yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); } break; case 83: -#line 374 "perly.y" +#line 372 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 84: -#line 376 "perly.y" +#line 374 "perly.y" { if (yyvsp[-1].ival != OP_REPEAT) scalar(yyvsp[-2].opval); yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); } break; case 85: -#line 380 "perly.y" +#line 378 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 86: -#line 382 "perly.y" +#line 380 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 87: -#line 384 "perly.y" +#line 382 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 88: -#line 386 "perly.y" +#line 384 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 89: -#line 388 "perly.y" +#line 386 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 90: -#line 390 "perly.y" +#line 388 "perly.y" { yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); } break; case 91: -#line 392 "perly.y" +#line 390 "perly.y" { yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));} break; case 92: -#line 394 "perly.y" +#line 392 "perly.y" { yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 93: -#line 396 "perly.y" +#line 394 "perly.y" { yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); } break; case 94: -#line 398 "perly.y" +#line 396 "perly.y" { yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); } break; case 95: -#line 400 "perly.y" +#line 398 "perly.y" { yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); } break; case 96: -#line 403 "perly.y" +#line 401 "perly.y" { yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); } break; case 97: -#line 405 "perly.y" +#line 403 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 98: -#line 407 "perly.y" +#line 405 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 99: -#line 409 "perly.y" +#line 407 "perly.y" { yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));} break; case 100: -#line 411 "perly.y" +#line 409 "perly.y" { yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); } break; case 101: -#line 413 "perly.y" +#line 411 "perly.y" { yyval.opval = newUNOP(OP_POSTINC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTINC)); } break; case 102: -#line 416 "perly.y" +#line 414 "perly.y" { yyval.opval = newUNOP(OP_POSTDEC, 0, mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); } break; case 103: -#line 419 "perly.y" +#line 417 "perly.y" { yyval.opval = newUNOP(OP_PREINC, 0, mod(scalar(yyvsp[0].opval), OP_PREINC)); } break; case 104: -#line 422 "perly.y" +#line 420 "perly.y" { yyval.opval = newUNOP(OP_PREDEC, 0, mod(scalar(yyvsp[0].opval), OP_PREDEC)); } break; case 105: -#line 425 "perly.y" +#line 423 "perly.y" { yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); } break; case 106: -#line 427 "perly.y" +#line 425 "perly.y" { yyval.opval = sawparens(yyvsp[-1].opval); } break; case 107: -#line 429 "perly.y" +#line 427 "perly.y" { yyval.opval = sawparens(newNULLLIST()); } break; case 108: -#line 431 "perly.y" +#line 429 "perly.y" { yyval.opval = newANONLIST(yyvsp[-1].opval); } break; case 109: -#line 433 "perly.y" +#line 431 "perly.y" { yyval.opval = newANONLIST(Nullop); } break; case 110: -#line 435 "perly.y" +#line 433 "perly.y" { yyval.opval = newANONHASH(yyvsp[-2].opval); } break; case 111: -#line 437 "perly.y" +#line 435 "perly.y" { yyval.opval = newANONHASH(Nullop); } break; case 112: -#line 439 "perly.y" +#line 437 "perly.y" { yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); } break; case 113: -#line 441 "perly.y" +#line 439 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 114: -#line 443 "perly.y" +#line 441 "perly.y" { yyval.opval = newBINOP(OP_GELEM, 0, newGVREF(0,yyvsp[-4].opval), yyvsp[-2].opval); } break; case 115: -#line 445 "perly.y" +#line 443 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 116: -#line 447 "perly.y" +#line 445 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } break; case 117: -#line 449 "perly.y" +#line 447 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-4].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 118: -#line 453 "perly.y" +#line 451 "perly.y" { assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-3].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 119: -#line 457 "perly.y" +#line 455 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 120: -#line 459 "perly.y" +#line 457 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 121: -#line 461 "perly.y" +#line 459 "perly.y" { yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} break; case 122: -#line 463 "perly.y" +#line 461 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 123: -#line 466 "perly.y" +#line 464 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-5].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 124: -#line 471 "perly.y" +#line 469 "perly.y" { assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-4].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 125: -#line 476 "perly.y" +#line 474 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } break; case 126: -#line 478 "perly.y" +#line 476 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } break; case 127: -#line 480 "perly.y" +#line 478 "perly.y" { yyval.opval = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, @@ -2025,7 +2023,7 @@ case 127: ref(yyvsp[-3].opval, OP_ASLICE))); } break; case 128: -#line 486 "perly.y" +#line 484 "perly.y" { yyval.opval = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -2034,37 +2032,37 @@ case 128: expect = XOPERATOR; } break; case 129: -#line 493 "perly.y" +#line 491 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 130: -#line 495 "perly.y" +#line 493 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; case 131: -#line 497 "perly.y" +#line 495 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); } break; case 132: -#line 499 "perly.y" +#line 497 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); } break; case 133: -#line 502 "perly.y" +#line 500 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 134: -#line 505 "perly.y" +#line 503 "perly.y" { yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } break; case 135: -#line 507 "perly.y" +#line 505 "perly.y" { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; case 136: -#line 509 "perly.y" +#line 507 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, @@ -2074,7 +2072,7 @@ case 136: )),Nullop)); dep();} break; case 137: -#line 517 "perly.y" +#line 515 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, @@ -2085,150 +2083,150 @@ case 137: )))); dep();} break; case 138: -#line 526 "perly.y" +#line 524 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();} break; case 139: -#line 530 "perly.y" +#line 528 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, yyvsp[-1].opval, scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();} break; case 140: -#line 535 "perly.y" +#line 533 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); hints |= HINT_BLOCK_SCOPE; } break; case 141: -#line 538 "perly.y" +#line 536 "perly.y" { yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; case 142: -#line 540 "perly.y" +#line 538 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 143: -#line 542 "perly.y" +#line 540 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 144: -#line 544 "perly.y" +#line 542 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 145: -#line 546 "perly.y" +#line 544 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 146: -#line 548 "perly.y" +#line 546 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 147: -#line 551 "perly.y" +#line 549 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 148: -#line 553 "perly.y" +#line 551 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, 0); } break; case 149: -#line 555 "perly.y" +#line 553 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[0].opval)); } break; case 150: -#line 558 "perly.y" +#line 556 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; case 151: -#line 560 "perly.y" +#line 558 "perly.y" { yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 152: -#line 562 "perly.y" +#line 560 "perly.y" { yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; case 153: -#line 564 "perly.y" +#line 562 "perly.y" { yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; case 156: -#line 570 "perly.y" +#line 568 "perly.y" { yyval.opval = Nullop; } break; case 157: -#line 572 "perly.y" +#line 570 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 158: -#line 576 "perly.y" +#line 574 "perly.y" { yyval.opval = Nullop; } break; case 159: -#line 578 "perly.y" +#line 576 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 160: -#line 580 "perly.y" +#line 578 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 161: -#line 583 "perly.y" +#line 581 "perly.y" { yyval.ival = 0; } break; case 162: -#line 584 "perly.y" +#line 582 "perly.y" { yyval.ival = 1; } break; case 163: -#line 588 "perly.y" +#line 586 "perly.y" { in_my = 0; yyval.opval = my(yyvsp[0].opval); } break; case 164: -#line 592 "perly.y" +#line 590 "perly.y" { yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); } break; case 165: -#line 596 "perly.y" +#line 594 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; case 166: -#line 600 "perly.y" +#line 598 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 167: -#line 604 "perly.y" +#line 602 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; case 168: -#line 608 "perly.y" +#line 606 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 169: -#line 612 "perly.y" +#line 610 "perly.y" { yyval.opval = newGVREF(0,yyvsp[0].opval); } break; case 170: -#line 616 "perly.y" +#line 614 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 171: -#line 618 "perly.y" +#line 616 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 172: -#line 620 "perly.y" +#line 618 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 173: -#line 623 "perly.y" +#line 621 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2217 "perly.c" +#line 2215 "perly.c" } yyssp -= yym; yystate = *yyssp; diff --git a/vms/vmsish.h b/vms/vmsish.h index 7fec438628..fa23571d47 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -51,7 +51,7 @@ #include <unixio.h> #include <unixlib.h> #include <file.h> /* it's not <sys/file.h>, so don't use I_SYS_FILE */ -#ifdef __DECC +#if defined(__DECC) && defined(__DECC_VER) && __DECC_VER > 20000000 # include <unistd.h> /* DECC has this; VAXC and gcc don't */ #endif @@ -158,6 +158,7 @@ /* Macros to set errno using the VAX thread-safe calls, if present */ #if (defined(__DECC) || defined(__DECCXX)) && !defined(__ALPHA) # define set_errno(v) (cma$tis_errno_set_value(v)) + void cma$tis_errno_set_value(int __value); /* missing in some errno.h */ # define set_vaxc_errno(v) (vaxc$errno = (v)) #else # define set_errno(v) (errno = (v)) @@ -9,7 +9,11 @@ */ #define VOIDUSED 1 -#include "../config.h" +#ifdef VMS +# include "config.h" +#else +# include "../config.h" +#endif #if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) # define STANDARD_C 1 @@ -101,7 +105,7 @@ #else # if defined(VMS) # define NO_PERL_TYPEDEFS -# include "[-]vmsish.h" +# include "vmsish.h" # endif #endif @@ -113,7 +117,11 @@ char *strchr(), *strrchr(); char *strcpy(), *strcat(); #endif /* ! STANDARD_C */ -#include "../handy.h" +#ifdef VMS +# include "handy.h" +#else +# include "../handy.h" +#endif #undef Nullfp #define Nullfp Null(FILE*) diff --git a/x2p/find2perl.PL b/x2p/find2perl.PL index 2ffc338075..c23fc923a8 100644 --- a/x2p/find2perl.PL +++ b/x2p/find2perl.PL @@ -14,6 +14,7 @@ use File::Basename qw(&basename &dirname); # This is so that make depend always knows where to find PL derivatives. chdir dirname($0); $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; diff --git a/x2p/s2p.PL b/x2p/s2p.PL index 7564d51d99..73f67872de 100644 --- a/x2p/s2p.PL +++ b/x2p/s2p.PL @@ -14,6 +14,7 @@ use File::Basename qw(&basename &dirname); # This is so that make depend always knows where to find PL derivatives. chdir dirname($0); $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; |