diff options
| -rw-r--r-- | Changes | 555 | ||||
| -rwxr-xr-x | Configure | 54 | ||||
| -rw-r--r-- | INSTALL | 7 | ||||
| -rw-r--r-- | MANIFEST | 3 | ||||
| -rw-r--r-- | README.vms | 19 | ||||
| -rwxr-xr-x[-rw-r--r--] | config_h.SH | 22 | ||||
| -rwxr-xr-x | configpm | 6 | ||||
| -rw-r--r--[-rwxr-xr-x] | configure | 0 | ||||
| -rw-r--r-- | cv.h | 25 | ||||
| -rw-r--r-- | doio.c | 4 | ||||
| -rw-r--r-- | dosish.h | 1 | ||||
| -rw-r--r-- | ext/FileHandle/FileHandle.pm | 20 | ||||
| -rw-r--r-- | ext/NDBM_File/NDBM_File.pm | 18 | ||||
| -rw-r--r-- | ext/NDBM_File/hints/svr4.pl | 4 | ||||
| -rw-r--r-- | ext/ODBM_File/ODBM_File.pm | 18 | ||||
| -rw-r--r-- | ext/SDBM_File/SDBM_File.pm | 18 | ||||
| -rw-r--r-- | ext/Safe/Safe.xs | 15 | ||||
| -rw-r--r-- | gv.c | 39 | ||||
| -rw-r--r-- | gv.h | 59 | ||||
| -rw-r--r-- | hints/aix.sh | 2 | ||||
| -rw-r--r-- | hints/hpux.sh | 2 | ||||
| -rw-r--r-- | hints/linux.sh | 1 | ||||
| -rw-r--r-- | hints/os2.sh | 4 | ||||
| -rw-r--r-- | hints/sco.sh | 28 | ||||
| -rw-r--r-- | hints/svr4.sh | 6 | ||||
| -rw-r--r--[-rwxr-xr-x] | installman | 0 | ||||
| -rw-r--r-- | lib/ExtUtils/MM_OS2.pm | 4 | ||||
| -rw-r--r-- | lib/ExtUtils/MM_Unix.pm | 24 | ||||
| -rw-r--r-- | lib/ExtUtils/MM_VMS.pm | 474 | ||||
| -rw-r--r-- | lib/ExtUtils/MakeMaker.pm | 15 | ||||
| -rw-r--r-- | lib/ExtUtils/Mksymlists.pm | 6 | ||||
| -rw-r--r-- | lib/File/Copy.pm | 11 | ||||
| -rw-r--r-- | lib/File/Path.pm | 14 | ||||
| -rw-r--r-- | lib/I18N/Collate.pm | 2 | ||||
| -rw-r--r-- | lib/Math/BigFloat.pm | 127 | ||||
| -rw-r--r-- | lib/Math/BigInt.pm | 123 | ||||
| -rw-r--r-- | lib/Math/Complex.pm | 65 | ||||
| -rw-r--r-- | lib/Shell.pm | 49 | ||||
| -rw-r--r-- | lib/Text/ParseWords.pm | 128 | ||||
| -rw-r--r-- | lib/lib.pm | 2 | ||||
| -rw-r--r--[-rwxr-xr-x] | makeaperl.SH | 0 | ||||
| -rw-r--r-- | mg.c | 6 | ||||
| -rw-r--r-- | op.c | 30 | ||||
| -rw-r--r-- | opcode.h | 4 | ||||
| -rwxr-xr-x | opcode.pl | 4 | ||||
| -rw-r--r-- | os2/diff.Makefile | 4 | ||||
| -rw-r--r-- | os2/diff.exec | 77 | ||||
| -rw-r--r-- | os2/os2ish.h | 2 | ||||
| -rw-r--r-- | patchlevel.h | 1 | ||||
| -rw-r--r-- | perl.c | 98 | ||||
| -rw-r--r-- | perl.h | 4 | ||||
| -rw-r--r-- | perl_exp.SH | 1 | ||||
| -rw-r--r-- | perly.c | 77 | ||||
| -rw-r--r-- | perly.c.diff | 18 | ||||
| -rw-r--r-- | perly.y | 3 | ||||
| -rw-r--r-- | pod/perldiag.pod | 13 | ||||
| -rw-r--r-- | pod/perlfunc.pod | 15 | ||||
| -rw-r--r-- | pod/perlop.pod | 3 | ||||
| -rw-r--r-- | pod/perlre.pod | 1 | ||||
| -rw-r--r-- | pod/perlrun.pod | 8 | ||||
| -rw-r--r-- | pod/perlxs.pod | 21 | ||||
| -rw-r--r-- | pp.c | 5 | ||||
| -rw-r--r-- | pp_ctl.c | 20 | ||||
| -rw-r--r-- | pp_hot.c | 6 | ||||
| -rw-r--r-- | pp_sys.c | 11 | ||||
| -rw-r--r-- | sv.c | 96 | ||||
| -rw-r--r-- | sv.h | 13 | ||||
| -rw-r--r--[-rwxr-xr-x] | t/comp/cpp.aux | 0 | ||||
| -rw-r--r-- | t/harness | 15 | ||||
| -rw-r--r--[-rwxr-xr-x] | t/lib/dirhand.t | 0 | ||||
| -rw-r--r--[-rwxr-xr-x] | t/lib/filehand.t | 0 | ||||
| -rw-r--r-- | toke.c | 37 | ||||
| -rw-r--r-- | unixish.h | 1 | ||||
| -rw-r--r-- | util.c | 22 | ||||
| -rw-r--r-- | utils/perlbug.PL | 64 | ||||
| -rw-r--r-- | vms/descrip.mms | 87 | ||||
| -rw-r--r-- | vms/ext/Filespec.pm | 26 | ||||
| -rw-r--r-- | vms/gen_shrfls.pl | 21 | ||||
| -rw-r--r-- | vms/genconfig.pl | 10 | ||||
| -rw-r--r-- | vms/perlvms.pod | 100 | ||||
| -rw-r--r-- | vms/perly_c.vms | 77 | ||||
| -rw-r--r-- | vms/vms.c | 275 | ||||
| -rw-r--r-- | vms/vmsish.h | 4 |
83 files changed, 2240 insertions, 1014 deletions
@@ -2,9 +2,13 @@ Version 5.002 ------------- -Nearly all the changes for 5.001 were bug fixes of one variety or another, -so here's the bug list, along with the "resolution" for each of them. If -you wish to correspond about any of them, please include the bug number. +The main enhancement to the Perl core was the addition of prototypes. +Many of the modules that come with Perl have been extensively upgraded. + +Other than that, nearly all the changes for 5.002 were bug fixes of one +variety or another, so here's the bug list, along with the "resolution" +for each of them. If you wish to correspond about any of them, please +include the bug number (if any). Added APPLLIB_EXP for embedded perl library support. Files patched: perl.c @@ -12,88 +16,21 @@ Files patched: perl.c Couldn't define autoloaded routine by assignment to typeglob. Files patched: pp_hot.c sv.c -NETaa13399: Andy patches. +NETaa13525: Tiny patch to fix installman -n From: Larry Wall -Files patched: MANIFEST +Files patched: installman -NETaa13399: Andy's patch 1m -Files patched: Configure MANIFEST Makefile.SH embed.h embed.pl - ext/GDBM_File/GDBM_File.xs global.sym hints/freebsd.sh installman - installperl interp.sym keywords.h keywords.pl lib/Exporter.pm - lib/ExtUtils/MakeMaker.pm lib/ExtUtils/xsubpp op.c perl.c perl.h perldoc.SH - pod/perl.pod pod/pod2html.SH pp.c pp_ctl.c pp_ctl.c pp_hot.c proto.h - regcomp.c regcomp.h regexec.c toke.c x2p/util.c x2p/util.h - -NETaa13399: Andy's patch.1l -Files patched: Changes.Conf Configure Makefile.SH README README.vms c2ph.SH - config_H config_h.SH configpm configure doio.c embed.h - ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs ext/DynaLoader/DynaLoader.pm - ext/DynaLoader/Makefile.PL ext/DynaLoader/README ext/DynaLoader/dl_dlopen.xs - ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs ext/GDBM_File/GDBM_File.pm - ext/GDBM_File/GDBM_File.xs ext/NDBM_File/hints/solaris.pl - ext/ODBM_File/Makefile.PL ext/ODBM_File/hints/sco.pl - ext/ODBM_File/hints/solaris.pl ext/ODBM_File/hints/svr4.pl - ext/POSIX/POSIX.pm ext/POSIX/POSIX.xs ext/SDBM_File/sdbm/sdbm.c - ext/Socket/Socket.pm global.sym h2ph.SH h2xs.SH handy.h hints/README.hints - hints/apollo.sh hints/aux.sh hints/cxux.sh hints/dynix.sh hints/epix.sh - hints/freebsd.sh hints/hpux_9.sh hints/irix_4.sh hints/irix_5.sh - hints/irix_6.sh hints/isc.sh hints/linux.sh hints/netbsd.sh hints/next_3.sh - hints/next_3_0.sh hints/powerunix.sh hints/sco_3.sh hints/titanos.sh - installman installperl lib/AnyDBM_File.pm lib/AutoLoader.pm lib/AutoSplit.pm - lib/Benchmark.pm lib/Carp.pm lib/Cwd.pm lib/English.pm lib/Exporter.pm - lib/ExtUtils/Liblist.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Manifest.pm - lib/ExtUtils/Mkbootstrap.pm lib/ExtUtils/xsubpp lib/File/Basename.pm - lib/File/CheckTree.pm lib/File/Find.pm lib/FileHandle.pm lib/Getopt/Long.pm - lib/Getopt/Std.pm lib/I18N/Collate.pm lib/IPC/Open2.pm lib/IPC/Open3.pm - lib/Net/Ping.pm lib/Term/Complete.pm lib/Text/Abbrev.pm lib/Text/Tabs.pm - lib/ftp.pl lib/getcwd.pl lib/integer.pm lib/less.pm lib/sigtrap.pm - lib/strict.pm lib/subs.pm makeaperl.SH makedepend.SH myconfig perl.c perl.h - perldoc.SH pod/Makefile pod/perl.pod pod/perlbot.pod pod/perlcall.pod - pod/perlfunc.pod pod/perlguts.pod pod/perlop.pod pod/perlre.pod - pod/perlxs.pod pod/pod2html.SH pod/pod2latex.SH pod/pod2man.SH pp_ctl.c - pp_hot.c pp_sys.c proto.h scope.c sv.c sv.h t/comp/cpp.aux t/comp/cpp.t - t/op/misc.t toke.c unixish.h util.c vms/config.vms vms/ext/MM_VMS.pm - vms/ext/VMS/stdio/stdio.xs vms/perlvms.pod vms/vms.c x2p/Makefile.SH - x2p/find2perl.SH x2p/s2p.SH x2p/str.c - -NETaa13399: Jumbo Configure patch (and patch 1) -Files patched: Changes.Conf - -NETaa13399: Jumbo Configure patch (and patch 1) -Files patched: Configure INSTALL MANIFEST Makefile.SH README config_H - config_h.SH configure embed.h ext/Fcntl/Fcntl.xs ext/ODBM_File/ODBM_File.xs - h2xs.SH hints/aix.sh hints/hpux_9.sh hints/isc.sh hints/isc_2.sh - hints/solaris_2.sh hints/unicos.sh hints/utekv.sh lib/ExtUtils/MakeMaker.pm - makedepend.SH t/README x2p/a2p.h - -NETaa13399: Jumbo Configure patch (patches 2 and 3) -Files patched: Configure INSTALL config_h.SH embed.h ext/Fcntl/Fcntl.xs - ext/POSIX/POSIX.xs global.sym mg.c perl.h proto.h +NETaa13525: de-documented \v +Files patched: pod/perlop.pod pod/perlre.pod NETaa13525: doc changes -From: Larry Wall Files patched: pod/perlop.pod pod/perltrap.pod -NETaa13525: random cleanup -Files patched: Configure MANIFEST Makefile.SH cop.h embed.h global.sym - hints/dec_osf.sh hv.c lib/dotsh.pl mg.c op.c op.c op.h perl.c perl.c perly.c - perly.c perly.c.diff perly.c.diff perly.h perly.y pod/perl.pod - pod/perldiag.pod pod/perlfunc.pod pod/perlfunc.pod pod/perlfunc.pod - pod/perlfunc.pod pod/perlop.pod pod/perlre.pod pod/perltrap.pod - pod/perlxs.pod pod/perlxs.pod pp_ctl.c pp_ctl.c pp_hot.c pp_sys.c proto.h - regcomp.c regexec.c sv.c sv.c sv.c toke.c vms/perly_c.vms vms/perly_h.vms - -NETaa13540: VMS stuff -From: Larry Wall -Files patched: EXTERN.h INTERN.h MANIFEST Makefile.SH README.vms av.c embed.h - ext/Socket/Socket.pm ext/Socket/Socket.xs global.sym gv.c lib/AutoSplit.pm - lib/ExtUtils/MakeMaker.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Manifest.pm - lib/ExtUtils/xsubpp lib/File/Find.pm lib/File/Path.pm lib/lib.pm perl.c - perl.h pp_ctl.c pp_sys.c proto.h run.c sv.c vms/Makefile vms/Makefile - vms/config.vms vms/descrip.mms vms/descrip.mms vms/ext/MM_VMS.pm - vms/gen_shrfls.pl vms/perlvms.pod vms/perly_c.vms vms/perly_h.vms - vms/sockadapt.c vms/sockadapt.h vms/test.com vms/vms.c vms/vms_yfix.pl - vms/vmsish.h +NETaa13525: perlxs update from Dean Roehrich +Files patched: pod/perlxs.pod + +NETaa13525: rename powerunix to powerux +Files patched: MANIFEST hints/powerux.sh NETaa13540: VMS uses CLK_TCK for HZ Files patched: pp_sys.c @@ -116,6 +53,11 @@ Files patched: x2p/walk.c Consolidated the various declarations and made them consistent with the actual definitions. +NETaa13724: -MPackage=args patch +From: Tim Bunce +Files patched: perl.c pod/perlrun.pod + Added in the -MPackage=args patch too. + NETaa13729: order-of-evaluation dependency in scope.c on leaving REGCONTEXT From: "Jason Shirk" Files patched: scope.c @@ -378,11 +320,6 @@ Files patched: embed.h global.sym op.h pp_ctl.c proto.h The expression inside the return was taking its context from the immediately surrounding block rather than the innermost surrounding subroutine call. -NETaa13794: TieHash produces ${pack} warnings -From: Stanley Donald Capelik x74321 24-5200 021876 -Files patched: lib/TieHash.pm - Changed $pack to $pkg. - NETaa13797: could modify sv_undef through auto-vivification From: Ilya Zakharevich Files patched: pp.c @@ -429,6 +366,11 @@ Files patched: pod/perlop.pod returning FALSE. +NETaa13986: split ignored /m pattern modifier +From: Winfried Koenig +Files patched: pp.c + Fixed to work like m// and s///. + NETaa13992: regexp comments not seen after + in non-extended regexp From: Mark Knutsen Files patched: regcomp.c @@ -710,6 +652,15 @@ Files patched: Makefile.SH op.c op.c perly.c perly.c.diff perly.h perly.y proto. Larry +NETaa14422: couldn't take reference of a prototyped function +Files patched: op.c + (same) + +NETaa14423: use didn't allow expressions involving the scratch pad +From: Graham Barr +Files patched: op.c perly.c perly.c.diff perly.y proto.h vms/perly_c.vms + Applied suggested patch. + NETaa14444: lexical scalar didn't autovivify From: Gurusamy Sarathy Files patched: op.c pp_hot.c @@ -763,6 +714,11 @@ From: Gurusamy Sarathy Files patched: op.c pp.c pp_hot.c regexec.c sv.c toke.c Applied most recent suggested patches. +NETaa14537: select() can return too soon +From: Matt Kimball +Also: Andreas Gustafsson +Files patched: pp_sys.c + NETaa14538: method calls were treated like do {} under loop modifiers From: Ilya Zakharevich Files patched: perly.c perly.y @@ -776,6 +732,15 @@ Files patched: Todo op.c pp_ctl.c pp_hot.c directly through the array, and can detect the implicit shift from referencing <>. +NETaa14541: new version of perlbug +From: Kenneth Albanowski +Files patched: README pod/perl.pod utils/perlbug.PL + Brought it up to version 1.09. + +NETaa14541: perlbug 1.11 +Files patched: utils/perlbug.PL + (same) + NETaa14548: magic sets didn't check private OK bits From: W. Bradley Rubenstein Files patched: mg.c @@ -819,17 +784,31 @@ NETaa14582: sort was letting unsortable values through to comparison routine Files patched: pp_ctl.c (same) +NETaa14585: globs in pad space weren't properly cleaned up +From: Gurusamy Sarathy +Files patched: op.c pp.c pp_hot.c sv.c + Applied suggested patch. + NETaa14614: now does dbmopen with perl_eval_sv() From: The Man Files patched: perl.c pp_sys.c proto.h dbmopen now invokes perl_eval_sv(), which should handle error conditions better. +NETaa14618: exists doesn't work in GDBM_File +From: Andrew Wilcox +Files patched: ext/GDBM_File/GDBM_File.xs + Applied suggested patch. + +NETaa14619: tied() +From: Larry Wall +Also: Paul Marquess +Files patched: embed.h global.sym keywords.h keywords.pl opcode.h opcode.pl pp_sys.c toke.c + Applied suggested patch. + NETaa14636: Jumbo Dynaloader patch From: Tim Bunce -Files patched: ext/DynaLoader/DynaLoader.pm 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 ext/DynaLoader/dlutils.c +Files patched: ext/DynaLoader/DynaLoader.pm 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 ext/DynaLoader/dlutils.c Applied suggested patches. NETaa14637: checkcomma routine was stupid about bareword sub calls @@ -855,11 +834,6 @@ Also: Stephen D. Lee Files patched: pp_sys.c Applied suggested patch. -NETaa14658: infinite loop in c2ph -From: Nick Gianniotis -Files patched: c2ph.SH - Applied suggested patch. - NETaa14668: {2,} could match once From: Hugo van der Sanden Files patched: regexec.c @@ -926,6 +900,12 @@ From: Gerd Knops Files patched: sv.c Now modifies address to copy if it was reallocated. +NETaa14709: Chip's FileHandle stuff +From: Larry Wall +Also: Chip Salzenberg +Files patched: MANIFEST ext/FileHandle/FileHandle.pm ext/FileHandle/FileHandle.xs ext/FileHandle/Makefile.PL ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod ext/POSIX/POSIX.xs lib/FileCache.pm lib/Symbol.pm t/lib/filehand.t t/lib/posix.t + Applied suggested patches. + NETaa14711: added (&) and (*) prototypes for blocks and symbols From: Kenneth Albanowski Files patched: Makefile.SH op.c perly.c perly.h perly.y toke.c @@ -951,6 +931,11 @@ Files patched: sv.c sv.c magic of that type. Ordinarily it would have, but it was called during mg_get(), which forces the magic flags off temporarily. +NETaa14721: sub defined during erroneous do-FILE caused core dump +From: David Campbell +Files patched: op.c + Fixed the seg fault. I couldn't reproduce the return problem. + NETaa14734: ref should never return undef From: Dale Amon Files patched: pp.c t/op/overload.t @@ -1016,15 +1001,397 @@ NETaa14893: /m modifier was sticky Files patched: cop.h pp_hot.c (same) +NETaa14916: complete.pl retained old return value +From: Martyn Pearce +Files patched: lib/complete.pl + Applied suggested patch. + +NETaa14928: non-const 3rd arg to split assigned to list could coredump +From: Hans de Graaff +Files patched: op.c + The optimizer was assuming the OP was an OP_CONST. + +NETaa14942: substr as lvalue could disable magic +From: Darrell Kindred <dkindred+@cmu.edu> +Files patched: pp.c + The substr was disabling the magic of $1. + +NETaa14990: "not" not parseable when expecting term +From: "Randal L. Schwartz" +Files patched: perly.c perly.c.diff perly.y vms/perly_c.vms + The NOTOP production needed to be moved down into the terms. + +NETaa14993: Bizarre copy of formline +From: Tom Christiansen +Also: Charles Bailey +Files patched: sv.c + Applied suggested patch. + +NETaa14998: sv_add_arena() no longer leaks memory +From: Andreas Koenig +Files patched: av.c hv.c perl.h sv.c + Now keeps one potential arena "on tap", but doesn't use it unless there's + demand for SV headers. When an AV or HV is extended, its old memory + becomes the next potential arena unless there already is one, in which + case it is simply freed. This will have the desired property of not + stranding medium-sized chunks of memory when extending a single array + repeatedly, but will not degrade when there's no SV demand beyond keeping + one chunk of memory on tap, which generally will be about 250 bytes big, + since it prefers the earlier freed chunk over the later. See the nice_chunk + variable. + +NETaa14999: $a and $b now protected from use strict and lexical declaration +From: Tom Christiansen +Files patched: gv.c pod/perldiag.pod toke.c + Bare $a and $b are now allowed during "use strict". In addition, + the following diag was added: + + =item Can't use "my %s" in sort comparison + + (F) The global variables $a and $b are reserved for sort comparisons. + You mentioned $a or $b in the same line as the <=> or cmp operator, + and the variable had earlier been declared as a lexical variable. + Either qualify the sort variable with the package name, or rename the + lexical variable. + + +NETaa15034: use strict refs should allow calls to prototyped functions +From: Roderick Schertler +Files patched: perly.c perly.c.diff perly.y toke.c vms/perly_c.vms + Applied patch suggested by Chip. + +NETaa15083: forced $AUTOLOAD to be untainted +From: Tim Bunce +Files patched: gv.c pp_hot.c + Stripped any taintmagic from $AUTOLOAD after setting it. + +NETaa15084: patch for Term::Cap +From: Mark Kaehny +Also: Hugo van der Sanden +Files patched: lib/Term/Cap.pm + Applied suggested patch. + +NETaa15086: null pattern could cause coredump in s//_$1_/ +From: "Paul E. Maisano" +Files patched: cop.h pp_ctl.c + If the replacement pattern was complicated enough to cause pp_substcont + to be called, then it lost track of which REGEXP* it was supposed to + be using. + +NETaa15087: t/io/pipe.t didn't work on AIX +From: Andy Dougherty +Files patched: t/io/pipe.t + Applied suggested patch. + +NETaa15088: study was busted +From: Hugo van der Sanden +Files patched: opcode.h opcode.pl pp.c + It was studying its scratch pad target rather than the argument supplied. + +NETaa15090: MSTATS patch +From: Tim Bunce +Files patched: global.sym malloc.c perl.c perl.h proto.h + Applied suggested patch. + +NETaa15098: longjmp out of magic leaks memory +From: Chip Salzenberg +Files patched: mg.c sv.c + Applied suggested patch. + +NETaa15102: getpgrp() is broken if getpgrp2() is available +From: Roderick Schertler +Files patched: perl.h pp_sys.c + Applied suggested patch. + +NETaa15103: prototypes leaked opcodes +From: Chip Salzenberg +Files patched: op.c + Applied suggested patch. + +NETaa15107: quotameta memory bug on all metacharacters +From: Chip Salzenberg +Files patched: pp.c + Applied suggested patch. + +NETaa15108: Fix for incomplete string leak +From: Chip Salzenberg +Files patched: toke.c + Applied suggested patch. + +NETaa15110: couldn't use $/ with 8th bit set on some architectures +From: Chip Salzenberg +Files patched: doop.c interp.sym mg.c op.c perl.c perl.h pp_ctl.c pp_hot.c pp_sys.c sv.c toke.c util.c + Applied suggested patches. + +NETaa15112: { a_1 => 2 } didn't parse as expected +From: Stuart M. Weinstein +Files patched: toke.c + The little dwimmer was only skipping ALPHA rather than ALNUM chars. + +NETaa15123: bitwise ops produce spurious warnings +From: Hugo van der Sanden +Also: Chip Salzenberg +Also: Andreas Gustafsson +Files patched: sv.c + Decided to suppress the warning in the conversion routines if merely converting + a temporary, which can never be a user-supplied value anyway. + +NETaa15129: #if defined (foo) misparsed in h2ph +From: Roderick Schertler <roderick@gate.net> +Files patched: utils/h2ph.PL + Applied suggested patch. + +NETaa15131: some POSIX functions assumed valid filehandles +From: Chip Salzenberg +Files patched: ext/POSIX/POSIX.xs + Applied suggested patch. + +NETaa15151: don't optimize split on OPpASSIGN_COMMON +From: Huw Rogers +Files patched: op.c + Had to swap the optimization down to after the assignment op is generated + and COMMON is calculated, and then clean up the resultant tree differently. + +NETaa15154: MakeMaker-5.18 +From: Andreas Koenig +Files patched: MANIFEST lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_VMS.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Mksymlists.pm + Brought it up to 5.18. + +NETaa15156: some Exporter tweaks +From: Roderick Schertler +Also: Tim Bunce +Files patched: lib/Exporter.pm + Also did Tim's Tiny Trivial patch. + +NETaa15157: new version of Test::Harness +From: Andreas Koenig +Files patched: lib/Test/Harness.pm + Applied suggested patch. + +NETaa15175: overloaded nomethod has garbage 4th op +From: Ilya Zakharevich +Files patched: gv.c + Applied suggested patch. + +NETaa15179: SvPOK_only shouldn't back off on offset pointer +From: Gutorm.Hogasen@oslo.teamco.telenor.no +Files patched: sv.h + SvPOK_only() was calling SvOOK_off(), which adjusted the string pointer + after tr/// has already acquired it. It shouldn't really be necessary + for SvPOK_only() to undo an offset string pointer, since there's no + conflict with a possible integer value where the offset is stored. + +NETaa15193: & now always bypasses prototype checking +From: Larry Wall +Files patched: dump.c op.c op.h perly.c perly.c.diff perly.y pod/perlsub.pod pp_hot.c proto.h toke.c vms/perly_c.vms vms/perly_h.vms + Turned out to be a big hairy deal because the lexer turns foo() into &foo(). + But it works consistently now. Also fixed pod. + +NETaa15197: 5.002b2 is 'appending' to $@ +From: Gurusamy Sarathy +Files patched: pp_ctl.c + Applied suggested patch. + +NETaa15201: working around Linux DBL_DIG problems +From: Kenneth Albanowski +Files patched: hints/linux.sh sv.c + Applied suggested patch. + +NETaa15208: SelectSaver +From: Chip Salzenberg +Files patched: MANIFEST lib/SelectSaver.pm + Applied suggested patch. + +NETaa15209: DirHandle +From: Chip Salzenberg +Files patched: MANIFEST lib/DirHandle.pm t/lib/dirhand.t + +NETaa15210: sysopen() +From: Chip Salzenberg +Files patched: doio.c keywords.pl lib/ExtUtils/typemap opcode.pl pod/perlfunc.pod pp_hot.c pp_sys.c proto.h toke.c + Applied suggested patch. Hope it works... + +NETaa15211: use mnemonic names in Safe setup +From: Chip Salzenberg +Files patched: ext/Safe/Safe.pm + Applied suggested patch, more or less. + +NETaa15214: prototype() +From: Chip Salzenberg +Files patched: ext/Safe/Safe.pm global.sym keywords.pl opcode.pl pp.c toke.c + Applied suggested patch. + +NETaa15217: -w problem with -d:foo +From: Tim Bunce +Files patched: perl.c + Applied suggested patch. + +NETaa15218: *GLOB{ELEMENT} +From: Larry Wall +Files patched: Makefile.SH embed.h ext/Safe/Safe.pm keywords.h opcode.h opcode.h opcode.pl perly.c perly.c.diff perly.y pp_hot.c t/lib/safe.t vms/perly_c.vms + +NETaa15219: Make *x=\*y do like *x=*y +From: Chip Salzenberg +Files patched: sv.c + Applied suggested patch. + +NETaa15221: Indigestion with Carp::longmess and big eval '...'s +From: Tim Bunce +Files patched: lib/Carp.pm + Applied suggested patch. + +NETaa15222: VERSION patch for standard extensions +From: Paul Marquess +Files patched: ext/DB_File/Makefile.PL ext/DynaLoader/DynaLoader.pm ext/DynaLoader/Makefile.PL ext/Fcntl/Fcntl.pm ext/Fcntl/Makefile.PL ext/GDBM_File/GDBM_File.pm ext/GDBM_File/Makefile.PL ext/NDBM_File/Makefile.PL ext/NDBM_File/NDBM_File.pm ext/ODBM_File/Makefile.PL ext/ODBM_File/ODBM_File.pm ext/POSIX/Makefile.PL ext/POSIX/POSIX.pm ext/SDBM_File/Makefile.PL ext/SDBM_File/SDBM_File.pm ext/Safe/Makefile.PL ext/Safe/Safe.pm ext/Socket/Makefile.PL + Applied suggested patch. + +NETaa15222: VERSION patch for standard extensions (reprise) +Files patched: ext/DB_File/DB_File.pm ext/DynaLoader/DynaLoader.pm ext/Fcntl/Fcntl.pm ext/GDBM_File/GDBM_File.pm ext/NDBM_File/NDBM_File.pm ext/ODBM_File/ODBM_File.pm ext/POSIX/POSIX.pm ext/SDBM_File/SDBM_File.pm ext/Safe/Safe.pm ext/Socket/Socket.pm + (same) + +NETaa15227: $i < 10000 should optimize to integer op +From: Larry Wall +Files patched: op.c op.c + The program + + for ($i = 0; $i < 100000; $i++) { + push @foo, $i; + } + + takes about one quarter the memory if the optimizer decides that it can + use an integer < comparison rather than floating point. It now does so + if one side is an integer constant and the other side a simple variable. + This should really help some of our benchmarks. You can still force a + floating point comparison by using 100000.0 instead. + +NETaa15228: CPerl-mode patch +From: Ilya Zakharevich +Files patched: emacs/cperl-mode.el + Applied suggested patch. + +NETaa15231: Symbol::qualify() +From: Chip Salzenberg +Files patched: ext/FileHandle/FileHandle.pm gv.c lib/SelectSaver.pm lib/Symbol.pm pp_hot.c + Applied suggested patch. + +NETaa15236: select select broke under use strict +From: Chip Salzenberg +Files patched: op.c + Instead of inventing a new bit, I just turned off the HINT_STRICT_REFS bit. + I don't think it's worthwhile distinguishing between qualified or unqualified + names to select. + +NETaa15237: use vars +From: Larry Wall +Files patched: MANIFEST gv.c lib/subs.pm lib/vars.pm sv.c + +NETaa15240: keep op names _and_ descriptions +From: Chip Salzenberg +Files patched: doio.c embed.h ext/Safe/Safe.pm ext/Safe/Safe.xs global.sym op.c opcode.h opcode.pl scope.c sv.c + Applied suggested patch. + +NETaa15259: study doesn't unset on string modification +From: Larry Wall +Files patched: mg.c pp.c + Piggybacked on m//g unset magic to unset the study too. + +NETaa15276: pick a better initial cxstack_max +From: Chip Salzenberg +Files patched: perl.c + Added fudge in, and made it calculate how many it could fit into (most of) 8K, + to avoid getting 16K of Kingsley malloc. + +NETaa15287: numeric comparison optimization adjustments +From: Clark Cooper +Files patched: op.c + Applied patch suggested by Chip, with liberalization to >= and <=. + +NETaa15299: couldn't eval string containing pod or __DATA__ +From: Andreas Koenig +Also: Gisle Aas +Files patched: toke.c + Basically, eval didn't know how to bypass pods correctly. + +NETaa15300: sv_backoff problems +From: Paul Marquess +Also: mtr +Also: Chip Salzenberg +Files patched: op.c sv.c sv.h + Applied suggested patch. + +NETaa15312: Avoid fclose(NULL) +From: Chip Salzenberg +Files patched: toke.c + Applied suggested patch. + +NETaa15318: didn't set up perl_init_i18nl14n for export +From: Ilya Zakharevich +Files patched: perl_exp.SH + Applied suggested patch. + +NETaa15331: File::Path::rmtree followed symlinks +From: Andreas Koenig +Files patched: lib/File/Path.pm + Added suggested patch, except I did + + if (not -l $root and -d _) { + + for efficiency, since if -d is true, the -l already called lstat on it. + +NETaa15339: sv_gets() didn't reset count +From: alanburlison@unn.unisys.com +Files patched: sv.c + Applied suggested patch. + +NETaa15341: differentiated importation of different types +From: Chip Salzenberg +Files patched: gv.c gv.h op.c perl.c pp.c pp_ctl.c sv.c sv.h toke.c + Applied suggested patch. + +NETaa15342: Consistent handling of e_{fp,tmpname} +From: Chip Salzenberg +Files patched: perl.c pp_ctl.c util.c + Applied suggested patch. + +NETaa15344: Safe gets confused about malloc on AIX +From: Tim Bunce +Files patched: ext/Safe/Safe.xs + Applied suggested patch. + +NETaa15348: -M upgrade +From: Tim Bunce +Files patched: perl.c pod/perlrun.pod + Applied suggested patch. + +NETaa15369: change in split optimization broke scalar context +From: Ulrich Pfeifer +Files patched: op.c + The earlier patch to make the split optimization pay attention to + OPpASSIGN_COMMON rearranged how the syntax tree is constructed, but kept + the wrong context flags. This causes pp_split() do do the wrong thing. + +NETaa15423: can't do subversion numbering because of %5.3f assumptions +From: Andy Dougherty +Files patched: configpm patchlevel.h perl.c perl.h pp_ctl.c + Removed the %5.3f assumptions where appropriate. patchlevel.h now + defines SUBVERSION, which if greater than 0 indicates a development version. + +NETaa15424: Sigsetjmp patch +From: Kenneth Albanowski +Files patched: Configure config_h.SH op.c perl.c perl.h pp_ctl.c util.c + Applied suggested patch. + Needed to make install paths absolute. Files patched: installperl -derived it -Files patched: perly.h +h2xs 1.14 +Files patched: utils/h2xs.PL makedir() looped on a symlink to a directory. Files patched: installperl +xsubpp 1.932 +Files patched: lib/ExtUtils/xsubpp ------------- Version 5.001 @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.8 1995/07/25 13:40:02 ram Exp $ # -# Generated on Fri Feb 9 14:09:07 EST 1996 [metaconfig 3.0 PL60] +# Generated on Wed Feb 21 14:26:18 EST 1996 [metaconfig 3.0 PL60] cat >/tmp/c1$$ <<EOF ARGGGHHHH!!!!! @@ -362,6 +362,7 @@ shmattype='' d_shmctl='' d_shmdt='' d_shmget='' +d_sigsetjmp='' d_sigaction='' d_sigintrp='' d_sigvec='' @@ -1011,7 +1012,7 @@ THIS PACKAGE SEEMS TO BE INCOMPLETE. You have the option of continuing the configuration process, despite the distinct possibility that your kit is damaged, by typing 'y'es. If you do, don't blame me if something goes wrong. I advise you to type 'n'o -and contact the author (lwall@sems.com). +and contact the author (doughera@lafcol.lafayette.edu). EOM echo $n "Continue? [n] $c" >&4 @@ -1208,7 +1209,7 @@ Much effort has been expended to ensure that this shell script will run on any Unix system. If despite that it blows up on yours, your best bet is to edit Configure and run it again. If you can't run Configure for some reason, you'll have to generate a config.sh file by hand. Whatever problems you -have, let me (lwall@sems.com) know how I blew it. +have, let me (doughera@lafcol.lafayette.edu) know how I blew it. This installation script affects things in two ways: @@ -1552,7 +1553,7 @@ EOM cd hints; ls -C *.sh | $sed 's/\.sh/ /g' >&4 dflt='' : Half the following guesses are probably wrong... If you have better - : tests or hints, please send them to lwall@sems.com + : tests or hints, please send them to doughera@lafcol.lafayette.edu : The metaconfig authors would also appreciate a copy... $test -f /irix && osname=irix $test -f /xenix && osname=sco_xenix @@ -6619,6 +6620,50 @@ fi set sigaction d_sigaction eval $inlibc + +: see if sigsetjmp exists +echo " " +case "$d_sigsetjmp" in +'') + $cat >set.c <<EOP +#include <setjmp.h> +sigjmp_buf env; +int set = 1; +main() +{ + if (sigsetjmp(env,1)) + exit(set); + set = 0; + siglongjmp(env, 1); + exit(1); +} +EOP + if $cc $ccflags $ldflags set.c -o set $libs >/dev/null 2>&1; then + if ./set >/dev/null 2>&1; then + echo "POSIX sigsetjmp found." >&4 + val="$define" + else + $cat <<EOM +Uh-Oh! You have POSIX sigsetjmp and siglongjmp, but they do not work properly!! +EOM + val="$undef" + fi + else + echo "Sigsetjmp not found." >&4 + val="$undef" + fi + ;; +*) val="$d_sigsetjmp" + case "$d_sigsetjmp" in + $define) echo "POSIX sigsetjmp found." >&4;; + $undef) echo "Sigsetjmp not found." >&4;; + esac + ;; +esac +set d_sigsetjmp +eval $setvar +$rm -f set.c set + socketlib='' sockethdr='' : see whether socket exists @@ -9053,6 +9098,7 @@ d_shmget='$d_shmget' d_shrplib='$d_shrplib' d_sigaction='$d_sigaction' d_sigintrp='$d_sigintrp' +d_sigsetjmp='$d_sigsetjmp' d_sigvec='$d_sigvec' d_sigvectr='$d_sigvectr' d_socket='$d_socket' @@ -549,6 +549,11 @@ page, however. You may need to be root to run B<make install>. If you are not root, you must own the directories in question and you should ignore any messages about chown not working. +B<Note:> In the 5.002 release, you will see some harmless error +messages and warnings from pod2man. You may safely ignore them. (Yes, +they should be fixed, but they didn't seem important enough to warrant +holding up the entire 5.002 release.) + If you want to see exactly what will happen without installing anything, you can run @@ -675,6 +680,6 @@ is sometimes useful for finding things in the library modules. Andy Dougherty <doughera@lafcol.lafayette.edu>, borrowing I<very> heavily from the original README by Larry Wall. -=head 2 LAST MODIFIED +=head1 LAST MODIFIED 04 January 1996 @@ -104,6 +104,7 @@ ext/NDBM_File/Makefile.PL NDBM extension makefile writer ext/NDBM_File/NDBM_File.pm NDBM extension Perl module ext/NDBM_File/NDBM_File.xs NDBM extension external subroutines ext/NDBM_File/hints/solaris.pl Hint for NDBM_File for named architecture +ext/NDBM_File/hints/svr4.pl Hint for NDBM_File for named architecture ext/NDBM_File/typemap NDBM extension interface types ext/ODBM_File/Makefile.PL ODBM extension makefile writer ext/ODBM_File/ODBM_File.pm ODBM extension Perl module @@ -368,7 +369,6 @@ os2/diff.Makefile Patches to Makefile.SH os2/diff.c2ph c2ph patch os2/diff.configure Patches to Configure os2/diff.db_file patch to DB_File -os2/diff.exec patch to #ifdef lines to exec with sh os2/diff.installman Patches to installman os2/diff.installperl Patches to installperl os2/diff.mkdep Patches to makedepend.SH @@ -465,6 +465,7 @@ t/comp/multiline.t See if multiline strings work t/comp/package.t See if packages work t/comp/script.t See if script invokation works t/comp/term.t See if more terms work +t/harness Finer diagnostics from test suite t/io/argv.t See if ARGV stuff works t/io/dup.t See if >& works right t/io/fs.t See if directory manipulations work diff --git a/README.vms b/README.vms index a530103f09..fd64ce3b9a 100644 --- a/README.vms +++ b/README.vms @@ -172,15 +172,16 @@ you omit this step, you risk ending up with a copy of Perl which composed partially of old files and partially of new ones, which may lead to strange effects when you try to run Perl. -Note for sites using DECC: A bug in some early versions of the DECC RTL on the -AXP causes newlines to be lost when writing to a pipe. This causes -Gen_ShrFls.pl to fail, since it can't read the preprocessor output to identify -global variables and routines. A different bug in the DECC preprocessor itself -for some patched versions of DECC 4.0 on the VAX also makes it impossible for -Gen_ShrFls.pl to parse the preprocessor output. In either case, the problem is -generally manifested as missing global symbols when linking PerlShr.Exe or -Perl.Exe. You can work around this problem by defining the macro -DECC_PIPES_BROKEN when you invoke MMS or MMK. +A bug in some early versions of the DECC RTL on the AXP causes newlines +to be lost when writing to a pipe. A different bug in some patched versions +of DECC 4.0 for VAX can also scramble preprocessor output. Finally, gcc 2.7.2 +has yet another preprocessor bug, which causes line breaks to be inserted +into the output at inopportune times. Each of these bugs causes Gen_ShrFls.pl +to fail, since it can't parse the preprocessor output to identify global +variables and routines. This problem is generally manifested as missing +global symbols when linking PerlShr.Exe or Perl.Exe. You can work around +it by defining the macro PIPES_BROKEN when you invoke MMS or MMK. + This will build the following files: Miniperl.Exe - a stand-alone version of without any extensions. diff --git a/config_h.SH b/config_h.SH index 5d823022cb..ad7a69fbea 100644..100755 --- a/config_h.SH +++ b/config_h.SH @@ -1389,6 +1389,28 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #define Gconvert(x,n,t,b) $d_Gconvert +/* Sigjmp_buf: + * This is the buffer type to be used with Sigsetjmp and Siglongjmp. + */ +/* Sigsetjmp: + * This macro is used in the same way as sigsetjmp(), but will invoke + * traditional setjmp() if sigsetjmp isn't available. + */ +/* Siglongjmp: + * This macro is used in the same way as siglongjmp(), but will invoke + * traditional longjmp() if siglongjmp isn't available. + */ +#$d_sigsetjmp HAS_SIGSETJMP /**/ +#ifdef HAS_SIGSETJMP +#define Sigjmp_buf sigjmp_buf +#define Sigsetjmp(buf,save_mask) sigsetjmp(buf,save_mask) +#define Siglongjmp(buf,retval) siglongjmp(buf,retval) +#else +#define Sigjmp_buf jmp_buf +#define Sigsetjmp(buf,save_mask) setjmp(buf) +#define Siglongjmp(buf,retval) longjmp(buf,retval) +#endif + /* USE_DYNAMIC_LOADING: * This symbol, if defined, indicates that dynamic loading of * some sort is available. @@ -16,7 +16,7 @@ $config_pm = $ARGV[0] || 'lib/Config.pm'; open CONFIG, ">$config_pm" or die "Can't open $config_pm: $!\n"; -$myver = sprintf("%.3f", $]); +$myver = $]; print CONFIG <<"ENDOFBEG"; package Config; @@ -25,8 +25,8 @@ use Exporter (); \@EXPORT = qw(%Config); \@EXPORT_OK = qw(myconfig config_sh config_vars); -\$] == $myver or die sprintf - "Perl lib version ($myver) doesn't match executable version (%.3f)\\n", \$]; +\$] == $myver + or die "Perl lib version ($myver) doesn't match executable version (\$])\\n"; # This file was created by configpm when Perl was built. Any changes # made to this file will be lost the next time perl is built. diff --git a/configure b/configure index 29e7d351b4..29e7d351b4 100755..100644 --- a/configure +++ b/configure @@ -26,10 +26,11 @@ struct xpvcv { long xcv_depth; /* >= 2 indicates recursive call */ AV * xcv_padlist; CV * xcv_outside; - bool xcv_oldstyle; + U8 xcv_flags; }; #define Nullcv Null(CV*) + #define CvSTASH(sv) ((XPVCV*)SvANY(sv))->xcv_stash #define CvSTART(sv) ((XPVCV*)SvANY(sv))->xcv_start #define CvROOT(sv) ((XPVCV*)SvANY(sv))->xcv_root @@ -40,5 +41,25 @@ struct xpvcv { #define CvDEPTH(sv) ((XPVCV*)SvANY(sv))->xcv_depth #define CvPADLIST(sv) ((XPVCV*)SvANY(sv))->xcv_padlist #define CvOUTSIDE(sv) ((XPVCV*)SvANY(sv))->xcv_outside -#define CvOLDSTYLE(sv) ((XPVCV*)SvANY(sv))->xcv_oldstyle +#define CvFLAGS(sv) ((XPVCV*)SvANY(sv))->xcv_flags + +#define CVf_CLONE 0x01 /* anon CV uses external lexicals */ +#define CVf_CLONED 0x02 /* a clone of one of those */ +#define CVf_ANON 0x04 /* CvGV() can't be trusted */ +#define CVf_OLDSTYLE 0x08 + +#define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE) +#define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE) +#define CvCLONE_off(cv) (CvFLAGS(cv) &= ~CVf_CLONE) + +#define CvCLONED(cv) (CvFLAGS(cv) & CVf_CLONED) +#define CvCLONED_on(cv) (CvFLAGS(cv) |= CVf_CLONED) +#define CvCLONED_off(cv) (CvFLAGS(cv) &= ~CVf_CLONED) + +#define CvANON(cv) (CvFLAGS(cv) & CVf_ANON) +#define CvANON_on(cv) (CvFLAGS(cv) |= CVf_ANON) +#define CvANON_off(cv) (CvFLAGS(cv) &= ~CVf_ANON) +#define CvOLDSTYLE(cv) (CvFLAGS(cv) & CVf_OLDSTYLE) +#define CvOLDSTYLE_on(cv) (CvFLAGS(cv) |= CVf_OLDSTYLE) +#define CvOLDSTYLE_off(cv) (CvFLAGS(cv) &= ~CVf_OLDSTYLE) @@ -278,7 +278,7 @@ FILE *supplied_fp; if (saveifp) { /* must use old fp? */ fd = fileno(saveifp); if (saveofp) { - fflush(saveofp); /* emulate fclose() */ + Fflush(saveofp); /* emulate fclose() */ if (saveofp != saveifp) { /* was a socket? */ fclose(saveofp); if (fd > 2) @@ -344,7 +344,7 @@ register GV *gv; if (!argvoutgv) argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO); if (filemode & (S_ISUID|S_ISGID)) { - fflush(IoIFP(GvIOn(argvoutgv))); /* chmod must follow last write */ + Fflush(IoIFP(GvIOn(argvoutgv))); /* chmod must follow last write */ #ifdef HAS_FCHMOD (void)fchmod(lastfd,filemode); #else @@ -14,5 +14,6 @@ #define Stat(fname,bufptr) stat((fname),(bufptr)) #define Fstat(fd,bufptr) fstat((fd),(bufptr)) +#define Fflush(fp) fflush(fp) #define my_getenv(var) getenv(var) diff --git a/ext/FileHandle/FileHandle.pm b/ext/FileHandle/FileHandle.pm index d6832dbd0b..1d1fe18e53 100644 --- a/ext/FileHandle/FileHandle.pm +++ b/ext/FileHandle/FileHandle.pm @@ -32,6 +32,11 @@ FileHandle - supply object methods for filehandles undef $fh; # automatically closes the file } + $pos = $fh->getpos; + $fh->setpos $pos; + + $fh->setvbuf($buffer_var, _IOLBF, 1024); + ($readfh, $writefh) = FileHandle::pipe; autoflush STDOUT 1; @@ -60,6 +65,21 @@ C<FileHandle::fdopen> is like C<open> except that its first parameter is not a filename but rather a file handle name, a FileHandle object, or a file descriptor number. +If the C functions fgetpos() and fsetpos() are available, then +C<FileHandle::getpos> returns an opaque value that represents the +current position of the FileHandle, and C<FileHandle::setpos> uses +that value to return to a previously visited position. + +If the C function setvbuf() is available, then C<FileHandle::setvbuf> +sets the buffering policy for the FileHandle. The calling sequence +for the Perl function is the same as its C counterpart, including the +macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer +parameter specifies a scalar variable to use as a buffer. WARNING: A +variable used as a buffer by C<FileHandle::setvbuf> must not be +modified in any way until the FileHandle is closed or until +C<FileHandle::setvbuf> is called again, or memory corruption may +result! + See L<perlfunc> for complete descriptions of each of the following supported C<FileHandle> methods, which are just front ends for the corresponding built-in functions: diff --git a/ext/NDBM_File/NDBM_File.pm b/ext/NDBM_File/NDBM_File.pm index 339439c98f..601a3c2a0e 100644 --- a/ext/NDBM_File/NDBM_File.pm +++ b/ext/NDBM_File/NDBM_File.pm @@ -15,3 +15,21 @@ bootstrap NDBM_File $VERSION; 1; __END__ + +=head1 NAME + +NDBM_File - Tied access to ndbm files + +=head1 SYNOPSIS + + use NDBM_File; + + tie(%h,NDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640); + + untie %h; + +=head1 DESCRIPTION + +See L<perlfunc/tie> + +=cut diff --git a/ext/NDBM_File/hints/svr4.pl b/ext/NDBM_File/hints/svr4.pl new file mode 100644 index 0000000000..3285d9a685 --- /dev/null +++ b/ext/NDBM_File/hints/svr4.pl @@ -0,0 +1,4 @@ +# Some SVR4 systems may need to link against routines in -lucb for +# odbm. Some may also need to link against -lc to pick up things like +# ecvt. +$self->{LIBS} = ['-ldbm -lucb -lc']; diff --git a/ext/ODBM_File/ODBM_File.pm b/ext/ODBM_File/ODBM_File.pm index a96916b6e0..e5386e853b 100644 --- a/ext/ODBM_File/ODBM_File.pm +++ b/ext/ODBM_File/ODBM_File.pm @@ -15,3 +15,21 @@ bootstrap ODBM_File $VERSION; 1; __END__ + +=head1 NAME + +ODBM_File - Tied access to odbm files + +=head1 SYNOPSIS + + use ODBM_File; + + tie(%h,ODBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640); + + untie %h; + +=head1 DESCRIPTION + +See L<perlfunc/tie> + +=cut diff --git a/ext/SDBM_File/SDBM_File.pm b/ext/SDBM_File/SDBM_File.pm index deb72f1966..9b7acc1e09 100644 --- a/ext/SDBM_File/SDBM_File.pm +++ b/ext/SDBM_File/SDBM_File.pm @@ -15,3 +15,21 @@ bootstrap SDBM_File $VERSION; 1; __END__ + +=head1 NAME + +SDBM_File - Tied access to sdbm files + +=head1 SYNOPSIS + + use SDBM_File; + + tie(%h,SDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640); + + untie %h; + +=head1 DESCRIPTION + +See L<perlfunc/tie> + +=cut diff --git a/ext/Safe/Safe.xs b/ext/Safe/Safe.xs index f970a626ac..6b25924a33 100644 --- a/ext/Safe/Safe.xs +++ b/ext/Safe/Safe.xs @@ -2,6 +2,9 @@ #include "perl.h" #include "XSUB.h" +/* maxo should never differ from MAXO but leave some room anyway */ +#define OP_MASK_BUF_SIZE (MAXO + 100) + MODULE = Safe PACKAGE = Safe void @@ -13,14 +16,15 @@ safe_call_sv(package, mask, codesv) int i; char *str; STRLEN len; + char op_mask_buf[OP_MASK_BUF_SIZE]; + assert(maxo < OP_MASK_BUF_SIZE); ENTER; SAVETMPS; save_hptr(&defstash); save_aptr(&endav); SAVEPPTR(op_mask); - Newz(666, op_mask, maxo+1, char); - SAVEFREEPV(op_mask); + op_mask = &op_mask_buf[0]; str = SvPV(mask, len); if (maxo != len) croak("Bad mask length"); @@ -62,8 +66,8 @@ void ops_to_mask(...) CODE: int i, j; - char *mask, *op; - Newz(666, mask, maxo+1, char); + char mask[OP_MASK_BUF_SIZE], *op; + Zero(mask, sizeof mask, char); for (i = 0; i < items; i++) { op = SvPV(ST(i), na); @@ -76,8 +80,7 @@ ops_to_mask(...) croak("bad op name \"%s\" in mask", op); } } - ST(0) = sv_newmortal(); - sv_usepvn(ST(0), mask, maxo); + ST(0) = sv_2mortal(newSVpv(mask,maxo)); void opname(...) @@ -65,7 +65,7 @@ char *name; gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV); sv_setpv(GvSV(gv), name); if (*name == '/' && (instr(name,"/lib/") || instr(name,".pm"))) - SvMULTI_on(gv); + GvMULTI_on(gv); if (perldb) hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); return gv; @@ -96,7 +96,7 @@ int multi; GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; if (multi) - SvMULTI_on(gv); + GvMULTI_on(gv); } static void @@ -366,7 +366,7 @@ I32 sv_type; gv = *gvp; if (SvTYPE(gv) == SVt_PVGV) - SvMULTI_on(gv); + GvMULTI_on(gv); else if (!add) return Nullgv; else @@ -432,15 +432,16 @@ I32 sv_type; { gvp = (GV**)hv_fetch(stash,name,len,0); if (!gvp || - *gvp == (GV*)&sv_undef || - SvTYPE(*gvp) != SVt_PVGV || - !(GvFLAGS(*gvp) & GVf_IMPORTED)) + *gvp == (GV*)&sv_undef || + SvTYPE(*gvp) != SVt_PVGV) + { stash = 0; - else if (sv_type == SVt_PVAV && !GvAV(*gvp) || - sv_type == SVt_PVHV && !GvHV(*gvp) || - sv_type == SVt_PV && !GvSV(*gvp) ) + } + else if (sv_type == SVt_PV && !GvIMPORTED_SV(*gvp) || + sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) || + sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) ) { - warn("Variable \"%c%s\" is not exported", + warn("Variable \"%c%s\" is not imported", sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', name); @@ -478,7 +479,7 @@ I32 sv_type; gv = *gvp; if (SvTYPE(gv) == SVt_PVGV) { if (add) { - SvMULTI_on(gv); + GvMULTI_on(gv); gv_init_sv(gv, sv_type); } return gv; @@ -502,16 +503,16 @@ I32 sv_type; case 'a': case 'b': if (len == 1) - SvMULTI_on(gv); + GvMULTI_on(gv); break; case 'E': if (strnEQ(name, "EXPORT", 6)) - SvMULTI_on(gv); + GvMULTI_on(gv); break; case 'I': if (strEQ(name, "ISA")) { AV* av = GvAVn(gv); - SvMULTI_on(gv); + GvMULTI_on(gv); sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0); if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1) { @@ -533,7 +534,7 @@ I32 sv_type; case 'O': if (strEQ(name, "OVERLOAD")) { HV* hv = GvHVn(gv); - SvMULTI_on(gv); + GvMULTI_on(gv); sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0); } break; @@ -542,7 +543,7 @@ I32 sv_type; if (strEQ(name, "SIG")) { HV *hv; siggv = gv; - SvMULTI_on(siggv); + GvMULTI_on(siggv); hv = GvHVn(siggv); hv_magic(hv, siggv, 'S'); @@ -699,7 +700,7 @@ newIO() sv_upgrade((SV *)io,SVt_PVIO); SvREFCNT(io) = 1; SvOBJECT_on(io); - iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVIO); + iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVHV); SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv)); return io; } @@ -726,12 +727,12 @@ HV* stash; } else if (isALPHA(*entry->hent_key)) { gv = (GV*)entry->hent_val; - if (SvMULTI(gv)) + if (GvMULTI(gv)) continue; curcop->cop_line = GvLINE(gv); filegv = GvFILEGV(gv); curcop->cop_filegv = filegv; - if (filegv && SvMULTI(filegv)) /* Filename began with slash */ + if (filegv && GvMULTI(filegv)) /* Filename began with slash */ continue; warn("Identifier \"%s::%s\" used only once: possible typo", HvNAME(stash), GvNAME(gv)); @@ -20,7 +20,6 @@ struct gp { I32 gp_lastexpr; /* used by nothing_in_common() */ line_t gp_line; /* line first declared at (for -w) */ GV * gp_filegv; /* file first declared in (for -w) */ - char gp_flags; }; #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286)) @@ -29,6 +28,12 @@ struct gp { #define GvXPVGV(gv) ((XPVGV*)SvANY(gv)) +#define GvGP(gv) (GvXPVGV(gv)->xgv_gp) +#define GvNAME(gv) (GvXPVGV(gv)->xgv_name) +#define GvNAMELEN(gv) (GvXPVGV(gv)->xgv_namelen) +#define GvSTASH(gv) (GvXPVGV(gv)->xgv_stash) +#define GvFLAGS(gv) (GvXPVGV(gv)->xgv_flags) + #define GvSV(gv) (GvGP(gv)->gp_sv) #define GvREFCNT(gv) (GvGP(gv)->gp_refcnt) #define GvIO(gv) ((gv) && SvTYPE((SV*)gv) == SVt_PVGV ? GvIOp(gv) : 0) @@ -63,18 +68,51 @@ HV *GvHVn(); #define GvLINE(gv) (GvGP(gv)->gp_line) #define GvFILEGV(gv) (GvGP(gv)->gp_filegv) -#define GvFLAGS(gv) (GvGP(gv)->gp_flags) - #define GvEGV(gv) (GvGP(gv)->gp_egv) - -#define GvGP(gv) (GvXPVGV(gv)->xgv_gp) -#define GvNAME(gv) (GvXPVGV(gv)->xgv_name) -#define GvNAMELEN(gv) (GvXPVGV(gv)->xgv_namelen) #define GvENAME(gv) GvNAME(GvEGV(gv) ? GvEGV(gv) : gv) - -#define GvSTASH(gv) (GvXPVGV(gv)->xgv_stash) #define GvESTASH(gv) GvSTASH(GvEGV(gv) ? GvEGV(gv) : gv) +#define GVf_INTRO 0x01 +#define GVf_MULTI 0x02 +#define GVf_ASSUMECV 0x04 +#define GVf_IMPORTED 0xF0 +#define GVf_IMPORTED_SV 0x10 +#define GVf_IMPORTED_AV 0x20 +#define GVf_IMPORTED_HV 0x40 +#define GVf_IMPORTED_CV 0x80 + +#define GvINTRO(gv) (GvFLAGS(gv) & GVf_INTRO) +#define GvINTRO_on(gv) (GvFLAGS(gv) |= GVf_INTRO) +#define GvINTRO_off(gv) (GvFLAGS(gv) &= ~GVf_INTRO) + +#define GvMULTI(gv) (GvFLAGS(gv) & GVf_MULTI) +#define GvMULTI_on(gv) (GvFLAGS(gv) |= GVf_MULTI) +#define GvMULTI_off(gv) (GvFLAGS(gv) &= ~GVf_MULTI) + +#define GvASSUMECV(gv) (GvFLAGS(gv) & GVf_ASSUMECV) +#define GvASSUMECV_on(gv) (GvFLAGS(gv) |= GVf_ASSUMECV) +#define GvASSUMECV_off(gv) (GvFLAGS(gv) &= ~GVf_ASSUMECV) + +#define GvIMPORTED(gv) (GvFLAGS(gv) & GVf_IMPORTED) +#define GvIMPORTED_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED) +#define GvIMPORTED_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED) + +#define GvIMPORTED_SV(gv) (GvFLAGS(gv) & GVf_IMPORTED_SV) +#define GvIMPORTED_SV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_SV) +#define GvIMPORTED_SV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_SV) + +#define GvIMPORTED_AV(gv) (GvFLAGS(gv) & GVf_IMPORTED_AV) +#define GvIMPORTED_AV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_AV) +#define GvIMPORTED_AV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_AV) + +#define GvIMPORTED_HV(gv) (GvFLAGS(gv) & GVf_IMPORTED_HV) +#define GvIMPORTED_HV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_HV) +#define GvIMPORTED_HV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_HV) + +#define GvIMPORTED_CV(gv) (GvFLAGS(gv) & GVf_IMPORTED_CV) +#define GvIMPORTED_CV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_CV) +#define GvIMPORTED_CV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_CV) + #define Nullgv Null(GV*) #define DM_UID 0x003 @@ -85,9 +123,6 @@ HV *GvHVn(); #define DM_EGID 0x020 #define DM_DELAY 0x100 -#define GVf_INTRO 0x01 -#define GVf_IMPORTED 0x02 - #define GV_ADD 0x01 #define GV_ADDMULTI 0x02 #define GV_ADDWARN 0x04 diff --git a/hints/aix.sh b/hints/aix.sh index 6a4c585eb6..a9f277eed1 100644 --- a/hints/aix.sh +++ b/hints/aix.sh @@ -15,6 +15,8 @@ d_setruid='undef' alignbytes=8 +usemymalloc='n' + # Make setsockopt work correctly. See man page. # ccflags='-D_BSD=44' diff --git a/hints/hpux.sh b/hints/hpux.sh index 2c3126dbb4..0f8d33c6ae 100644 --- a/hints/hpux.sh +++ b/hints/hpux.sh @@ -24,7 +24,7 @@ ldflags="$ldflags" # ANSI C (the -Aa flag) nor can it produce shared libraries. Thus we have # to turn off dynamic loading. case "$cc" in -'') if cc $ccflags -Aa 2>&1 | $contains 'Unknown option "A"' >/dev/null +'') if cc $ccflags -Aa 2>&1 | $contains 'option' >/dev/null then case "$usedl" in '') usedl="$undef" diff --git a/hints/linux.sh b/hints/linux.sh index 3dedb33e14..cbeafcb5de 100644 --- a/hints/linux.sh +++ b/hints/linux.sh @@ -82,6 +82,7 @@ EOM ccflags="-DOVR_DBL_DIG=14 $ccflags" so='sa' dlext='o' + nm_so_opt=' ' ## If you are using DLD 3.2.4 which does not support shared libs, ## uncomment the next two lines: #ldflags="-static" diff --git a/hints/os2.sh b/hints/os2.sh index c9726656b8..d4fb71df2a 100644 --- a/hints/os2.sh +++ b/hints/os2.sh @@ -84,10 +84,6 @@ usedl='define' #cppflags='-DDOSISH -DOS2=2 -DEMBED -I.' -# This variables taken from recommended config.sh -# [Does Configure get it wrong?] -alignbytes='8' - # for speedup: (some patches to ungetc are also needed): # Note that without this guy tests 8 and 10 of io/tell.t fail, with it 11 fails diff --git a/hints/sco.sh b/hints/sco.sh index 5e8a6b0939..307e27e4db 100644 --- a/hints/sco.sh +++ b/hints/sco.sh @@ -1,7 +1,19 @@ # sco_3.sh # Courtesy of Joel Rosi-Schwartz <joel@ftechne.co.uk> -# To use gcc, do Configure -Dcc=gcc -# +# Additional SCO version info from +# Peter Wolfe <wolfe@teloseng.com> +# Last revised +# Tue Feb 13 09:09:10 EST 1996 + +# To use gcc, use sh Configure -Dcc=gcc + +# figure out what SCO version we are: +case `uname -X | egrep '^Release'` in +*3.2v4.2) scorls=3 ;; +*3.2v5.*) scorls=5 ;; +*) scorls=3 ;; # this probabaly shouldn't happen +esac + # Try to use libintl.a since it has strcoll and strxfrm libswanted="intl $libswanted" # Try to use libdbm.nfs.a since it has dbmclose. @@ -12,11 +24,11 @@ fi set X $libswanted shift libswanted="$*" -# + # We don't want Xenix cross-development libraries glibpth=`echo $glibpth | sed -e 's! /usr/lib/386 ! !' -e 's! /lib/386 ! !'` xlibpth='' -# + case "$cc" in gcc) ccflags="$ccflags -U M_XENIX" @@ -24,10 +36,12 @@ gcc) ;; scocc) ;; -*) - # Apparently, SCO's cc gives rather verbose warnings +*) # Apparently, SCO's cc gives rather verbose warnings # Set -w0 to turn them off. - ccflags="$ccflags -w0 -U M_XENIX" + case $scorls in + 3) ccflags="$ccflags -W0 -quiet -U M_XENIX" ;; + 5) ccflags="$ccflags -w0 -U M_XENIX" ;; + esac ;; esac i_varargs=undef diff --git a/hints/svr4.sh b/hints/svr4.sh index f4664d9366..5569274753 100644 --- a/hints/svr4.sh +++ b/hints/svr4.sh @@ -26,6 +26,12 @@ if [ -r /usr/ucblib/libucb.a ]; then # If using BSD-compat. library: fi d_suidsafe='define' # "./Configure -d" can't figure this out easilly usevfork='false' + +# Configure may fail to find lstat() since it's a static/inline +# function in <sys/stat.h> on Unisys U6000 SVR4, and possibly +# other SVR4 derivatives. +d_lstat=define + cat <<'EOM' >&4 If you wish to use dynamic linking, you must use diff --git a/installman b/installman index 76ab23c558..76ab23c558 100755..100644 --- a/installman +++ b/installman diff --git a/lib/ExtUtils/MM_OS2.pm b/lib/ExtUtils/MM_OS2.pm index e88b899b46..1a1f8b16a0 100644 --- a/lib/ExtUtils/MM_OS2.pm +++ b/lib/ExtUtils/MM_OS2.pm @@ -61,6 +61,10 @@ __END__ ExtUtils::MM_OS2 - methods to override UN*X behaviour in ExtUtils::MakeMaker +=head1 SYNOPSIS + + use ExtUtils::MM_OS2; # Done internally by ExtUtils::MakeMaker if needed + =head1 DESCRIPTION See ExtUtils::MM_Unix for a documentation of the methods provided diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index cabb1be827..bbaef15daf 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -65,7 +65,7 @@ with a directory sub catdir { shift; - my $result = join('/',@_,'/'); + my $result = join('/',@_); $result =~ s:/\./:/:g; $result =~ s:/+:/:g; $result; @@ -689,7 +689,7 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) my($c); ($c = $name) =~ s/\.xs$/.c/; $xs{$name} = $c; $c{$c} = 1; - } elsif ($name =~ /\.c$/i){ + } elsif ($name =~ /\.c(pp|xx|c)?$/i){ # .c .C .cpp .cxx .cc $c{$name} = 1 unless $name =~ m/perlmain\.c/; # See MAP_TARGET } elsif ($name =~ /\.h$/i){ @@ -772,7 +772,7 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) $self->{PM} = \%pm unless $self->{PM}; $self->{C} = [sort keys %c] unless $self->{C}; my(@o_files) = @{$self->{C}}; - $self->{O_FILES} = [grep s/\.c$/$self->{OBJ_EXT}/i, @o_files] ; + $self->{O_FILES} = [grep s/\.c(pp|xx|c)?$/$self->{OBJ_EXT}/i, @o_files] ; $self->{H} = [sort keys %h] unless $self->{H}; $self->{PL_FILES} = \%pl_files unless $self->{PL_FILES}; @@ -1015,7 +1015,8 @@ sub const_config { push(@m,"\n# They may have been overridden via Makefile.PL or on the command line\n"); my(%once_only); foreach $m (@{$self->{CONFIG}}){ - next if $once_only{$m}; + # SITE*EXP macros are defined in &constants; avoid duplicates here + next if $once_only{$m} or $m eq 'SITELIBEXP' or $m eq 'SITEARCHEXP'; push @m, "\U$m\E = ".$self->{uc $m}."\n"; $once_only{$m} = 1; } @@ -1096,7 +1097,7 @@ MAN3PODS = ".join(" \\\n\t", sort keys %{$self->{MAN3PODS}})." # work around a famous dec-osf make(1) feature(?): makemakerdflt: all -.SUFFIXES: .xs .c .C \$(OBJ_EXT) +.SUFFIXES: .xs .c .C .cpp .cxx .cc \$(OBJ_EXT) # Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that # some make implementations will delete the Makefile when we rebuild it. Because @@ -1641,6 +1642,15 @@ sub c_o { .C$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.C + +.cpp$(OBJ_EXT): + $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.cpp + +.cxx$(OBJ_EXT): + $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.cxx + +.cc$(OBJ_EXT): + $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.cc '; join "", @m; } @@ -2449,9 +2459,9 @@ sub install { push @m, q{ install :: all pure_install doc_install -install_perl :: pure_perl_install doc_perl_install +install_perl :: all pure_perl_install doc_perl_install -install_site :: pure_site_install doc_site_install +install_site :: all pure_site_install doc_site_install install_ :: install_site @echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 8b6625e02f..7e92a2ef06 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -3,11 +3,11 @@ # This package is inserted into @ISA of MakeMaker's MM before the # built-in ExtUtils::MM_Unix methods if MakeMaker.pm is run under VMS. # -# Version: 5.17 # Author: Charles Bailey bailey@genetics.upenn.edu -# Revised: 14-Jan-1996 package ExtUtils::MM_VMS; +$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.21 (15-Feb-1996)'; +unshift @MM::ISA, 'ExtUtils::MM_VMS'; use Config; require Exporter; @@ -15,7 +15,6 @@ use VMS::Filespec; use File::Basename; Exporter::import('ExtUtils::MakeMaker', '$Verbose', '&neatvalue'); -unshift @MM::ISA, 'ExtUtils::MM_VMS'; sub eliminate_macros { @@ -99,7 +98,7 @@ sub catdir { $rslt = vmspath($self->eliminate_macros($spath)."/$sdir"); } else { $rslt = vmspath($dir); } - print "catdir($path,$dir) = |$rslt|\n" if $Verbose >= 3; + print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; $rslt; } @@ -117,10 +116,13 @@ sub catfile { my($spath) = $path; $spath =~ s/.dir$//; if ( $spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { $rslt = "$spath$file"; } - else { $rslt = vmsify($self->eliminate_macros($spath).'/'.unixify($file)); } + else { + $rslt = $self->eliminate_macros($spath); + $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); + } } else { $rslt = vmsify($file); } - print "catfile($path,$file) = |$rslt|\n" if $Verbose >= 3; + print "catfile(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; $rslt; } @@ -197,6 +199,13 @@ sub find_perl{ } +sub path { + my(@dirs,$dir,$i); + while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } + @dirs; +} + + sub maybe_command { my($self,$file) = @_; return $file if -x $file && ! -d _; @@ -275,7 +284,7 @@ sub init_others { $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE}; $self->{NOECHO} ||= '@ '; $self->{RM_F} = '$(PERL) -e "foreach (@ARGV) { 1 while ( -d $_ ? rmdir $_ : unlink $_)}"'; - $self->{RM_RF} = '$(PERL) -e "use File::Path; @dirs = map(VMS::Filespec::unixify($_),@ARGV); rmtree(\@dirs,0,0)"'; + $self->{RM_RF} = '$(PERL) "-I$(PERL_LIB)" -e "use File::Path; @dirs = map(VMS::Filespec::unixify($_),@ARGV); rmtree(\@dirs,0,0)"'; $self->{TOUCH} = '$(PERL) -e "$t=time; foreach (@ARGV) { -e $_ ? utime($t,$t,@ARGV) : (open(F,qq(>$_)),close F)}"'; $self->{CHMOD} = '$(PERL) -e "chmod @ARGV"'; # expect Unix syntax from MakeMaker $self->{CP} = 'Copy/NoConfirm'; @@ -284,95 +293,14 @@ sub init_others { &ExtUtils::MM_Unix::init_others; } + sub constants { my($self) = @_; unless (ref $self){ ExtUtils::MakeMaker::TieAtt::warndirectuse((caller(0))[3]); $self = $ExtUtils::MakeMaker::Parent[-1]; } - my(@m,$def); - push @m, " -NAME = $self->{NAME} -DISTNAME = $self->{DISTNAME} -NAME_SYM = $self->{NAME_SYM} -VERSION = $self->{VERSION} -VERSION_SYM = $self->{VERSION_SYM} -VERSION_MACRO = VERSION -DEFINE_VERSION = ",'"$(VERSION_MACRO)=""$(VERSION)"""'," -XS_VERSION = $self->{XS_VERSION} -XS_VERSION_MACRO = XS_VERSION -XS_DEFINE_VERSION = ",'"$(XS_VERSION_MACRO)=""$(XS_VERSION)"""'," - -# In which library should we install this extension? -# This is typically the same as PERL_LIB. -# (also see INST_LIBDIR and relationship to ROOTEXT) -INST_LIB = ",$self->fixpath($self->{INST_LIB},1)," -INST_ARCHLIB = ",$self->fixpath($self->{INST_ARCHLIB},1)," -INST_EXE = ",$self->fixpath($self->{INST_EXE},1)," - -PREFIX = $self->{PREFIX} - -# AFS users will want to set the installation directories for -# the final 'make install' early without setting INST_LIB, -# INST_ARCHLIB, and INST_EXE for the testing phase -INSTALLPRIVLIB = ",$self->fixpath($self->{INSTALLPRIVLIB},1),' -INSTALLARCHLIB = ',$self->fixpath($self->{INSTALLARCHLIB},1),' -INSTALLBIN = ',$self->fixpath($self->{INSTALLBIN},1),' - -# Perl library to use when building the extension -PERL_LIB = ',$self->fixpath($self->{PERL_LIB},1),' -PERL_ARCHLIB = ',$self->fixpath($self->{PERL_ARCHLIB},1),' -LIBPERL_A = ',$self->fixpath($self->{LIBPERL_A}),' - -MAKEMAKER = ',$self->catfile($self->{PERL_LIB},'ExtUtils','MakeMaker.pm')," -MM_VERSION = $ExtUtils::MakeMaker::VERSION -FIRST_MAKEFILE = ",$self->fixpath($self->{FIRST_MAKEFILE}),' -MAKE_APERL_FILE = ',$self->fixpath($self->{MAKE_APERL_FILE})," - -PERLMAINCC = $self->{PERLMAINCC} -"; - - if ($self->{PERL_SRC}) { - push @m, " -# Where is the perl source code located? -PERL_SRC = ",$self->fixpath($self->{PERL_SRC},1); - push @m, " -PERL_VMS = ",$self->catdir($self->{PERL_SRC},q(VMS)); - } - push @m," -# Perl header files (will eventually be under PERL_LIB) -PERL_INC = ",$self->fixpath($self->{PERL_INC},1)," -# Perl binaries -PERL = $self->{PERL} -FULLPERL = $self->{FULLPERL} - -# FULLEXT = Pathname for extension directory (eg DBD/Oracle). -# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. -# ROOTEXT = Directory part of FULLEXT with leading slash (e.g /DBD) -FULLEXT = ",$self->fixpath($self->{FULLEXT},1)," -BASEEXT = $self->{BASEEXT} -ROOTEXT = ",($self->{ROOTEXT} eq '') ? '[]' : $self->fixpath($self->{ROOTEXT},1)," -DLBASE = $self->{DLBASE} -"; - - push @m, " -VERSION_FROM = $self->{VERSION_FROM} -" if defined $self->{VERSION_FROM}; - - push @m,' -INC = '; - - if ($self->{'INC'}) { - push @m,'/Include=('; - my(@includes) = split(/\s+/,$self->{INC}); - my($plural); - foreach (@includes) { - s/^-I//; - push @m,', ' if $plural++; - push @m,$self->fixpath($_,1); - } - push @m, ")\n"; - } + my(@m,$def,$macro); if ($self->{DEFINE} ne '') { my(@defs) = split(/\s+/,$self->{DEFINE}); @@ -390,35 +318,99 @@ INC = '; } $self->{LDFROM} = join(' ',map($self->fixpath($_),split(/,?\s+/,$self->{LDFROM}))); - push @m," -DEFINE = $self->{DEFINE} -OBJECT = $self->{OBJECT} -LDFROM = $self->{LDFROM} -LINKTYPE = $self->{LINKTYPE} + if ($self->{'INC'} && $self->{INC} !~ m!/Include=!i) { + my(@val) = ( '/Include=(' ); + my(@includes) = split(/\s+/,$self->{INC}); + my($plural); + foreach (@includes) { + s/^-I//; + push @val,', ' if $plural++; + push @val,$self->fixpath($_,1); + } + $self->{INC} = join('',@val,')'); + } + + # Fix up directory specs + $self->{ROOTEXT} = $self->{ROOTEXT} ? $self->fixpath($self->{ROOTEXT},1) + : '[]'; + foreach $macro ( qw [ + INST_LIB INST_ARCHLIB INST_EXE INSTALLPRIVLIB INSTALLARCHLIB + INSTALLBIN PERL_LIB PERL_ARCHLIB PERL_INC PERL_SRC FULLEXT + INST_MAN1DIR INSTALLMAN1DIR INST_MAN3DIR INSTALLMAN3DIR + INSTALLSITELIB INSTALLSITEARCH SITELIBEXP SITEARCHEXP ] ) { + next unless defined $self->{$macro}; + $self->{$macro} = $self->fixpath($self->{$macro},1); + } + $self->{PERL_VMS} = $self->catdir($self->{PERL_SRC},q(VMS)) + if ($self->{PERL_SRC}); + + + + # Fix up file specs + foreach $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKE_APERL_FILE MYEXTLIB] ) { + next unless defined $self->{$macro}; + $self->{$macro} = $self->fixpath($self->{$macro}); + } + + for $tmp (qw/ + AR_STATIC_ARGS NAME DISTNAME NAME_SYM VERSION VERSION_SYM XS_VERSION + INST_LIB INST_ARCHLIB INST_EXE PREFIX INSTALLDIRS INSTALLPRIVLIB + INSTALLARCHLIB INSTALLSITELIB INSTALLSITEARCH INSTALLBIN PERL_LIB + PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB + FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC PERL_VMS + PERL_INC PERL FULLPERL + / ) { + next unless defined $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } + + + push @m, q[ +VERSION_MACRO = VERSION +DEFINE_VERSION = "$(VERSION_MACRO)=""$(VERSION)""" +XS_VERSION_MACRO = XS_VERSION +XS_DEFINE_VERSION = "$(XS_VERSION_MACRO)=""$(XS_VERSION)""" + +MAKEMAKER = ],$self->catfile($self->{PERL_LIB},'ExtUtils','MakeMaker.pm'),qq[ +MM_VERSION = $ExtUtils::MakeMaker::VERSION +MM_REVISION = $ExtUtils::MakeMaker::Revision +MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision + +# FULLEXT = Pathname for extension directory (eg DBD/Oracle). +# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. +# ROOTEXT = Directory part of FULLEXT with leading slash (eg /DBD) +# DLBASE = Basename part of dynamic library. May be just equal BASEEXT. +]; + + for $tmp (qw/ + FULLEXT BASEEXT ROOTEXT DLBASE VERSION_FROM INC DEFINE OBJECT + LDFROM LINKTYPE + / ) { + next unless defined $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } + + push @m,' # Handy lists of source code files: -XS_FILES = ",join(', ', sort keys %{$self->{XS}}),' +XS_FILES = ',join(', ', sort keys %{$self->{XS}}),' C_FILES = ',join(', ', @{$self->{C}}),' O_FILES = ',join(', ', @{$self->{O_FILES}} ),' H_FILES = ',join(', ', @{$self->{H}}),' -MAN1PODS = ',join(" \\\n\t", sort keys %{$self->{MAN1PODS}}),' -MAN3PODS = ',join(" \\\n\t", sort keys %{$self->{MAN3PODS}}),' - -# Man installation stuff: -INST_MAN1DIR = ',$self->fixpath($self->{INST_MAN1DIR},1),' -INSTALLMAN1DIR = ',$self->fixpath($self->{INSTALLMAN1DIR},1)," -MAN1EXT = $self->{MAN1EXT} - -INST_MAN3DIR = ",$self->fixpath($self->{INST_MAN3DIR},1),' -INSTALLMAN3DIR = ',$self->fixpath($self->{INSTALLMAN3DIR},1)," -MAN3EXT = $self->{MAN3EXT} +MAN1PODS = ',join(', ', sort keys %{$self->{MAN1PODS}}),' +MAN3PODS = ',join(', ', sort keys %{$self->{MAN3PODS}}),' +'; -.SUFFIXES : .xs .c \$(OBJ_EXT) + for $tmp (qw/ + INST_MAN1DIR INSTALLMAN1DIR MAN1EXT INST_MAN3DIR INSTALLMAN3DIR MAN3EXT + /) { + next unless defined $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } -# This extension may link to it's own library (see SDBM_File)"; - push @m," -MYEXTLIB = ",$self->fixpath($self->{MYEXTLIB})," +push @m," +.SUFFIXES : .xs .c .cpp .cxx \$(OBJ_EXT) # Here is the Config.pm that we are using/depend on CONFIGDEP = \$(PERL_ARCHLIB)Config.pm, \$(PERL_INC)config.h \$(VERSION_FROM) @@ -696,7 +688,7 @@ sub tools_other { ExtUtils::MakeMaker::TieAtt::warndirectuse((caller(0))[3]); $self = $ExtUtils::MakeMaker::Parent[-1]; } - " + qq! # Assumes \$(MMS) invokes MMS or MMK # (It is assumed in some cases later that the default makefile name # (Descrip.MMS for MM[SK]) is used.) @@ -713,7 +705,12 @@ RM_F = $self->{RM_F} RM_RF = $self->{RM_RF} UMASK_NULL = $self->{UMASK_NULL} MKPATH = Create/Directory -"; +EQUALIZE_TIMESTAMP = \$(PERL) -we "open F,qq{>\$ARGV[1]};close F;utime(0,(stat(\$ARGV[0]))[9]+1,\$ARGV[1])" +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 '=head3 ',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);" +!; } @@ -808,7 +805,7 @@ sub top_targets { } my(@m); push @m, ' -all :: config $(INST_PM) subdirs linkext manifypods reorg_packlist +all :: config $(INST_PM) subdirs linkext manifypods $(NOOP) subdirs :: $(MYEXTLIB) @@ -817,13 +814,18 @@ subdirs :: $(MYEXTLIB) config :: $(MAKEFILE) $(INST_LIBDIR).exists $(NOOP) -config :: $(INST_ARCHAUTODIR).exists Version_check +config :: $(INST_ARCHAUTODIR).exists $(NOOP) config :: $(INST_AUTODIR).exists $(NOOP) '; + push @m, q{ +config :: Version_check + +} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl"); + push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]); if (%{$self->{MAN1PODS}}) { @@ -853,8 +855,7 @@ help : push @m, q{ Version_check : },$self->{NOECHO},q{$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" - - -e "use ExtUtils::MakeMaker qw($Version &Version_check);" - - -e "&Version_check('$(MM_VERSION)')" + "-MExtUtils::MakeMaker=Version_check" -e "&Version_check('$(MM_VERSION)')" }; join('',@m); @@ -871,17 +872,30 @@ sub dlsyms { return '' unless $self->needs_linking(); my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; - my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($srcdir)= $attribs{PERL_SRC} || $self->{PERL_SRC} || ''; my(@m); - push(@m,' + unless ($self->{SKIPHASH}{'dynamic'}) { + push(@m,' dynamic :: rtls.opt $(INST_ARCHAUTODIR)$(BASEEXT).opt $(NOOP) - +'); + if ($srcdir) { + my($opt) = $self->catfile($srcdir,'perlshr.opt'); + push(@m,"# Depend on $(BASEEXT).opt to insure we copy here *after* autogenerating (wrong) rtls.opt in Mksymlists +rtls.opt : $opt \$(BASEEXT).opt + Copy/Log $opt Sys\$Disk:[]rtls.opt +"); + } + else { + push(@m,' # rtls.opt is built in the same step as $(BASEEXT).opt rtls.opt : $(BASEEXT).opt $(TOUCH) $(MMS$TARGET) -') unless $self->{SKIPHASH}{'dynamic'}; +'); + } + } push(@m,' static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt @@ -891,7 +905,6 @@ static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt push(@m,' $(INST_ARCHAUTODIR)$(BASEEXT).opt : $(BASEEXT).opt $(CP) $(MMS$SOURCE) $(MMS$TARGET) - ',$self->{NOECHO},'$(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR).packlist\';print F qq[$(MMS$TARGET)\n];close F;" $(BASEEXT).opt : Makefile.PL $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Mksymlists;" - @@ -929,7 +942,6 @@ INST_DYNAMIC_DEP = $inst_dynamic_dep $(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt rtls.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) ',$self->{NOECHO},'$(MKPATH) $(INST_ARCHAUTODIR) Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,rtls.opt/Option,$(PERL_INC)perlshr_attr.opt/Option - ',$self->{NOECHO},'$(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR).packlist\';print F qq[$(MMS$TARGET)\n];close F;" '; push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); @@ -956,12 +968,10 @@ $(BOOTSTRAP) : $(MAKEFILE) '."$self->{BOOTDEP}".' $(INST_ARCHAUTODIR).exists '.$self->{NOECHO}.'$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" - -e "use ExtUtils::Mkbootstrap; Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');" '.$self->{NOECHO}.' $(TOUCH) $(MMS$TARGET) - '.$self->{NOECHO}.'$(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR).packlist\';print F qq[$(MMS$TARGET)\n];close F;" $(INST_BOOT) : $(BOOTSTRAP) $(INST_ARCHAUTODIR).exists '.$self->{NOECHO}.'$(RM_RF) $(INST_BOOT) - $(CP) $(BOOTSTRAP) $(INST_BOOT) - '.$self->{NOECHO}.'$(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR).packlist\';print F qq[$(MMS$TARGET)\n];close F;" '; } # --- Static Loading Sections --- @@ -994,7 +1004,6 @@ $(INST_STATIC) : $(OBJECT) $(MYEXTLIB) If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET) Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST) ',$self->{NOECHO},'$(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR)extralibs.ld\';print F qq[$(EXTRALIBS)\n];close F;" - ',$self->{NOECHO},'$(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR).packlist\';print F qq[$(MMS$TARGET)\n];close F;" '); push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); join('',@m); @@ -1021,7 +1030,6 @@ $inst : $dist \$(MAKEFILE) ${instdir}.exists \$(INST_ARCHAUTODIR).exists ",' ',$self->{NOECHO},'$(RM_F) $(MMS$TARGET) ',$self->{NOECHO},'$(CP) ',"$dist $inst",' $(CHMOD) 644 $(MMS$TARGET) - ',$self->{NOECHO},'$(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR).packlist\';print F qq[$(MMS$TARGET)\n];close F;" '); push(@m, ' $(AUTOSPLITFILE) $(MMS$TARGET) ', $self->catdir($splitlib,'auto')."\n\n") @@ -1155,25 +1163,6 @@ $to : $from \$(MAKEFILE) ${todir}.exists # --- Sub-directory Sections --- -sub pasthru { - my($self) = @_; - unless (ref $self){ - ExtUtils::MakeMaker::TieAtt::warndirectuse((caller(0))[3]); - $self = $ExtUtils::MakeMaker::Parent[-1]; - } - my(@m,$key); - my(@pasthru); - - foreach $key (qw(INSTALLPRIVLIB INSTALLARCHLIB INSTALLBIN - INSTALLMAN1DIR INSTALLMAN3DIR LIBPERL_A LINKTYPE)){ - push @pasthru, "$key=\"$self->{$key}\""; - } - - push @m, "\nPASTHRU = \\\n ", join (",\\\n ", @pasthru), "\n"; - join "", @m; -} - - sub subdir_x { my($self, $subdir) = @_; unless (ref $self){ @@ -1390,82 +1379,100 @@ sub install { ExtUtils::MakeMaker::TieAtt::warndirectuse((caller(0))[3]); $self = $ExtUtils::MakeMaker::Parent[-1]; } - my(@m); - push @m, q{ -doc_install :: - },$self->{NOECHO},q{Write Sys$Output "Appending installation info to $(INST_ARCHLIB)perllocal.pod" - },$self->{NOECHO},q{$(PERL) "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)" \\ - -e "use ExtUtils::MakeMaker; MY->new({})->writedoc('Module', '$(NAME)', \\ - 'LINKTYPE=$(LINKTYPE)', 'VERSION=$(VERSION)', 'XS_VERSION=$(XS_VERSION)', 'EXE_FILES=$(EXE_FILES)')" \\ - >>$(INSTALLARCHLIB)perllocal.pod -}; + my(@m,@docfiles); - push(@m, " -install :: pure_install doc_install - \$(NOOP) - -# Interim solution for VMS; assumes directory tree of same structure under -# both \$(INST_LIB) and \$(INSTALLPRIVLIB). This operation will be assumed -# into MakeMaker in a (near) future version. -pure_install :: all -"); -# # install subdirectories first -# foreach(@{$self->{DIR}}){ -# my($vmsdir) = $self->fixpath($_,1); -# push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir ',"'$vmsdir'", -# '; print `$(MMS) install`"'."\n"); -# } -# -# push(@m, ' ',$self->{NOECHO},'$(PERL) "-I$(PERL_LIB)" -e "use File::Path; mkpath(\@ARGV)" $(INSTALLPRIVLIB) $(INSTALLARCHLIB) -# ',$self->{NOECHO},'$(PERL) -e "die qq{You do not have permissions to install into $ARGV[0]\n} unless -w VMS::Filespec::fileify($ARGV[0])" $(INSTALLPRIVLIB) -# ',$self->{NOECHO},'$(PERL) -e "die qq{You do not have permissions to install into $ARGV[0]\n} unless -w VMS::Filespec::fileify($ARGV[0])" $(INSTALLARCHLIB)'," -# # Can't install manpages here -- INST_MAN%DIR macros make line >255 chars -# \$(MMS) \$(USEMACROS)INST_LIB=$self->{INSTALLPRIVLIB},INST_ARCHLIB=$self->{INSTALLARCHLIB},INST_EXE=$self->{INSTALLBIN}\$(MACROEND)",' -# ',$self->{NOECHO},'$(PERL) -i_bak -lne "print unless $seen{$_}++" $(INST_ARCHAUTODIR).packlist -#'); - - my($curtop,$insttop); - ($curtop = $self->fixpath($self->{INST_LIB},1)) =~ s/]$//; - ($insttop = $self->fixpath($self->{INSTALLPRIVLIB},1)) =~ s/]$//; - push(@m," Backup/Log ${curtop}...]*.*; ${insttop}...]/New_Version/By_Owner=Parent\n"); - - my($oldpacklist) = $self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist'); - push @m,' -# This song and dance brought to you by DCL\'s 255 char limit -reorg_packlist : -'; - my($oldpacklist) = $self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist'); - if ("\L$oldpacklist" ne "\L$self->{INST_ARCHAUTODIR}.packlist") { - push(@m,' If F$Search("',$oldpacklist,'").nes."" Then Append/New ',$oldpacklist,' $(INST_ARCHAUTODIR).packlist'); + if ($self->{EXE_FILES}) { + my($line,$file) = ('',''); + foreach $file (@{$self->{EXE_FILES}}) { + $line .= "$file "; + if (length($line) > 128) { + push(@docfiles,qq[\t\$(PERL) -e "print $line" >>.MM_tmp\n]); + $line = ''; + } + } + push(@docfiles,qq[\t\$(PERL) -e "print $line" >>.MM_tmp\n]) if $line; } - push @m,' - $(PERL) -ne "BEGIN{exit unless -e $ARGV[0];}print unless $s{$_}++;" $(INST_ARCHAUTODIR).packlist >.MM_tmp - If F$Search(".MM_tmp").nes."" Then Copy/NoConfirm .MM_tmp $(INST_ARCHAUTODIR).packlist - If F$Search(".MM_tmp").nes."" Then Delete/NoConfirm .MM_tmp; -'; - -# From MM 5.16: push @m, q[ -# Comment on .packlist rewrite above: -# Read both .packlist files: the old one in PERL_ARCHLIB/auto/FULLEXT, and the new one -# in INSTARCHAUTODIR. Don't croak if they are missing. Write to the one -# in INSTARCHAUTODIR. +install :: all pure_install doc_install + $(NOOP) + +install_perl :: all pure_perl_install doc_perl_install + $(NOOP) + +install_site :: all pure_site_install doc_site_install + $(NOOP) + +install_ :: install_site + ],$self->{NOECHO},q[Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + +pure_install :: pure_$(INSTALLDIRS)_install + $(NOOP) + +doc_install :: doc_$(INSTALLDIRS)_install + ],$self->{NOECHO},q[Write Sys$Output "Appending installation info to $(INST_ARCHLIB)perllocal.pod" + +pure__install : pure_site_install + ],$self->{NOECHO},q[Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + +doc__install : doc_site_install + ],$self->{NOECHO},q[Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + +# This hack brought to you by DCL's 255-character command line limit +pure_perl_install :: + ].$self->{NOECHO}.q[$(PERL) -e "print 'read ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print 'write ].$self->catfile('$(INSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_LIB) $(INSTALLPRIVLIB) '" >>.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLARCHLIB) '" >>.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_EXE) $(INSTALLBIN) '" >>.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN1DIR) $(INSTALLMAN1DIR) '" >>.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp + $(MOD_INSTALL) <.MM_tmp + ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp; + ].$self->{NOECHO}.q[$(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[ + +# Likewise +pure_site_install :: + ].$self->{NOECHO}.q[$(PERL) -e "print 'read ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print 'write ].$self->catfile('$(INSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_LIB) $(INSTALLSITELIB) '" >>.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLSITEARCH) '" >>.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_EXE) $(INSTALLBIN) '" >>.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN1DIR) $(INSTALLMAN1DIR) '" >>.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp + $(MOD_INSTALL) <.MM_tmp + ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp; + ].$self->{NOECHO}.q[$(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ + +# Ditto +doc_perl_install :: + ].$self->{NOECHO}.q[$(PERL) -e "print 'Module $(NAME)|installed into|$(INSTALLPRIVLIB)|'" >.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|'" >>.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|'" >>.MM_tmp +],@docfiles,q[ $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[ + ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp; + +# And again +doc_site_install :: + ].$self->{NOECHO}.q[$(PERL) -e "print 'Module $(NAME)|installed into|$(INSTALLSITELIB)|'" >.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|'" >>.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|'" >>.MM_tmp +],@docfiles,q[ $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[ + ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp; + ]; - push @m, ' -##### UNINSTALL IS STILL EXPERIMENTAL #### -uninstall :: -'; - foreach(@{$self->{DIR}}){ - my($vmsdir) = $self->fixpath($_,1); - push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir ',"'$vmsdir'", - '; print `$(MMS) uninstall`"'."\n"); - } - push @m, "\t".'$(PERL) -le "use File::Path; foreach (<>) {s/',"$curtop/$insttop/;",'rmtree($_,1,0);}" <$(INST_ARCHAUTODIR).packlist -'; + push @m, q[ +uninstall :: uninstall_from_$(INSTALLDIRS)dirs + $(NOOP) + +uninstall_from_perldirs :: + ].$self->{NOECHO}.q[$(UNINSTALL) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ + +uninstall_from_sitedirs :: + ].$self->{NOECHO}.q[$(UNINSTALL) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist')."\n"; - join("",@m); + join('',@m); } @@ -1533,7 +1540,7 @@ $(MAKEFILE) : Makefile.PL $(CONFIGDEP) ',$self->{NOECHO},'Write Sys$Output "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(' ',@ARGV),' + $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL ',join(' ',map(qq["$_"],@ARGV)),' ',$self->{NOECHO},'Write Sys$Output "$(MAKEFILE) has been rebuilt." ',$self->{NOECHO},'Write Sys$Output "Please run $(MMS) to build the extension." '; @@ -1562,13 +1569,14 @@ test : \$(TEST_TYPE) push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir ',"'$vmsdir'", '; print `$(MMS) $(PASTHRU2) test`'."\n"); } - push(@m, "\t$self->{NOECHO}Write Sys\$Output 'No tests defined for \$(NAME) extension.'\n") + push(@m, "\t$self->{NOECHO}Write Sys\$Output \"No tests defined for \$(NAME) extension.\"\n") unless $tests or -f "test.pl" or @{$self->{DIR}}; push(@m, "\n"); push(@m, "test_dynamic :: all\n"); push(@m, $self->test_via_harness('$(FULLPERL)', $tests)) if $tests; push(@m, $self->test_via_script('$(FULLPERL)', 'test.pl')) if -f "test.pl"; + push(@m, " \$(NOOP)\n") if (!$tests && ! -f "test.pl"); push(@m, "\n"); # Occasionally we may face this degenerate target: @@ -1578,10 +1586,11 @@ test : \$(TEST_TYPE) push(@m, "test_static :: all \$(MAP_TARGET)\n"); push(@m, $self->test_via_harness('$(MAP_TARGET)', $tests)) if $tests; push(@m, $self->test_via_script('$(MAP_TARGET)', 'test.pl')) if -f "test.pl"; + push(@m, "\t$self->{NOECHO}\$(NOOP)\n") if (!$tests && ! -f "test.pl"); push(@m, "\n"); } else { - push @m, "test_static :: test_dynamic\n"; + push @m, "test_static :: test_dynamic\n\t$self->{NOECHO}\$(NOOP)\n"; } join('',@m); @@ -1605,7 +1614,7 @@ sub test_via_script { ExtUtils::MakeMaker::TieAtt::warndirectuse((caller(0))[3]); $self = $ExtUtils::MakeMaker::Parent[-1]; } - " $perl".' "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" test.pl + " $perl".' "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '.$script.' '; } @@ -1757,10 +1766,16 @@ $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmp}perlmain\$(OBJ_EXT) ${tmp}PerlShr.Opt" ',$self->{NOECHO},'$(PERL) $(MAP_PERLINC) -e "use ExtUtils::Miniperl; writemain(qw|',@staticpkgs,'|)" >$(MMS$TARGET) '; - push @m, q{ + push @m, q[ +# More from the 255-char line length limit doc_inst_perl : - },$self->{NOECHO},q{$(PERL) -e "use ExtUtils::MakeMaker; MY->new()->writedoc('Perl binary','$(MAP_TARGET)','MAP_STATIC=$(MAP_STATIC)','MAP_EXTRA=$(MAP_EXTRA)','MAP_LIBPERL=$(MAP_LIBPERL)')" -}; + ].$self->{NOECHO}.q[$(PERL) -e "print 'Perl binary $(MAP_TARGET)|'" >.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print 'MAP_STATIC|$(MAP_STATIC)|'" >>.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp + ].$self->{NOECHO}.q[$(PERL) -e "print 'MAP_LIBPERL|$(MAP_LIBPERL)|'" >>.MM_tmp + $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[ + ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp; +]; push @m, " inst_perl : pure_inst_perl doc_inst_perl @@ -1781,7 +1796,7 @@ map_clean : join '', @m; } -sub extliblist { +sub ext { my($self) = @_; unless (ref $self){ ExtUtils::MakeMaker::TieAtt::warndirectuse((caller(0))[3]); @@ -1795,9 +1810,9 @@ sub extliblist { # dir_target(@array) returns a Makefile entry for the file .exists in each # named directory. Returns nothing, if the entry has already been processed. # We're helpless though, if the same directory comes as $(FOO) _and_ as "bar". -# Both of them get an entry, that's why we use "::". I chose '$(PERL)' as the -# prerequisite, because there has to be one, something that doesn't change -# too often :) +# Both of them get an entry, that's why we use "::". I chose +# '$(PERL_INC)perl.h' as the prerequisite, because there has to be one, +# something that doesn't change too often :) sub dir_target { my($self,@dirs) = @_; @@ -1812,7 +1827,7 @@ sub dir_target { push @m, " ${vmsdir}.exists :: \$(PERL_INC)perl.h $self->{NOECHO}\$(MKPATH) $vmsdir - $self->{NOECHO}\$(TOUCH) ${vmsdir}.exists + $self->{NOECHO}\$(EQUALIZE_TIMESTAMP) \$(MMS\$SOURCE) \$(MMS\$TARGET) "; } join "", @m; @@ -1844,9 +1859,12 @@ __END__ ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker +=head1 SYNOPSIS + + use ExtUtils::MM_VMS; # Done internally by ExtUtils::MakeMaker if needed + =head1 DESCRIPTION See ExtUtils::MM_Unix for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. - diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 76486b1c4c..f2ee0ce797 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -160,15 +160,20 @@ eval {require DynaLoader;}; # Get mod2fname, if defined. Will fail } # -# No we can can pull in the friends +# Now we can can pull in the friends +# Since they will require us back, we would better prepare the needed +# data _before_ we require them. # +$Is_VMS = ($Config{osname} eq 'VMS'); +$Is_OS2 = ($Config{osname} =~ m|^os/?2$|i); + require ExtUtils::MM_Unix; -if ($Is_VMS = ($Config{osname} eq 'VMS')) { +if ($Is_VMS) { require ExtUtils::MM_VMS; require VMS::Filespec; import VMS::Filespec '&vmsify'; } -if ($Is_OS2 = $Config{osname} =~ m|^os/?2$|i) { +if ($Is_OS2) { require ExtUtils::MM_OS2; } @@ -568,7 +573,7 @@ sub parse_args{ $value = $self->catdir("..",$value) if $Prepend_dot_dot{$name} && ! $value =~ m!^/!; } - $self->{$name} = $value; + $self->{uc($name)} = $value; } # This may go away, in mid 1996 delete $self->{Correct_relativ_directories}; @@ -1758,7 +1763,7 @@ An example: Andy Dougherty F<E<lt>doughera@lafcol.lafayette.eduE<gt>>, Andreas KE<ouml>nig F<E<lt>A.Koenig@franz.ww.TU-Berlin.DEE<gt>>, Tim Bunce F<E<lt>Tim.Bunce@ig.co.ukE<gt>>. VMS support by Charles Bailey -F<E<lt>bailey@HMIVAX.HUMGEN.UPENN.EDUE<gt>>. OS/2 support by Ilya +F<E<lt>bailey@genetics.upenn.eduE<gt>>. OS/2 support by Ilya Zakharevich F<E<lt>ilya@math.ohio-state.eduE<gt>>. Contact the makemaker mailing list C<mailto:makemaker@franz.ww.tu-berlin.de>, if you have any questions. diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index aa21f4388d..1d7ae8c669 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -169,8 +169,8 @@ from which it is usually taken. Its value is a reference to an associative array, in which each key is the name of a package, and each value is an a reference to an array of function names which should be exported by the extension. For instance, one might say -C<DL_FUNCS => { Homer::Iliad => [ qw(trojans greeks) ], -Homer::Odyssey => [ qw(travellers family suitors) ] }>. The +C<DL_FUNCS =E<gt> { Homer::Iliad =E<gt> [ qw(trojans greeks) ], +Homer::Odyssey =E<gt> [ qw(travellers family suitors) ] }>. The function names should be identical to those in the XSUB code; C<Mksymlists> will alter the names written to the linker option file to match the changes made by F<xsubpp>. In addition, if @@ -221,4 +221,4 @@ Charles Bailey I<E<lt>bailey@genetics.upenn.eduE<gt>> =head1 REVISION -Last revised 14-Jan-1996, for Perl 5.002. +Last revised 14-Feb-1996, for Perl 5.002. diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index b4a075dbe1..62697456b7 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -24,6 +24,10 @@ sub copy { croak("Usage: copy( file1, file2 [, buffersize]) ") unless(@_ == 2 || @_ == 3); + # VMS: perform RMS copy to preserve file attributes, indices, etc. + # This function is always defined under VMS, even in miniperl + if (defined(&File::Copy::rmscopy)) { return File::Copy::rmscopy($_[0],$_[1]) } + my $from = shift; my $to = shift; my $recsep = $\; @@ -99,11 +103,12 @@ sub copy { 1; __END__ + =head1 NAME File::Copy - Copy files or filehandles -=head1 USAGE +=head1 SYNOPSIS use File::Copy; @@ -133,6 +138,10 @@ being written to the second file. The default buffer size depends upon the file, but will generally be the whole file (up to 2Mb), or 1k for filehandles that do not reference files (eg. sockets). +When running under VMS, this routine performs an RMS copy of +the file, in order to preserve file attributed, indexed file +structure, I<etc.> The buffer size parameter is ignored. + You may use the syntax C<use File::Copy "cp"> to get at the "cp" alias for this function. The syntax is I<exactly> the same. diff --git a/lib/File/Path.pm b/lib/File/Path.pm index 6cb675b683..8a17173b0d 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -73,7 +73,8 @@ than VMS is settled. (defaults to FALSE) =back -It returns the number of files successfully deleted. +It returns the number of files successfully deleted. Symlinks are +treated as ordinary files. =head1 AUTHORS @@ -82,10 +83,13 @@ Charles Bailey <bailey@genetics.upenn.edu> =head1 REVISION -This document was last revised 25-Aug-1995, for perl 5.002 +This module was last revised 14-Feb-1996, for perl 5.002. $VERSION is +1.01. =cut +$VERSION = "1.01"; # That's my hobby-horse, A.K. + require 5.000; use Config; use Carp; @@ -95,7 +99,7 @@ require Exporter; $Is_VMS = $Config{'osname'} eq 'VMS'; -sub mkpath{ +sub mkpath { my($paths, $verbose, $mode) = @_; # $paths -- either a path string or ref to list of paths # $verbose -- optional print "mkdir $path" for each directory created @@ -126,7 +130,7 @@ sub rmtree { foreach $root (@{$roots}) { $root =~ s#/$##; - if (-d $root) { + if (not -l $root and -d _) { opendir(D,$root); ($root = VMS::Filespec::unixify($root)) =~ s#\.dir$## if $Is_VMS; @files = map("$root/$_", grep $_!~/^\.{1,2}$/, readdir(D)); @@ -147,7 +151,7 @@ sub rmtree { next; } print "unlink $root\n" if $verbose; - while (-e $root) { # delete all versions under VMS + while (-e $root || -l $root) { # delete all versions under VMS (unlink($root) && ++$count) or carp "Can't unlink file $root: $!"; } diff --git a/lib/I18N/Collate.pm b/lib/I18N/Collate.pm index d012fcc5ce..0d8314e12e 100644 --- a/lib/I18N/Collate.pm +++ b/lib/I18N/Collate.pm @@ -99,7 +99,7 @@ require Exporter; @EXPORT = qw(collate_xfrm setlocale LC_COLLATE); @EXPORT_OK = qw(); -%OVERLOAD = qw( +use overload qw( fallback 1 cmp collate_cmp ); diff --git a/lib/Math/BigFloat.pm b/lib/Math/BigFloat.pm index 92e701666f..7551ad01a3 100644 --- a/lib/Math/BigFloat.pm +++ b/lib/Math/BigFloat.pm @@ -5,31 +5,31 @@ use Math::BigInt; use Exporter; # just for use to be happy @ISA = (Exporter); -%OVERLOAD = ( - # Anonymous subroutines: -'+' => sub {new BigFloat &fadd}, -'-' => sub {new BigFloat +use overload +'+' => sub {new Math::BigFloat &fadd}, +'-' => sub {new Math::BigFloat $_[2]? fsub($_[1],${$_[0]}) : fsub(${$_[0]},$_[1])}, -'<=>' => sub {new BigFloat +'<=>' => sub {new Math::BigFloat $_[2]? fcmp($_[1],${$_[0]}) : fcmp(${$_[0]},$_[1])}, -'cmp' => sub {new BigFloat +'cmp' => sub {new Math::BigFloat $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, -'*' => sub {new BigFloat &fmul}, -'/' => sub {new BigFloat +'*' => sub {new Math::BigFloat &fmul}, +'/' => sub {new Math::BigFloat $_[2]? scalar fdiv($_[1],${$_[0]}) : scalar fdiv(${$_[0]},$_[1])}, -'neg' => sub {new BigFloat &fneg}, -'abs' => sub {new BigFloat &fabs}, +'neg' => sub {new Math::BigFloat &fneg}, +'abs' => sub {new Math::BigFloat &fabs}, qw( "" stringify 0+ numify) # Order of arguments unsignificant -); +; sub new { - my $foo = fnorm($_[1]); - panic("Not a number initialized to BigFloat") if $foo eq "NaN"; - bless \$foo; + my ($class) = shift; + my ($foo) = fnorm(shift); + panic("Not a number initialized to Math::BigFloat") if $foo eq "NaN"; + bless \$foo, $class; } sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead # comparing to direct compilation based on @@ -58,21 +58,6 @@ sub stringify { return $n; } -# Arbitrary length float math package -# -# by Mark Biggar -# -# number format -# canonical strings have the form /[+-]\d+E[+-]\d+/ -# Input values can have inbedded whitespace -# Error returns -# 'NaN' An input parameter was "Not a Number" or -# divide by zero or sqrt of negative number -# Division is computed to -# max($div_scale,length(dividend)+length(divisor)) -# digits by default. -# Also used for default sqrt scale - $div_scale = 40; # Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'. @@ -84,21 +69,6 @@ sub fneg; sub fabs; sub fcmp; sub fround; sub ffround; sub fnorm; sub fsqrt; -# bigfloat routines -# -# fadd(NSTR, NSTR) return NSTR addition -# fsub(NSTR, NSTR) return NSTR subtraction -# fmul(NSTR, NSTR) return NSTR multiplication -# fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places -# fneg(NSTR) return NSTR negation -# fabs(NSTR) return NSTR absolute value -# fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0 -# fround(NSTR, SCALE) return NSTR round to SCALE digits -# ffround(NSTR, SCALE) return NSTR round at SCALEth place -# fnorm(NSTR) return (NSTR) normalize -# fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places - - # Convert a number to canonical string form. # Takes something that looks like a number and converts it to # the form /^[+-]\d+E[+-]\d+$/. @@ -154,7 +124,7 @@ sub fmul { #(fnum_str, fnum_str) return fnum_str &norm(Math::BigInt::bmul($xm,$ym),$xe+$ye); } } - + # addition sub fadd { #(fnum_str, fnum_str) return fnum_str local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1])); @@ -192,7 +162,7 @@ sub fdiv #(fnum_str, fnum_str[,scale]) return fnum_str $xe-$ye-$scale); } } - + # round int $q based on fraction $r/$base using $rnd_mode sub round { #(int_str, int_str, int_str) return int_str local($q,$r,$base) = @_; @@ -233,7 +203,7 @@ sub fround { #(fnum_str, scale) return fnum_str } } } - + # round $x at the 10 to the $scale digit place sub ffround { #(fnum_str, scale) return fnum_str local($x,$scale) = (fnorm($_[$[]),$_[$[+1]); @@ -273,7 +243,7 @@ sub fcmp #(fnum_str, fnum_str) return cond_code ); } } - + # square root by Newtons method. sub fsqrt { #(fnum_str[, scale]) return fnum_str local($x, $scale) = (fnorm($_[$[]), $_[$[+1]); @@ -290,8 +260,67 @@ sub fsqrt { #(fnum_str[, scale]) return fnum_str $guess = fmul(fadd($guess,fdiv($x,$guess,$gs*2)),".5"); $gs *= 2; } - new BigFloat &fround($guess, $scale); + new Math::BigFloat &fround($guess, $scale); } } 1; +__END__ + +=head1 NAME + +Math::BigFloat - Arbitrary length float math package + +=head1 SYNOPSIS + + use Math::BogFloat; + $f = Math::BigFloat->new($string); + + $f->fadd(NSTR) return NSTR addition + $f->fsub(NSTR) return NSTR subtraction + $f->fmul(NSTR) return NSTR multiplication + $f->fdiv(NSTR[,SCALE]) returns NSTR division to SCALE places + $f->fneg() return NSTR negation + $f->fabs() return NSTR absolute value + $f->fcmp(NSTR) return CODE compare undef,<0,=0,>0 + $f->fround(SCALE) return NSTR round to SCALE digits + $f->ffround(SCALE) return NSTR round at SCALEth place + $f->fnorm() return (NSTR) normalize + $f->fsqrt([SCALE]) return NSTR sqrt to SCALE places + +=head1 DESCRIPTION + +All basic math operations are overloaded if you declare your big +floats as + + $float = new Math::BigFloat "2.123123123123123123123123123123123"; + +=over 2 + +=item number format + +canonical strings have the form /[+-]\d+E[+-]\d+/ . Input values can +have inbedded whitespace. + +=item Error returns 'NaN' + +An input parameter was "Not a Number" or divide by zero or sqrt of +negative number. + +=item Division is computed to + +C<max($div_scale,length(dividend)+length(divisor))> digits by default. +Also used for default sqrt scale. + +=back + +=head1 BUGS + +The current version of this module is a preliminary version of the +real thing that is currently (as of perl5.002) under development. + +=head1 AUTHOR + +Mark Biggar + +=cut diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm index 8c0ca4e6d4..68856aea6e 100644 --- a/lib/Math/BigInt.pm +++ b/lib/Math/BigInt.pm @@ -1,7 +1,6 @@ package Math::BigInt; -%OVERLOAD = ( - # Anonymous subroutines: +use overload '+' => sub {new Math::BigInt &badd}, '-' => sub {new Math::BigInt $_[2]? bsub($_[1],${$_[0]}) : bsub(${$_[0]},$_[1])}, @@ -23,57 +22,24 @@ package Math::BigInt; qw( "" stringify 0+ numify) # Order of arguments unsignificant -); +; $NaNOK=1; sub new { - my $foo = bnorm($_[1]); + my($class) = shift; + my($foo) = bnorm(shift); die "Not a number initialized to Math::BigInt" if !$NaNOK && $foo eq "NaN"; - bless \$foo; + bless \$foo, $class; } sub stringify { "${$_[0]}" } sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead # comparing to direct compilation based on # stringify -# arbitrary size integer math package -# -# by Mark Biggar -# -# Canonical Big integer value are strings of the form -# /^[+-]\d+$/ with leading zeros suppressed -# Input values to these routines may be strings of the form -# /^\s*[+-]?[\d\s]+$/. -# Examples: -# '+0' canonical zero value -# ' -123 123 123' canonical value '-123123123' -# '1 23 456 7890' canonical value '+1234567890' -# Output values always always in canonical form -# -# Actual math is done in an internal format consisting of an array -# whose first element is the sign (/^[+-]$/) and whose remaining -# elements are base 100000 digits with the least significant digit first. -# The string 'NaN' is used to represent the result when input arguments -# are not numbers, as well as the result of dividing by zero -# -# routines provided are: -# -# bneg(BINT) return BINT negation -# babs(BINT) return BINT absolute value -# bcmp(BINT,BINT) return CODE compare numbers (undef,<0,=0,>0) -# badd(BINT,BINT) return BINT addition -# bsub(BINT,BINT) return BINT subtraction -# bmul(BINT,BINT) return BINT multiplication -# bdiv(BINT,BINT) return (BINT,BINT) division (quo,rem) just quo if scalar -# bmod(BINT,BINT) return BINT modulus -# bgcd(BINT,BINT) return BINT greatest common divisor -# bnorm(BINT) return BINT normalization -# - $zero = 0; - + # normalize string form of number. Strip leading zeros. Strip any # white space and add a sign, if missing. # Strings that are not numbers result the value 'NaN'. @@ -125,7 +91,7 @@ sub abs { # post-normalized abs for internal use s/^-/+/; $_; } - + # Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort) sub bcmp { #(num_str, num_str) return cond_code local($x,$y) = (&bnorm($_[$[]),&bnorm($_[$[+1])); @@ -186,7 +152,7 @@ sub bgcd { #(num_str, num_str) return num_str $x; } } - + # routine to add two base 1e5 numbers # stolen from Knuth Vol 2 Algorithm A pg 231 # there are separate routines to add and sub as per Kunth pg 233 @@ -252,7 +218,7 @@ sub mul { #(*int_num_array, *int_num_array) return int_num_array sub bmod { #(num_str, num_str) return num_str (&bdiv(@_))[$[+1]; } - + sub bdiv { #(dividend: num_str, divisor: num_str) return num_str local (*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1])); return wantarray ? ('NaN','NaN') : 'NaN' @@ -347,3 +313,74 @@ sub bpow { #(num_str, num_str) return num_str } 1; +__END__ + +=head1 NAME + +Math::BigInt - Arbitrary size integer math package + +=head1 SYNOPSIS + + use Math::BigInt; + $i = Math::BigInt->new($string); + + $i->bneg return BINT negation + $i->babs return BINT absolute value + $i->bcmp(BINT) return CODE compare numbers (undef,<0,=0,>0) + $i->badd(BINT) return BINT addition + $i->bsub(BINT) return BINT subtraction + $i->bmul(BINT) return BINT multiplication + $i->bdiv(BINT) return (BINT,BINT) division (quo,rem) just quo if scalar + $i->bmod(BINT) return BINT modulus + $i->bgcd(BINT) return BINT greatest common divisor + $i->bnorm return BINT normalization + +=head1 DESCRIPTION + +All basic math operations are overloaded if you declare your big +integers as + + $i = new Math::BigInt '123 456 789 123 456 789'; + + +=over 2 + +=item Canonical notation + +Big integer value are strings of the form C</^[+-]\d+$/> with leading +zeros suppressed. + +=item Input + +Input values to these routines may be strings of the form +C</^\s*[+-]?[\d\s]+$/>. + +=item Output + +Output values always always in canonical form + +=back + +Actual math is done in an internal format consisting of an array +whose first element is the sign (/^[+-]$/) and whose remaining +elements are base 100000 digits with the least significant digit first. +The string 'NaN' is used to represent the result when input arguments +are not numbers, as well as the result of dividing by zero. + +=head1 EXAMPLES + + '+0' canonical zero value + ' -123 123 123' canonical value '-123123123' + '1 23 456 7890' canonical value '+1234567890' + + +=head1 BUGS + +The current version of this module is a preliminary version of the +real thing that is currently (as of perl5.002) under development. + +=head1 AUTHOR + +Mark Biggar, overloaded interface by Ilya Zakharevich. + +=cut diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index a5a40b2486..969f3c2c79 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -1,18 +1,3 @@ -# -# Perl5 Package for complex numbers -# -# 1994 by David Nadler -# Coding know-how provided by Tom Christiansen, Tim Bunce, and Larry Wall -# sqrt() added by Tom Christiansen; beware should have two roots, -# but only returns one. (use wantarray?) -# -# -# The functions "Re", "Im", and "arg" are provided. -# "~" is used as the conjugation operator and "abs" is overloaded. -# -# Transcendental functions overloaded: so far only sin, cos, and exp. -# - package Math::Complex; require Exporter; @@ -21,7 +6,7 @@ require Exporter; # just to make use happy -%OVERLOAD= ( +use overload '+' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]}); bless [ $x1+$x2, $y1+$y2]; }, @@ -95,12 +80,12 @@ require Exporter; }, qw("" stringify) -); +; sub new { - shift; + my $class = shift; my @C = @_; - bless \@C; + bless \@C, $class; } sub Re { @@ -134,3 +119,45 @@ sub stringify { $_ = 0 if ($_ eq ''); return $_; } + +1; +__END__ + +=head1 NAME + +Math::Complex - complex numbers package + +=head1 SYNOPSIS + + use Math::Complex; + $i = new Math::Complex; + +=head1 DESCRIPTION + +Complex numbers declared as + + $i = Math::Complex->new(1,1); + +can be manipulated with overloaded math operators. The operators + + + - * / neg ~ abs cos sin exp sqrt + +are supported as well as + + "" (stringify) + +The methods + + Re Im arg + +are also provided. + +=head1 BUGS + +sqrt() should return two roots, but only returns one. + +=head1 AUTHORS + +Dave Nadler, Tom Christiansen, Tim Bunce, Larry Wall. + +=cut diff --git a/lib/Shell.pm b/lib/Shell.pm index 021f175947..bb44b5398b 100644 --- a/lib/Shell.pm +++ b/lib/Shell.pm @@ -75,3 +75,52 @@ AUTOLOAD { } 1; +__END__ + +=head1 NAME + +Shell - run shell commands transparently within perl + +=head1 SYNOPSIS + +See below. + +=head1 DESCRIPTION + + Date: Thu, 22 Sep 94 16:18:16 -0700 + Message-Id: <9409222318.AA17072@scalpel.netlabs.com> + To: perl5-porters@isu.edu + From: Larry Wall <lwall@scalpel.netlabs.com> + Subject: a new module I just wrote + +Here's one that'll whack your mind a little out. + + #!/usr/bin/perl + + use Shell; + + $foo = echo("howdy", "<funny>", "world"); + print $foo; + + $passwd = cat("</etc/passwd"); + print $passwd; + + sub ps; + print ps -ww; + + cp("/etc/passwd", "/tmp/passwd"); + +That's maybe too gonzo. It actually exports an AUTOLOAD to the current +package (and uncovered a bug in Beta 3, by the way). Maybe the usual +usage should be + + use Shell qw(echo cat ps cp); + +Larry + + +=head1 AUTHOR + +Larry Wall + +=cut diff --git a/lib/Text/ParseWords.pm b/lib/Text/ParseWords.pm index 89278501d1..97d7beb896 100644 --- a/lib/Text/ParseWords.pm +++ b/lib/Text/ParseWords.pm @@ -9,43 +9,76 @@ use Carp; @EXPORT = qw(shellwords quotewords); @EXPORT_OK = qw(old_shellwords); -# This code needs updating to use new Perl 5 features (regexp etc). - -# ParseWords.pm -# -# Usage: -# use ParseWords; -# @words = "ewords($delim, $keep, @lines); -# @words = &shellwords(@lines); -# @words = &old_shellwords(@lines); - -# Hal Pomeranz (pomeranz@netcom.com), 23 March 1994 -# Permission to use and distribute under the same terms as Perl. -# No warranty expressed or implied. - -# Basically an update and generalization of the old shellwords.pl. -# Much code shamelessly stolen from the old version (author unknown). -# -# "ewords() accepts a delimiter (which can be a regular expression) -# and a list of lines and then breaks those lines up into a list of -# words ignoring delimiters that appear inside quotes. -# -# The $keep argument is a boolean flag. If true, the quotes are kept -# with each word, otherwise quotes are stripped in the splitting process. -# $keep also defines whether unprotected backslashes are retained. -# +=head1 NAME -1; -__END__ +Text::ParseWords - parse text into an array of tokens +=head1 SYNOPSIS -sub shellwords { + use Text::ParseWords; + @words = "ewords($delim, $keep, @lines); + @words = &shellwords(@lines); + @words = &old_shellwords(@lines); + +=head1 DESCRIPTION + +"ewords() accepts a delimiter (which can be a regular expression) +and a list of lines and then breaks those lines up into a list of +words ignoring delimiters that appear inside quotes. + +The $keep argument is a boolean flag. If true, the quotes are kept +with each word, otherwise quotes are stripped in the splitting process. +$keep also defines whether unprotected backslashes are retained. + +A &shellwords() replacement is included to demonstrate the new package. +This version differs from the original in that it will _NOT_ default +to using $_ if no arguments are given. I personally find the old behavior +to be a mis-feature. + + +"ewords() works by simply jamming all of @lines into a single +string in $_ and then pulling off words a bit at a time until $_ +is exhausted. + +The inner "for" loop builds up each word (or $field) one $snippet +at a time. A $snippet is a quoted string, a backslashed character, +or an unquoted string. We fall out of the "for" loop when we reach +the end of $_ or when we hit a delimiter. Falling out of the "for" +loop, we push the $field we've been building up onto the list of +@words we'll be returning, and then loop back and pull another word +off of $_. + +The first two cases inside the "for" loop deal with quoted strings. +The first case matches a double quoted string, removes it from $_, +and assigns the double quoted string to $snippet in the body of the +conditional. The second case handles single quoted strings. In +the third case we've found a quote at the current beginning of $_, +but it didn't match the quoted string regexps in the first two cases, +so it must be an unbalanced quote and we croak with an error (which can +be caught by eval()). - # A &shellwords() replacement is included to demonstrate the new package. - # This version differs from the original in that it will _NOT_ default - # to using $_ if no arguments are given. I personally find the old behavior - # to be a mis-feature. +The next case handles backslashed characters, and the next case is the +exit case on reaching the end of the string or finding a delimiter. +Otherwise, we've found an unquoted thing and we pull of characters one +at a time until we reach something that could start another $snippet-- +a quote of some sort, a backslash, or the delimiter. This one character +at a time behavior was necessary if the delimiter was going to be a +regexp (love to hear it if you can figure out a better way). + +=head1 AUTHORS + +Hal Pomeranz (pomeranz@netcom.com), 23 March 1994 + +Basically an update and generalization of the old shellwords.pl. +Much code shamelessly stolen from the old version (author unknown). + +=cut + +1; +__END__ + +sub shellwords { local(@lines) = @_; $lines[$#lines] =~ s/\s+$//; "ewords('\s+', 0, @lines); @@ -54,37 +87,6 @@ sub shellwords { sub quotewords { - -# "ewords() works by simply jamming all of @lines into a single -# string in $_ and then pulling off words a bit at a time until $_ -# is exhausted. -# -# The inner "for" loop builds up each word (or $field) one $snippet -# at a time. A $snippet is a quoted string, a backslashed character, -# or an unquoted string. We fall out of the "for" loop when we reach -# the end of $_ or when we hit a delimiter. Falling out of the "for" -# loop, we push the $field we've been building up onto the list of -# @words we'll be returning, and then loop back and pull another word -# off of $_. -# -# The first two cases inside the "for" loop deal with quoted strings. -# The first case matches a double quoted string, removes it from $_, -# and assigns the double quoted string to $snippet in the body of the -# conditional. The second case handles single quoted strings. In -# the third case we've found a quote at the current beginning of $_, -# but it didn't match the quoted string regexps in the first two cases, -# so it must be an unbalanced quote and we croak with an error (which can -# be caught by eval()). -# -# The next case handles backslashed characters, and the next case is the -# exit case on reaching the end of the string or finding a delimiter. -# -# Otherwise, we've found an unquoted thing and we pull of characters one -# at a time until we reach something that could start another $snippet-- -# a quote of some sort, a backslash, or the delimiter. This one character -# at a time behavior was necessary if the delimiter was going to be a -# regexp (love to hear it if you can figure out a better way). - local($delim, $keep, @lines) = @_; local(@words,$snippet,$field,$_); diff --git a/lib/lib.pm b/lib/lib.pm index ab19426b04..546ae87b89 100644 --- a/lib/lib.pm +++ b/lib/lib.pm @@ -10,7 +10,7 @@ my $archname = $Config{'archname'}; sub import { shift; - foreach (@_) { + foreach (reverse @_) { unshift(@INC, $_); # Put a corresponding archlib directory infront of $_ if it # looks like $_ has an archlib directory below it. diff --git a/makeaperl.SH b/makeaperl.SH index 6af94195d0..6af94195d0 100755..100644 --- a/makeaperl.SH +++ b/makeaperl.SH @@ -461,7 +461,11 @@ MAGIC *mg; sv_setpv(sv,ofmt); break; case '!': +#ifdef VMS + sv_setnv(sv,(double)((errno == EVMSERR) ? vaxc$errno : errno)); +#else sv_setnv(sv,(double)errno); +#endif sv_setpv(sv, errno ? Strerror(errno) : ""); SvNOK_on(sv); /* what a wonderful hack! */ break; @@ -1137,7 +1141,7 @@ MAGIC* mg; statusvalue = FIXSTATUS(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '!': - SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),SS$_ABORT); /* will anyone ever use this? */ + SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),4); /* will anyone ever use this? */ break; case '<': uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -23,7 +23,7 @@ #ifdef USE_OP_MASK /* * In the following definition, the ", (OP *) op" is just to make the compiler - * think the expression is of the right type: croak actually does a longjmp. + * think the expression is of the right type: croak actually does a Siglongjmp. */ #define CHECKOP(type,op) \ ((op_mask && op_mask[type]) \ @@ -190,7 +190,7 @@ pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix) SvFLAGS(sv) |= SVf_FAKE; } av_store(comppad, newoff, SvREFCNT_inc(oldsv)); - SvFLAGS(compcv) |= SVpcv_CLONE; + CvCLONE_on(compcv); return newoff; } } @@ -1424,10 +1424,12 @@ register OP *o; if (curop->op_type == OP_PADSV || curop->op_type == OP_RV2SV) { if (vars++) return o; - if ((o->op_type == OP_LT && curop == ((BINOP*)o)->op_first) || - (o->op_type == OP_GT && curop == ((BINOP*)o)->op_last)) + if (((o->op_type == OP_LT || o->op_type == OP_GE) && + curop == ((BINOP*)o)->op_first ) || + ((o->op_type == OP_GT || o->op_type == OP_LE) && + curop == ((BINOP*)o)->op_last )) { - /* Allow "$i < 100" and "100 > $i" to integerize */ + /* Allow "$i < 100" and variants to integerize */ continue; } } @@ -2210,6 +2212,8 @@ OP *right; tmpop->op_sibling = Nullop; /* don't free split */ right->op_next = tmpop->op_next; /* fix starting loc */ op_free(op); /* blow off assign */ + right->op_flags &= ~(OPf_KNOW|OPf_LIST); + /* "I don't know and I don't care." */ return right; } } @@ -2301,8 +2305,8 @@ OP *op; if (perldb && curstash != debstash) { SV **svp = av_fetch(GvAV(curcop->cop_filegv),(I32)cop->cop_line, FALSE); if (svp && *svp != &sv_undef && !SvIOK(*svp)) { - SvIVX(*svp) = 1; (void)SvIOK_on(*svp); + SvIVX(*svp) = 1; SvSTASH(*svp) = (HV*)cop; } } @@ -2675,7 +2679,7 @@ CV *cv; SAVESPTR(curpad); curpad = 0; - if (!(SvFLAGS(cv) & SVpcv_CLONED)) + if (!CvCLONED(cv)) op_free(CvROOT(cv)); CvROOT(cv) = Nullop; LEAVE; @@ -2716,7 +2720,7 @@ CV* proto; cv = compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)cv, SVt_PVCV); - SvFLAGS(cv) |= SVpcv_CLONED; + CvCLONED_on(cv); CvFILEGV(cv) = CvFILEGV(proto); CvGV(cv) = SvREFCNT_inc(CvGV(proto)); @@ -2791,7 +2795,7 @@ OP *block; if (cv = GvCV(gv)) { if (GvCVGEN(gv)) cv = 0; /* just a cached method */ - else if (CvROOT(cv) || CvXSUB(cv) || GvFLAGS(gv) & GVf_IMPORTED) { + else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { if (dowarn) { /* already defined (or promised)? */ line_t oldline = curcop->cop_line; @@ -2906,7 +2910,7 @@ OP *block; LEAVE_SCOPE(floor); if (!op) { GvCV(gv) = 0; /* Will remember in SVOP instead. */ - SvFLAGS(cv) |= SVpcv_ANON; + CvANON_on(cv); } return cv; } @@ -2920,7 +2924,7 @@ I32 (*subaddr)(); char *filename; { CV* cv = newXS(name, (void(*)())subaddr, filename); - CvOLDSTYLE(cv) = TRUE; + CvOLDSTYLE_on(cv); CvXSUBANY(cv).any_i32 = ix; return cv; } @@ -2985,7 +2989,7 @@ char *filename; } if (!name) { GvCV(gv) = 0; /* Will remember elsewhere instead. */ - SvFLAGS(cv) |= SVpcv_ANON; + CvANON_on(cv); } return cv; } @@ -3006,7 +3010,7 @@ OP *block; else name = "STDOUT"; gv = gv_fetchpv(name,TRUE, SVt_PVFM); - SvMULTI_on(gv); + GvMULTI_on(gv); if (cv = GvFORM(gv)) { if (dowarn) { line_t oldline = curcop->cop_line; @@ -2325,7 +2325,7 @@ EXT U32 opargs[] = { 0x00000604, /* binmode */ 0x00021755, /* tie */ 0x00000714, /* untie */ - 0x0000070c, /* tied */ + 0x00000704, /* tied */ 0x00011414, /* dbmopen */ 0x00000414, /* dbmclose */ 0x00111108, /* sselect */ @@ -2336,7 +2336,7 @@ EXT U32 opargs[] = { 0x00000000, /* leavewrite */ 0x00002e15, /* prtf */ 0x00002e15, /* print */ - 0x0091160c, /* sysopen */ + 0x00911604, /* sysopen */ 0x0091761d, /* sysread */ 0x0091161d, /* syswrite */ 0x0091161d, /* send */ @@ -452,7 +452,7 @@ binmode binmode ck_fun s F tie tie ck_fun idms R S L untie untie ck_fun is R -tied tied ck_fun st R +tied tied ck_fun s R dbmopen dbmopen ck_fun is H S S dbmclose dbmclose ck_fun is H @@ -467,7 +467,7 @@ leavewrite write exit ck_null 0 prtf printf ck_listiob ims F? L print print ck_listiob ims F? L -sysopen sysopen ck_fun st F S S S? +sysopen sysopen ck_fun s F S S S? sysread sysread ck_fun imst F R S S? syswrite syswrite ck_fun imst F S S S? diff --git a/os2/diff.Makefile b/os2/diff.Makefile index 2d0b7238f1..fdce070977 100644 --- a/os2/diff.Makefile +++ b/os2/diff.Makefile @@ -124,7 +124,7 @@ ! miniperl: $& miniperlmain.o $(perllib) ! $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain.o $(perllib) $(libs) - @miniperl -w -MExporter -e 0 || $(MAKE) minitest + @./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest ! miniperlmain.o: miniperlmain.c $(CCCMD) $(PLDLFLAGS) $*.c @@ -143,7 +143,7 @@ ! miniperl: $& miniperlmain$(OBJ_EXT) $(perllib) ! $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(perllib) $(libs) - @miniperl -w -MExporter -e 0 || $(MAKE) minitest + @./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest ! miniperlmain$(OBJ_EXT): miniperlmain.c $(CCCMD) $(PLDLFLAGS) $*.c diff --git a/os2/diff.exec b/os2/diff.exec deleted file mode 100644 index f3ef938610..0000000000 --- a/os2/diff.exec +++ /dev/null @@ -1,77 +0,0 @@ -Only #if lines are changed below. - -diff -rc perl5.002b3/pp_sys.c perl5.002b3.new/pp_sys.c -*** perl5.002b3/pp_sys.c Fri Feb 02 16:39:40 1996 ---- perl5.002b3.new/pp_sys.c Sat Feb 03 21:20:56 1996 -*************** -*** 2771,2777 **** - Signal_t (*ihand)(); /* place to save signal during system() */ - Signal_t (*qhand)(); /* place to save signal during system() */ - -! #if defined(HAS_FORK) && !defined(VMS) - if (SP - MARK == 1) { - if (tainting) { - char *junk = SvPV(TOPs, na); ---- 2771,2777 ---- - Signal_t (*ihand)(); /* place to save signal during system() */ - Signal_t (*qhand)(); /* place to save signal during system() */ - -! #if defined(HAS_FORK) && !defined(VMS) && !defined(OS2) - if (SP - MARK == 1) { - if (tainting) { - char *junk = SvPV(TOPs, na); -*************** -*** 2817,2823 **** - value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na)); - } - _exit(-1); -! #else /* ! FORK or VMS */ - if (op->op_flags & OPf_STACKED) { - SV *really = *++MARK; - value = (I32)do_aspawn(really, MARK, SP); ---- 2817,2823 ---- - value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na)); - } - _exit(-1); -! #else /* ! FORK or VMS or OS/2 */ - if (op->op_flags & OPf_STACKED) { - SV *really = *++MARK; - value = (I32)do_aspawn(really, MARK, SP); -diff -rc perl5.002b3/util.c perl5.002b3.new/util.c -*** perl5.002b3/util.c Fri Jan 26 15:46:42 1996 ---- perl5.002b3.new/util.c Sat Feb 03 23:03:48 1996 -*************** -*** 1287,1293 **** - VTOH(vtohl,long) - #endif - -! #if !defined(DOSISH) && !defined(VMS) /* VMS' my_popen() is in VMS.c */ - FILE * - my_popen(cmd,mode) - char *cmd; ---- 1287,1294 ---- - VTOH(vtohl,long) - #endif - -! #if !defined(DOSISH) && !defined(VMS) /* VMS' my_popen() is in -! VMS.c, same with OS/2. */ - FILE * - my_popen(cmd,mode) - char *cmd; -*************** -*** 1364,1370 **** - return fdopen(p[this], mode); - } - #else -! #if defined(atarist) || defined(OS2) - FILE *popen(); - FILE * - my_popen(cmd,mode) ---- 1365,1371 ---- - return fdopen(p[this], mode); - } - #else -! #if defined(atarist) - FILE *popen(); - FILE * - my_popen(cmd,mode) diff --git a/os2/os2ish.h b/os2/os2ish.h index 8d0820dcfb..0a8720cf8d 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -70,6 +70,7 @@ void settmppath(); #define Stat(fname,bufptr) os2_stat((fname),(bufptr)) #define Fstat(fd,bufptr) fstat((fd),(bufptr)) +#define FFlush(fp) fflush(fp) #undef S_IFBLK #undef S_ISBLK @@ -80,5 +81,6 @@ void settmppath(); #define Stat(fname,bufptr) stat((fname),(bufptr)) #define Fstat(fd,bufptr) fstat((fd),(bufptr)) +#define FFlush(fp) fflush(fp) #endif diff --git a/patchlevel.h b/patchlevel.h index e3d7670bc6..4c941b4ca8 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1,2 @@ #define PATCHLEVEL 2 +#define SUBVERSION 0 @@ -114,7 +114,13 @@ register PerlInterpreter *sv_interp; #endif init_ids(); + +#if defined(SUBVERSION) && SUBVERSION > 0 + sprintf(patchlevel, "%7.5f", 5.0 + (PATCHLEVEL / 1000.0) + + (SUBVERSION / 100000.0)); +#else sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0)); +#endif fdpid = newAV(); /* for remembering popen pids by fd */ pidstatus = newHV();/* for remembering status of dead pids */ @@ -263,7 +269,7 @@ setuid perl scripts securely.\n"); op_free(main_root); main_root = 0; - switch (setjmp(top_env)) { + switch (Sigsetjmp(top_env,1)) { case 1: #ifdef VMS statusvalue = 255; @@ -397,7 +403,7 @@ setuid perl scripts securely.\n"); if (!scriptname) scriptname = argv[0]; if (e_fp) { - if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp)) + if (Fflush(e_fp) || ferror(e_fp) || fclose(e_fp)) croak("Can't write to temp file for -e: %s", Strerror(errno)); argc++,argv--; scriptname = e_tmpname; @@ -465,6 +471,7 @@ setuid perl scripts securely.\n"); curstash = defstash; preprocess = FALSE; if (e_fp) { + fclose(e_fp); e_fp = Nullfp; (void)UNLINK(e_tmpname); } @@ -499,7 +506,7 @@ PerlInterpreter *sv_interp; { if (!(curinterp = sv_interp)) return 255; - switch (setjmp(top_env)) { + switch (Sigsetjmp(top_env,1)) { case 1: cxstack_ix = -1; /* start context stack again */ break; @@ -569,7 +576,7 @@ U32 status; POPBLOCK(cx,curpm); LEAVE; } - longjmp(top_env, 2); + Siglongjmp(top_env, 2); } SV* @@ -679,7 +686,7 @@ I32 flags; /* See G_* flags in cop.h */ SV** sp = stack_sp; I32 oldmark = TOPMARK; I32 retval; - jmp_buf oldtop; + Sigjmp_buf oldtop; I32 oldscope; if (flags & G_DISCARD) { @@ -702,7 +709,7 @@ I32 flags; /* See G_* flags in cop.h */ myop.op_flags |= OPf_LIST; if (flags & G_EVAL) { - Copy(top_env, oldtop, 1, jmp_buf); + Copy(top_env, oldtop, 1, Sigjmp_buf); cLOGOP->op_other = op; markstack_ptr--; @@ -728,7 +735,7 @@ I32 flags; /* See G_* flags in cop.h */ markstack_ptr++; restart: - switch (setjmp(top_env)) { + switch (Sigsetjmp(top_env,1)) { case 0: break; case 1: @@ -742,7 +749,7 @@ I32 flags; /* See G_* flags in cop.h */ /* my_exit() was called */ curstash = defstash; FREETMPS; - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); if (statusvalue) croak("Callback called exit"); my_exit(statusvalue); @@ -787,7 +794,7 @@ I32 flags; /* See G_* flags in cop.h */ curpm = newpm; LEAVE; } - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); } if (flags & G_DISCARD) { stack_sp = stack_base + oldmark; @@ -809,7 +816,7 @@ I32 flags; /* See G_* flags in cop.h */ SV** sp = stack_sp; I32 oldmark = sp - stack_base; I32 retval; - jmp_buf oldtop; + Sigjmp_buf oldtop; I32 oldscope; if (flags & G_DISCARD) { @@ -831,10 +838,10 @@ I32 flags; /* See G_* flags in cop.h */ if (flags & G_ARRAY) myop.op_flags |= OPf_LIST; - Copy(top_env, oldtop, 1, jmp_buf); + Copy(top_env, oldtop, 1, Sigjmp_buf); restart: - switch (setjmp(top_env)) { + switch (Sigsetjmp(top_env,1)) { case 0: break; case 1: @@ -848,7 +855,7 @@ restart: /* my_exit() was called */ curstash = defstash; FREETMPS; - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); if (statusvalue) croak("Callback called exit"); my_exit(statusvalue); @@ -878,7 +885,7 @@ restart: sv_setpv(GvSV(errgv),""); cleanup: - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); if (flags & G_DISCARD) { stack_sp = stack_base + oldmark; retval = 0; @@ -1101,8 +1108,12 @@ char *s; case 'm': taint_not("-m"); /* XXX ? */ if (*++s) { - char *start = s; - Sv = newSVpv("use ",4); + char *start; + char *use = "use "; + /* -M-foo == 'no foo' */ + if (*s == '-') { use = "no "; ++s; } + Sv = newSVpv(use,0); + start = s; /* We allow -M'Module qw(Foo Bar)' */ while(isALNUM(*s) || *s==':') ++s; if (*s != '=') { @@ -1114,9 +1125,9 @@ char *s; } } else { sv_catpvn(Sv, start, s-start); - sv_catpv(Sv, " qw("); + sv_catpv(Sv, " split(/,/,q{"); sv_catpv(Sv, ++s); - sv_catpv(Sv, ")"); + sv_catpv(Sv, "})"); } s += strlen(s); if (preambleav == NULL) @@ -1152,7 +1163,11 @@ char *s; s++; return s; case 'v': - printf("\nThis is perl, version %s gamma",patchlevel); +#if defined(SUBVERSION) && SUBVERSION > 0 + printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION); +#else + printf("\nThis is perl, version %s",patchlevel); +#endif #if defined(DEBUGGING) || defined(EMBED) || defined(MULTIPLICITY) fputs(" with", stdout); @@ -1229,8 +1244,13 @@ my_unexec() fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf); exit(status); #else +# ifdef VMS +# include <lib$routines.h> + lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */ +#else ABORT(); /* for use with undump */ #endif +#endif } static void @@ -1245,10 +1265,10 @@ init_main_stash() SvREADONLY_on(gv); HvNAME(defstash) = savepv("main"); incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); - SvMULTI_on(incgv); + GvMULTI_on(incgv); defgv = gv_fetchpv("_",TRUE, SVt_PVAV); errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); - SvMULTI_on(errgv); + GvMULTI_on(errgv); curstash = defstash; compiling.cop_stash = defstash; debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); @@ -1745,9 +1765,9 @@ init_stacks() retstack_ix = 0; retstack_max = 16; - New(50,cxstack,129,CONTEXT); /* XXX should fix CXINC macro */ + cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */ + New(50,cxstack,cxstack_max + 1,CONTEXT); cxstack_ix = -1; - cxstack_max = 128; New(50,tmps_stack,128,SV*); tmps_ix = -1; @@ -1779,26 +1799,26 @@ init_predump_symbols() sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1); stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); - SvMULTI_on(stdingv); + GvMULTI_on(stdingv); IoIFP(GvIOp(stdingv)) = stdin; tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV); + GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv)); - SvMULTI_on(tmpgv); tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO); - SvMULTI_on(tmpgv); + GvMULTI_on(tmpgv); IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout; setdefout(tmpgv); tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV); + GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv)); - SvMULTI_on(tmpgv); othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); - SvMULTI_on(othergv); + GvMULTI_on(othergv); IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr; tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV); + GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv)); - SvMULTI_on(tmpgv); statname = NEWSV(66,0); /* last filename we did stat on */ } @@ -1848,7 +1868,7 @@ register char **env; if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)) sv_setpv(GvSV(tmpgv),origargv[0]); if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) { - SvMULTI_on(argvgv); + GvMULTI_on(argvgv); (void)gv_AVadd(argvgv); av_clear(GvAVn(argvgv)); for (; argc > 0; argc--,argv++) { @@ -1857,7 +1877,7 @@ register char **env; } if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) { HV *hv; - SvMULTI_on(envgv); + GvMULTI_on(envgv); hv = GvHVn(envgv); hv_clear(hv); #ifndef VMS /* VMS doesn't have environ array */ @@ -1935,25 +1955,25 @@ void calllist(list) AV* list; { - jmp_buf oldtop; + Sigjmp_buf oldtop; STRLEN len; line_t oldline = curcop->cop_line; - Copy(top_env, oldtop, 1, jmp_buf); + Copy(top_env, oldtop, 1, Sigjmp_buf); while (AvFILL(list) >= 0) { CV *cv = (CV*)av_shift(list); SAVEFREESV(cv); - switch (setjmp(top_env)) { + switch (Sigsetjmp(top_env,1)) { case 0: { SV* atsv = GvSV(errgv); PUSHMARK(stack_sp); perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); (void)SvPV(atsv, len); if (len) { - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); curcop = &compiling; curcop->cop_line = oldline; if (list == beginav) @@ -1977,7 +1997,7 @@ AV* list; if (endav) calllist(endav); FREETMPS; - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); curcop = &compiling; curcop->cop_line = oldline; if (statusvalue) { @@ -1995,13 +2015,13 @@ AV* list; FREETMPS; break; } - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); curcop = &compiling; curcop->cop_line = oldline; - longjmp(top_env, 3); + Siglongjmp(top_env, 3); } } - Copy(oldtop, top_env, 1, jmp_buf); + Copy(oldtop, top_env, 1, Sigjmp_buf); } @@ -1206,7 +1206,7 @@ IEXT SV * Iparsehook; /* switches */ IEXT char * Icddir; IEXT bool Iminus_c; -IEXT char Ipatchlevel[6]; +IEXT char Ipatchlevel[10]; IEXT SV * Inrs; IEXT char * Isplitstr IINIT(" "); IEXT bool Ipreprocess; @@ -1339,7 +1339,7 @@ IEXT line_t Icopline IINIT(NOLINE); IEXT CONTEXT * Icxstack; IEXT I32 Icxstack_ix IINIT(-1); IEXT I32 Icxstack_max IINIT(128); -IEXT jmp_buf Itop_env; +IEXT Sigjmp_buf Itop_env; IEXT I32 Irunlevel; /* stack stuff */ diff --git a/perl_exp.SH b/perl_exp.SH index ea63054664..5835162fbd 100644 --- a/perl_exp.SH +++ b/perl_exp.SH @@ -22,6 +22,7 @@ sed -n "/^[A-Za-z]/ p" interp.sym >> perl.exp # extra globals not included above. cat <<END >> perl.exp +perl_init_i18nl14n perl_init_ext perl_alloc perl_construct @@ -1318,7 +1318,7 @@ int yyerrflag; int yychar; YYSTYPE yyval; YYSTYPE yylval; -#line 572 "perly.y" +#line 571 "perly.y" /* PROGRAM */ #line 1394 "y.tab.c" #define YYABORT goto yyabort @@ -2083,19 +2083,18 @@ break; case 122: #line 455 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, - append_elem(OP_LIST, - yyvsp[0].opval, newCVREF(0,scalar(yyvsp[-1].opval)))); } + append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 123: -#line 459 "perly.y" +#line 458 "perly.y" { yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } break; case 124: -#line 461 "perly.y" +#line 460 "perly.y" { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; case 125: -#line 463 "perly.y" +#line 462 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, @@ -2105,7 +2104,7 @@ case 125: )),Nullop)); dep();} break; case 126: -#line 471 "perly.y" +#line 470 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, @@ -2116,138 +2115,138 @@ case 126: )))); dep();} break; case 127: -#line 480 "perly.y" +#line 479 "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 128: -#line 484 "perly.y" +#line 483 "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 129: -#line 489 "perly.y" +#line 488 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); hints |= HINT_BLOCK_SCOPE; } break; case 130: -#line 492 "perly.y" +#line 491 "perly.y" { yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; case 131: -#line 494 "perly.y" +#line 493 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 132: -#line 496 "perly.y" +#line 495 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 133: -#line 498 "perly.y" +#line 497 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 134: -#line 500 "perly.y" +#line 499 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 135: -#line 502 "perly.y" +#line 501 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 136: -#line 505 "perly.y" +#line 504 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 137: -#line 507 "perly.y" +#line 506 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, 0); } break; case 138: -#line 509 "perly.y" +#line 508 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; case 139: -#line 512 "perly.y" +#line 511 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; case 140: -#line 514 "perly.y" +#line 513 "perly.y" { yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 141: -#line 516 "perly.y" +#line 515 "perly.y" { yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; case 142: -#line 518 "perly.y" +#line 517 "perly.y" { yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; case 145: -#line 524 "perly.y" +#line 523 "perly.y" { yyval.opval = Nullop; } break; case 146: -#line 526 "perly.y" +#line 525 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 147: -#line 530 "perly.y" +#line 529 "perly.y" { yyval.opval = Nullop; } break; case 148: -#line 532 "perly.y" +#line 531 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 149: -#line 534 "perly.y" +#line 533 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 150: -#line 538 "perly.y" +#line 537 "perly.y" { yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); } break; case 151: -#line 542 "perly.y" +#line 541 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; case 152: -#line 546 "perly.y" +#line 545 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 153: -#line 550 "perly.y" +#line 549 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; case 154: -#line 554 "perly.y" +#line 553 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 155: -#line 558 "perly.y" +#line 557 "perly.y" { yyval.opval = newGVREF(0,yyvsp[0].opval); } break; case 156: -#line 562 "perly.y" +#line 561 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 157: -#line 564 "perly.y" +#line 563 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 158: -#line 566 "perly.y" +#line 565 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 159: -#line 569 "perly.y" +#line 568 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2237 "y.tab.c" +#line 2236 "y.tab.c" } yyssp -= yym; yystate = *yyssp; diff --git a/perly.c.diff b/perly.c.diff index 37b1b92a70..3b3c04ecf8 100644 --- a/perly.c.diff +++ b/perly.c.diff @@ -1,5 +1,5 @@ -*** perly.c.orig Thu Feb 1 20:47:42 1996 ---- perly.c Thu Feb 1 20:47:43 1996 +*** perly.c.orig Wed Feb 14 15:29:04 1996 +--- perly.c Wed Feb 14 15:29:05 1996 *************** *** 12,82 **** deprecate("\"do\" to call subroutines"); @@ -86,7 +86,7 @@ - short yyss[YYSTACKSIZE]; - YYSTYPE yyvs[YYSTACKSIZE]; - #define yystacksize YYSTACKSIZE - #line 572 "perly.y" + #line 571 "perly.y" /* PROGRAM */ #line 1394 "y.tab.c" --- 1316,1323 ---- @@ -327,7 +327,7 @@ #endif yym = yylen[yyn]; *************** -*** 2243,2250 **** +*** 2242,2249 **** { #if YYDEBUG if (yydebug) @@ -336,7 +336,7 @@ #endif yystate = YYFINAL; *++yyssp = YYFINAL; ---- 2257,2265 ---- +--- 2256,2264 ---- { #if YYDEBUG if (yydebug) @@ -347,7 +347,7 @@ yystate = YYFINAL; *++yyssp = YYFINAL; *************** -*** 2258,2264 **** +*** 2257,2263 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -355,7 +355,7 @@ YYFINAL, yychar, yys); } #endif ---- 2273,2279 ---- +--- 2272,2278 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -364,7 +364,7 @@ } #endif *************** -*** 2273,2292 **** +*** 2272,2291 **** yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) @@ -385,7 +385,7 @@ yyaccept: ! return (0); } ---- 2288,2322 ---- +--- 2287,2321 ---- yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) @@ -453,8 +453,7 @@ term : term ASSIGNOP term append_elem(OP_LIST, $3, scalar($1))); } | NOAMP WORD listexpr { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, - append_elem(OP_LIST, - $3, newCVREF(0,scalar($2)))); } + append_elem(OP_LIST, $3, scalar($2))); } | DO term %prec UNIOP { $$ = newUNOP(OP_DOFILE, 0, scalar($2)); } | DO block %prec '(' diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 130bc8dca2..38edda1982 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -133,6 +133,10 @@ which provides a race condition that breaks security. (F) Perl can't peek at the stdio buffer of filehandles when it doesn't know about your kind of stdio. You'll have to use a filename instead. +=item 500 Server error + +See Server error. + =item ?+* follows nothing in regexp (F) You started a regular expression with a quantifier. Backslash it @@ -1751,6 +1755,15 @@ but has not yet been written. See L<perlre>. (F) You used a regular expression extension that doesn't make sense. See L<perlre>. +=item Server error + +Also known as "500 Server error". This is a CGI error, not a Perl +error. You need to make sure your script is executable, is accessible +by the user CGI is running the script under (which is probably not +the user account you tested it under), does not rely on any environment +variables (like PATH) from the user it isn't running under, and isn't +in a location where the CGI server can't find it, basically, more or less. + =item setegid() not implemented (F) You tried to assign to $), and your operating system doesn't support diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 7017c8f5df..6b312536b4 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -628,6 +628,21 @@ Examples: See also undef(). +Note: many folks tend to overuse defined(), and then are surprised to +discover that the number 0 and the null string are, in fact, defined +concepts. For example, if you say + + "ab" =~ /a(.*)b/; + +the pattern match succeeds, and $1 is defined, despite the fact that it +matched "nothing". But it didn't really match nothing--rather, it +matched something that happened to be 0 characters long. This is all +very above-board and honest. When a function returns an undefined value, +it's an admission that it couldn't give you an honest answer. So +you should only use defined() when you're questioning the integrity +of what you're trying to do. At other times, a simple comparison to +0 or "" is what you want. + =item delete EXPR Deletes the specified value from its hash array. Returns the deleted diff --git a/pod/perlop.pod b/pod/perlop.pod index d96afc55a2..810cff324d 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -32,7 +32,7 @@ operate on scalar values only, not array values. right = += -= *= etc. left , => nonassoc list operators (rightward) - left not + right not left and left or xor @@ -562,7 +562,6 @@ are interpolated, as are the following sequences: \n newline \r return \f form feed - \v vertical tab, whatever that is \b backspace \a alarm (bell) \e escape diff --git a/pod/perlre.pod b/pod/perlre.pod index 1c7855c041..41a3d5ff8f 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -104,7 +104,6 @@ also work: \n newline \r return \f form feed - \v vertical tab, whatever that is \a alarm (bell) \e escape (think troff) \033 octal char (think of a PDP-11) diff --git a/pod/perlrun.pod b/pod/perlrun.pod index fe8a154c39..7169515c54 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -260,11 +260,19 @@ C<-M>I<module> executes C<use> I<module> C<;> before executing your script. You can use quotes to add extra code after the module name, e.g., C<-M'module qw(foo bar)'>. +If the first character after the C<-M> or C<-m> is a dash (C<->) +then the 'use' is replaced with 'no'. + A little built-in syntactic sugar means you can also say C<-mmodule=foo> or C<-Mmodule=foo> as a shortcut for C<-M'module qw(foo)'>. Note that using the C<=> form removes the distinction between C<-m> and C<-M>. +To avoid the need to use quotes when importing more that one symbol +with the C<=> form, the text following the C<=> is split into a list +on commas (C<,>) rather than whitespace. The actual code generated +by C<-Mmodule=foo,bar> is C<use module split(/,/,q{foo,bar})>. + =item B<-n> causes Perl to assume the following loop around your script, which diff --git a/pod/perlxs.pod b/pod/perlxs.pod index 0c376047ba..5e7699b0d5 100644 --- a/pod/perlxs.pod +++ b/pod/perlxs.pod @@ -27,12 +27,11 @@ See L<perlxstut> for a tutorial on the whole extension creation process. =head2 On The Road -Many of the examples which follow will concentrate on creating an -interface between Perl and the ONC+ RPC bind library functions. -Specifically, the rpcb_gettime() function will be used to demonstrate many -features of the XS language. This function has two parameters; the first -is an input parameter and the second is an output parameter. The function -also returns a status value. +Many of the examples which follow will concentrate on creating an interface +between Perl and the ONC+ RPC bind library functions. The rpcb_gettime() +function is used to demonstrate many features of the XS language. This +function has two parameters; the first is an input parameter and the second +is an output parameter. The function also returns a status value. bool_t rpcb_gettime(const char *host, time_t *timep); @@ -845,10 +844,10 @@ the function will be called using the THIS->method() syntax. The next examples will use the following C++ class. - class colors { + class color { public: - colors(); - ~colors(); + color(); + ~color(); int blue(); void set_blue( int ); @@ -1115,9 +1114,9 @@ File C<rpctest.pl>: Perl test program for the RPC extension. =head1 XS VERSION -This document covers features supported by C<xsubpp> 1.931. +This document covers features supported by C<xsubpp> 1.933. =head1 AUTHOR Dean Roehrich F<E<lt>roehrich@cray.comE<gt>> -Jan 25, 1996 +Feb 13, 1996 @@ -132,7 +132,7 @@ PP(pp_rv2gv) if (op->op_flags & OPf_SPECIAL) { GvGP(sv)->gp_refcnt++; /* will soon be assigned */ - GvFLAGS(sv) |= GVf_INTRO; + GvINTRO_on(sv); } else { GP *gp; @@ -273,9 +273,8 @@ PP(pp_anoncode) CV* cv = (CV*)cSVOP->op_sv; EXTEND(SP,1); - if (SvFLAGS(cv) & SVpcv_CLONE) { + if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); - } PUSHs((SV*)cv); RETURN; @@ -937,7 +937,7 @@ die(pat, va_alist) } restartop = die_where(message); if ((!restartop && was_in_eval) || oldrunlevel > 1) - longjmp(top_env, 3); + Siglongjmp(top_env, 3); return restartop; } @@ -997,11 +997,10 @@ char *message; } } fputs(message, stderr); - (void)fflush(stderr); + (void)Fflush(stderr); if (e_fp) { -#ifdef DOSISH fclose(e_fp); -#endif + e_fp = Nullfp; (void)UNLINK(e_tmpname); } statusvalue = SHIFTSTATUS(statusvalue); @@ -1135,7 +1134,7 @@ PP(pp_caller) GV* tmpgv; dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, SVt_PVAV))); - SvMULTI_on(tmpgv); + GvMULTI_on(tmpgv); AvREAL_off(dbargs); /* XXX Should be REIFY */ } @@ -1828,6 +1827,9 @@ PP(pp_goto) } if (do_dump) { +#ifdef VMS + if (!retop) retop = main_start; +#endif restartop = retop; do_undump = TRUE; @@ -1839,7 +1841,7 @@ PP(pp_goto) if (stack == signalstack) { restartop = retop; - longjmp(top_env, 3); + Siglongjmp(top_env, 3); } RETURNOP(retop); @@ -2038,9 +2040,9 @@ PP(pp_require) sv = POPs; if (SvNIOKp(sv) && !SvPOKp(sv)) { - if (atof(patchlevel) + 0.000999 < SvNV(sv)) - DIE("Perl %3.3f required--this is only version %s, stopped", - SvNV(sv),patchlevel); + if (atof(patchlevel) + 0.00000999 < SvNV(sv)) + DIE("Perl %s required--this is only version %s, stopped", + SvPV(sv,na),patchlevel); RETPUSHYES; } name = SvPV(sv, na); @@ -373,7 +373,7 @@ PP(pp_print) goto just_say_no; if (IoFLAGS(io) & IOf_FLUSH) - if (fflush(fp) == EOF) + if (Fflush(fp) == EOF) goto just_say_no; } } @@ -1720,8 +1720,10 @@ PP(pp_entersub) if ((op->op_private & OPpENTERSUB_DB) && !CvXSUB(cv)) { sv = GvSV(DBsub); save_item(sv); - if (SvFLAGS(cv) & (SVpcv_ANON | SVpcv_CLONED)) /* Is GV potentially non-unique? */ + if (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) { + /* GV is potentially non-unique */ sv_setsv(sv, newRV((SV*)cv)); + } else { gv = CvGV(cv); gv_efullname(sv,gv); @@ -365,7 +365,7 @@ PP(pp_binmode) #ifdef DOSISH #ifdef atarist - if (!fflush(fp) && (fp->_flag |= _IOBIN)) + if (!Fflush(fp) && (fp->_flag |= _IOBIN)) RETPUSHYES; else RETPUSHUNDEF; @@ -452,7 +452,7 @@ PP(pp_untie) PP(pp_tied) { - dSP; dTARGET ; + dSP; SV * sv ; MAGIC * mg ; @@ -919,7 +919,7 @@ PP(pp_leavewrite) SvCUR_set(formtarget, 0); *SvEND(formtarget) = '\0'; if (IoFLAGS(io) & IOf_FLUSH) - (void)fflush(fp); + (void)Fflush(fp); PUSHs(&sv_yes); } } @@ -965,7 +965,7 @@ PP(pp_prtf) goto just_say_no; if (IoFLAGS(io) & IOf_FLUSH) - if (fflush(fp) == EOF) + if (Fflush(fp) == EOF) goto just_say_no; } SvREFCNT_dec(sv); @@ -982,9 +982,8 @@ PP(pp_prtf) PP(pp_sysopen) { - dSP; dTARGET; + dSP; GV *gv; - IO *io; SV *sv; char *tmps; STRLEN len; @@ -210,6 +210,27 @@ sv_clean_objs() register SV* svend; SV* rv; +#ifndef DISABLE_DESTRUCTOR_KLUDGE + register GV* gv; + for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { + gv = sva + 1; + svend = &sva[SvREFCNT(sva)]; + while (gv < svend) { + if (SvTYPE(gv) == SVt_PVGV && (sv = GvSV(gv)) && + SvROK(sv) && SvOBJECT(rv = SvRV(sv))) + { + DEBUG_D((fprintf(stderr, "Cleaning object ref:\n "), + sv_dump(sv));) + SvROK_off(sv); + SvRV(sv) = 0; + SvREFCNT_dec(rv); + } + ++gv; + } + } + if (!sv_objcount) + return; +#endif for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { sv = sva + 1; svend = &sva[SvREFCNT(sva)]; @@ -503,6 +524,9 @@ U32 mt; if (SvTYPE(sv) == mt) return TRUE; + if (mt < SVt_PVIV) + (void)SvOOK_off(sv); + switch (SvTYPE(sv)) { case SVt_NULL: pv = 0; @@ -719,6 +743,7 @@ U32 mt; GvNAME(sv) = 0; GvNAMELEN(sv) = 0; GvSTASH(sv) = 0; + GvFLAGS(sv) = 0; break; case SVt_PVBM: SvANY(sv) = new_XPVBM(); @@ -1004,8 +1029,8 @@ IV i; croak("Can't coerce %s to integer in %s", sv_reftype(sv,0), op_name[op->op_type]); } - SvIVX(sv) = i; (void)SvIOK_only(sv); /* validate number */ + SvIVX(sv) = i; SvTAINT(sv); } @@ -1157,6 +1182,7 @@ register SV *sv; break; } if (SvNOKp(sv)) { + (void)SvIOK_on(sv); if (SvNVX(sv) < 0.0) SvIVX(sv) = I_V(SvNVX(sv)); else @@ -1165,6 +1191,7 @@ register SV *sv; else if (SvPOKp(sv) && SvLEN(sv)) { if (dowarn && !looks_like_number(sv)) not_a_number(sv); + (void)SvIOK_on(sv); SvIVX(sv) = (IV)atol(SvPVX(sv)); } else { @@ -1172,7 +1199,6 @@ register SV *sv; warn(warn_uninit); return 0; } - (void)SvIOK_on(sv); DEBUG_c(fprintf(stderr,"0x%lx 2iv(%ld)\n", (unsigned long)sv,(long)SvIVX(sv))); return SvIVX(sv); @@ -1522,6 +1548,12 @@ register SV *sstr; else if (dtype == SVt_PVGV && SvTYPE(SvRV(sstr)) == SVt_PVGV) { sstr = SvRV(sstr); + if (sstr == dstr) { + if (curcop->cop_stash != GvSTASH(dstr)) + GvIMPORTED_on(dstr); + GvMULTI_on(dstr); + return; + } goto glob_assign; } break; @@ -1556,9 +1588,7 @@ register SV *sstr; case SVt_PVGV: if (dtype <= SVt_PVGV) { glob_assign: - if (dtype == SVt_PVGV) - GvFLAGS(sstr) |= GVf_IMPORTED; - else { + if (dtype != SVt_PVGV) { char *name = GvNAME(sstr); STRLEN len = GvNAMELEN(sstr); sv_upgrade(dstr, SVt_PVGV); @@ -1569,12 +1599,13 @@ register SV *sstr; SvFAKE_on(dstr); /* can coerce to non-glob */ } (void)SvOK_off(dstr); - if (GvGP(dstr)) - gp_free(dstr); + GvINTRO_off(dstr); /* one-shot flag */ + gp_free(dstr); GvGP(dstr) = gp_ref(GvGP(sstr)); SvTAINT(dstr); - GvFLAGS(dstr) &= ~GVf_INTRO; /* one-shot flag */ - SvMULTI_on(dstr); + if (curcop->cop_stash != GvSTASH(dstr)) + GvIMPORTED_on(dstr); + GvMULTI_on(dstr); return; } /* FALL THROUGH */ @@ -1593,20 +1624,20 @@ register SV *sstr; if (dtype == SVt_PVGV) { SV *sref = SvREFCNT_inc(SvRV(sstr)); SV *dref = 0; - int intro = GvFLAGS(dstr) & GVf_INTRO; + int intro = GvINTRO(dstr); if (intro) { GP *gp; GvGP(dstr)->gp_refcnt--; + GvINTRO_off(dstr); /* one-shot flag */ Newz(602,gp, 1, GP); GvGP(dstr) = gp; GvREFCNT(dstr) = 1; GvSV(dstr) = NEWSV(72,0); GvLINE(dstr) = curcop->cop_line; GvEGV(dstr) = dstr; - GvFLAGS(dstr) &= ~GVf_INTRO; /* one-shot flag */ } - SvMULTI_on(dstr); + GvMULTI_on(dstr); switch (SvTYPE(sref)) { case SVt_PVAV: if (intro) @@ -1614,6 +1645,8 @@ register SV *sstr; else dref = (SV*)GvAV(dstr); GvAV(dstr) = (AV*)sref; + if (curcop->cop_stash != GvSTASH(dstr)) + GvIMPORTED_AV_on(dstr); break; case SVt_PVHV: if (intro) @@ -1621,6 +1654,8 @@ register SV *sstr; else dref = (SV*)GvHV(dstr); GvHV(dstr) = (HV*)sref; + if (curcop->cop_stash != GvSTASH(dstr)) + GvIMPORTED_HV_on(dstr); break; case SVt_PVCV: if (intro) @@ -1637,7 +1672,12 @@ register SV *sstr; SvFAKE_on(cv); } } - GvCV(dstr) = (CV*)sref; + if (GvCV(dstr) != (CV*)sref) { + GvCV(dstr) = (CV*)sref; + GvASSUMECV_on(dstr); + } + if (curcop->cop_stash != GvSTASH(dstr)) + GvIMPORTED_CV_on(dstr); break; case SVt_PVIO: if (intro) @@ -1652,10 +1692,10 @@ register SV *sstr; else dref = (SV*)GvSV(dstr); GvSV(dstr) = sref; + if (curcop->cop_stash != GvSTASH(dstr)) + GvIMPORTED_SV_on(dstr); break; } - if (curcop->cop_stash != GvSTASH(dstr)) - GvFLAGS(dstr) |= GVf_IMPORTED; /* crude */ if (dref) SvREFCNT_dec(dref); if (intro) @@ -1694,20 +1734,27 @@ register SV *sstr; * has to be allocated and SvPVX(sstr) has to be freed. */ - if (SvTEMP(sstr)) { /* slated for free anyway? */ + if (SvTEMP(sstr) && /* slated for free anyway? */ + !(sflags & SVf_OOK)) /* and not involved in OOK hack? */ + { if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */ - (void)SvOOK_off(dstr); - Safefree(SvPVX(dstr)); + if (SvOOK(dstr)) { + SvFLAGS(dstr) &= ~SVf_OOK; + Safefree(SvPVX(dstr) - SvIVX(dstr)); + } + else + Safefree(SvPVX(dstr)); } + (void)SvPOK_only(dstr); SvPV_set(dstr, SvPVX(sstr)); SvLEN_set(dstr, SvLEN(sstr)); SvCUR_set(dstr, SvCUR(sstr)); - (void)SvPOK_only(dstr); SvTEMP_off(dstr); + (void)SvOK_off(sstr); SvPV_set(sstr, Nullch); SvLEN_set(sstr, 0); - SvPOK_off(sstr); /* wipe out any weird flags */ - SvPVX(sstr) = 0; /* so sstr frees uneventfully */ + SvCUR_set(sstr, 0); + SvTEMP_off(sstr); } else { /* have to copy actual string */ STRLEN len = SvCUR(sstr); @@ -2578,6 +2625,7 @@ I32 append; memcpy((char*)bp, (char*)ptr, cnt); /* this | eat */ bp += cnt; /* screams | dust */ ptr += cnt; /* louder | sed :-) */ + cnt = 0; } } @@ -2696,8 +2744,8 @@ register SV *sv; mg_get(sv); flags = SvFLAGS(sv); if (flags & SVp_IOK) { - ++SvIVX(sv); (void)SvIOK_only(sv); + ++SvIVX(sv); return; } if (flags & SVp_NOK) { @@ -2766,8 +2814,8 @@ register SV *sv; mg_get(sv); flags = SvFLAGS(sv); if (flags & SVp_IOK) { - --SvIVX(sv); (void)SvIOK_only(sv); + --SvIVX(sv); return; } if (flags & SVp_NOK) { @@ -3349,7 +3397,7 @@ SV* sv; gp_free(sv); sv_unmagic(sv, '*'); Safefree(GvNAME(sv)); - SvMULTI_off(sv); + GvMULTI_off(sv); SvFLAGS(sv) &= ~SVTYPEMASK; SvFLAGS(sv) |= SVt_PVMG; } @@ -129,12 +129,6 @@ struct io { #define SVpbm_CASEFOLD 0x40000000 #define SVpbm_TAIL 0x20000000 -#define SVpgv_MULTI 0x80000000 - -#define SVpcv_CLONE 0x80000000 /* anon CV uses external lexicals */ -#define SVpcv_CLONED 0x40000000 /* a clone of one of those */ -#define SVpcv_ANON 0x20000000 /* CvGV() can't be trusted */ - #ifdef OVERLOAD #define SVpgv_AM 0x40000000 /* #define SVpgv_badAM 0x20000000 */ @@ -203,6 +197,7 @@ struct xpvgv { char* xgv_name; STRLEN xgv_namelen; HV* xgv_stash; + U8 xgv_flags; }; struct xpvbm { @@ -301,7 +296,7 @@ struct xpvio { #define SvIOK_on(sv) (SvOOK_off(sv), \ SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) #define SvIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVp_IOK)) -#define SvIOK_only(sv) (SvOK_off(sv), \ +#define SvIOK_only(sv) (SvOOK_off(sv), SvOK_off(sv), \ SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) #define SvNOK(sv) (SvFLAGS(sv) & SVf_NOK) @@ -411,10 +406,6 @@ struct xpvio { #define SvVALID_on(sv) (SvFLAGS(sv) |= SVpbm_VALID) #define SvVALID_off(sv) (SvFLAGS(sv) &= ~SVpbm_VALID) -#define SvMULTI(sv) (SvFLAGS(sv) & SVpgv_MULTI) -#define SvMULTI_on(sv) (SvFLAGS(sv) |= SVpgv_MULTI) -#define SvMULTI_off(sv) (SvFLAGS(sv) &= ~SVpgv_MULTI) - #define SvRV(sv) ((XRV*) SvANY(sv))->xrv_rv #define SvRVx(sv) SvRV(sv) diff --git a/t/comp/cpp.aux b/t/comp/cpp.aux index bb93d212c3..bb93d212c3 100755..100644 --- a/t/comp/cpp.aux +++ b/t/comp/cpp.aux diff --git a/t/harness b/t/harness new file mode 100644 index 0000000000..c98d91e360 --- /dev/null +++ b/t/harness @@ -0,0 +1,15 @@ +#!./perl + +# We suppose that perl _mostly_ works at this moment, so may use +# sophisticated testing. + +# Note that _before install_ you may need to run it with -I ../lib flag + +use lib '../lib'; +use Test::Harness; + +$Test::Harness::switches = ""; # Too much noise otherwise + +@tests = @ARGV; +@tests = <*/*.t> unless @tests; +Test::Harness::runtests @tests; diff --git a/t/lib/dirhand.t b/t/lib/dirhand.t index 8403609578..8403609578 100755..100644 --- a/t/lib/dirhand.t +++ b/t/lib/dirhand.t diff --git a/t/lib/filehand.t b/t/lib/filehand.t index 8b27617568..8b27617568 100755..100644 --- a/t/lib/filehand.t +++ b/t/lib/filehand.t @@ -276,7 +276,7 @@ void *f; if (rsfp == stdin) clearerr(rsfp); - else if (rsfp != fp) + else if (rsfp && (rsfp != fp)) fclose(rsfp); rsfp = fp; } @@ -1877,6 +1877,24 @@ yylex() if (expect == XSTATE && isALPHA(tmp) && (s == SvPVX(linestr)+1 || s[-2] == '\n') ) { + if (in_eval && !rsfp) { + d = bufend; + while (s < d) { + if (*s++ == '\n') { + incline(s); + if (strnEQ(s,"=cut",4)) { + s = strchr(s,'\n'); + if (s) + s++; + else + s = d; + incline(s); + goto retry; + } + } + } + goto retry; + } s = bufend; doextract = TRUE; goto retry; @@ -2297,10 +2315,9 @@ yylex() if (tmp < 0) { /* second-class keyword? */ GV* gv; if (expect != XOPERATOR && - (*s != ':' || s[1] != ':') && - (gv = gv_fetchpv(tokenbuf,FALSE, SVt_PVCV)) && - (GvFLAGS(gv) & GVf_IMPORTED) && - GvCV(gv)) + (*s != ':' || s[1] != ':') && + (gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) && + GvIMPORTED_CV(gv)) { tmp = 0; } @@ -2415,8 +2432,8 @@ yylex() if (gv && GvCV(gv)) { CV* cv = GvCV(gv); - nextval[nexttoke].opval = yylval.opval; if (*s == '(') { + nextval[nexttoke].opval = yylval.opval; expect = XTERM; force_next(WORD); yylval.ival = 0; @@ -2427,6 +2444,9 @@ yylex() tokenbuf, tokenbuf); last_lop = oldbufptr; last_lop_op = OP_ENTERSUB; + /* Resolve to GV now. */ + op_free(yylval.opval); + yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); /* Is there a prototype? */ if (SvPOK(cv)) { STRLEN len; @@ -2440,6 +2460,7 @@ yylex() PREBLOCK(LSTOPSUB); } } + nextval[nexttoke].opval = yylval.opval; expect = XTERM; force_next(WORD); TOKEN(NOAMP); @@ -2492,14 +2513,14 @@ yylex() GV *gv; /*SUPPRESS 560*/ - if (!in_eval || tokenbuf[2] == 'D') { + if (rsfp && (!in_eval || tokenbuf[2] == 'D')) { char dname[256]; char *pname = "main"; if (tokenbuf[2] == 'D') pname = HvNAME(curstash ? curstash : defstash); sprintf(dname,"%s::DATA", pname); gv = gv_fetchpv(dname,TRUE, SVt_PVIO); - SvMULTI_on(gv); + GvMULTI_on(gv); if (!GvIO(gv)) GvIOp(gv) = newIO(); IoIFP(GvIOp(gv)) = rsfp; @@ -73,6 +73,7 @@ #define Stat(fname,bufptr) stat((fname),(bufptr)) #define Fstat(fd,bufptr) fstat((fd),(bufptr)) +#define Fflush(fp) fflush(fp) #define my_getenv(var) getenv(var) @@ -821,14 +821,13 @@ long a1, a2, a3, a4; } if (in_eval) { restartop = die_where(message); - longjmp(top_env, 3); + Siglongjmp(top_env, 3); } fputs(message,stderr); - (void)fflush(stderr); + (void)Fflush(stderr); if (e_fp) { -#ifdef DOSISH - fclose(e_fp); -#endif + fclose(e_fp); + e_fp = Nullfp; (void)UNLINK(e_tmpname); } statusvalue = SHIFTSTATUS(statusvalue); @@ -865,7 +864,7 @@ long a1, a2, a3, a4; #ifdef LEAKTEST DEBUG_L(xstat()); #endif - (void)fflush(stderr); + (void)Fflush(stderr); } } @@ -981,14 +980,13 @@ croak(pat, va_alist) } if (in_eval) { restartop = die_where(message); - longjmp(top_env, 3); + Siglongjmp(top_env, 3); } fputs(message,stderr); - (void)fflush(stderr); + (void)Fflush(stderr); if (e_fp) { -#ifdef DOSISH - fclose(e_fp); -#endif + fclose(e_fp); + e_fp = Nullfp; (void)UNLINK(e_tmpname); } statusvalue = SHIFTSTATUS(statusvalue); @@ -1037,7 +1035,7 @@ warn(pat,va_alist) #ifdef LEAKTEST DEBUG_L(xstat()); #endif - (void)fflush(stderr); + (void)Fflush(stderr); } } #endif /* !defined(I_STDARG) && !defined(I_VARARGS) */ diff --git a/utils/perlbug.PL b/utils/perlbug.PL index 375bb78576..a3aaefe59b 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -51,16 +51,18 @@ use strict; sub paraprint; -my($Version) = "1.11"; +my($Version) = "1.12"; # 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 -# Changed in 1.08 to use correct address for sendmail +# Changed in 1.07 to see more sendmail execs, and added pipe output. +# Changed in 1.08 to use correct address for sendmail. # Changed in 1.09 to close the REP file before calling it up in the editor. # Also removed some old comments duplicated elsewhere. # Changed in 1.10 to run under VMS without Mail::Send; also fixed -# temp filename generation +# temp filename generation. # Changed in 1.11 to clean up some text and removed Mail::Send deactivator. +# Changed in 1.12 to check for editor errors, make save/send distinction +# clearer and add $ENV{REPLYTO}. # TODO: Allow the user to re-name the file on mail failure, and # make sure failure (transmission-wise) of Mail::Send is @@ -204,20 +206,23 @@ EOF $guess = "$me\@$domain" if $domain; $guess = "$me\@unknown.addresss" unless $domain; } + + $guess = $ENV{'REPLYTO'} if defined($ENV{'REPLYTO'}); + $guess = $ENV{"REPLY-TO"} if defined($ENV{'REPLY-TO'}); if( $guess ) { paraprint <<EOF; -Your e-mail address will be useful if you need to be contacted. -If the default shown is not your proper address, please correct it. +Your e-mail address will be useful if you need to be contacted. If the +default shown is not your full internet e-mail address, please correct it. EOF } else { paraprint <<EOF; So that you may be contacted if necessary, please enter -your e-mail address here. +your full internet e-mail address here. EOF } @@ -394,10 +399,34 @@ EOF sub Edit { # Edit the report +tryagain: if(!$file and !$body) { my($sts) = system("$ed $filename"); if( $Is_VMS ? !($sts & 1) : $sts ) { - print "\nUnable to run editor!\n"; + #print "\nUnable to run editor!\n"; + paraprint <<EOF; + +The editor you chose (`$ed') could apparently not be run! +Did you mistype the name of your editor? If so, please +correct it here, otherwise just press Enter. + +EOF + print "Editor [$ed]: "; + + my($entry) =scalar(<>); + chop $entry; + + if($entry ne "") { + $ed = $entry; + goto tryagain; + } else { + + paraprint <<EOF; + +You may want to save your report to a file, so you can edit and mail it +yourself. +EOF + } } } } @@ -418,14 +447,11 @@ You may also save the message as a file to mail at another time. EOF - print "Action (Send/Display/Edit/Cancel/File): "; + print "Action (Send/Display/Edit/Cancel/Save to File): "; my($action) = scalar(<>); chop $action; - if($action =~ /^s/i) { # Send - # Send the message - last; - } elsif($action =~ /^f/i) { # File + if( $action =~ /^(f|sa)/i ) { # <F>ile/<Sa>ve print "\n\nName of file to save message in [perlbug.rep]: "; my($file) = scalar(<>); chop $file; @@ -444,15 +470,19 @@ EOF print "\nMessage saved in `$file'.\n"; exit; - } elsif($action =~ /^[drl]/i) { # Display, Redisplay, List + } elsif( $action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow # Display the message open(REP,"<$filename"); while(<REP>) { print $_ } close(REP); - } elsif($action =~ /^e/i) { # Edit + } elsif( $action =~ /^s/i ) { # <S>end + # Send the message + last; + } elsif( $action =~ /^[er]/i ) { # <E>dit, <R>e-edit # edit the message - system("$ed $filename"); - } elsif($action =~ /^[qc]/i) { # Cancel, Quit + 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); diff --git a/vms/descrip.mms b/vms/descrip.mms index d34245c8fc..04fcfeb108 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -1,5 +1,5 @@ # Descrip.MMS for perl5 on VMS -# Last revised 17-Jan-1995 by Charles Bailey bailey@genetics.upenn.edu +# Last revised 22-Feb-1996 by Charles Bailey bailey@genetics.upenn.edu # #: This file uses MMS syntax, and can be processed using DEC's MMS product, #: or the free MMK clone (available by ftp at ftp.spc.edu). If you want to @@ -230,6 +230,9 @@ CRTL = []crtl.opt CRTLOPTS =,$(CRTL)/Options .SUFFIXES + +.ifdef LINK_ONLY +.else .SUFFIXES $(O) .c .xs .xs.c : @@ -242,12 +245,14 @@ CRTLOPTS =,$(CRTL)/Options .xs$(O) : $(XSUBPP) $(MMS$SOURCE) >$(MMS$SOURCE_NAME).c $(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c +.endif + all : base extras archcorefiles preplibrary perlpods @ $(NOOP) base : miniperl$(E) perl$(E) @ $(NOOP) -extras : FileHandle Safe libmods utils podxform +extras : Fcntl FileHandle Safe libmods utils podxform @ $(NOOP) libmods : [.lib]Config.pm [.lib.$(ARCH)]Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm @ $(NOOP) @@ -286,29 +291,38 @@ $(DBG)libperl$(OLB) : $(obj) perlmain.c : miniperlmain.c $(MINIPERL_EXE) [.vms]writemain.pl $(MINIPERL) [.VMS]Writemain.pl "$(EXT)" -perl$(E) : perlmain$(O), perlshr$(E), $(MINIPERL_EXE) +$(DBG)perl$(E) : perlmain$(O), $(DBG)perlshr$(E), $(MINIPERL_EXE) @ @[.vms]genopt "PerlShr.Opt/Write" "|" "''F$Environment("Default")'$(DBG)PerlShr$(E)/Share" .ifdef gnuc @ @[.vms]genopt "PerlShr.Opt/Append" "|" "$(LIBS1)|$(LIBS2)" .endif Link $(LINKFLAGS)/Exe=$(DBG)$(MMS$TARGET) perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option -perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts + +$(DBG)perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts Link /NoTrace$(LINKFLAGS)/Share=$(DBG)$(MMS$TARGET) $(extobj) []$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option + # The following files are built in one go by gen_shrfls.pl: # perlshr_attr.opt, $(DBG)perlshr_bld.opt - VAX and AXP # perlshr_gbl*.mar, perlshr_gbl*$(O) - VAX only +# The song and dance with gen_shrfls.opt accomodates DCL's 255 character +# line length limit. .ifdef PIPES_BROKEN # This is a backup target used only with older versions of the DECCRTL which # can't deal with pipes properly. See ReadMe.VMS for details. $(DBG)perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl $(MINIPERL_EXE) $(MAKEFILE) $(CRTL) $(CC) $(CFLAGS)/NoObject/NoList/PreProcess=perl.i perl.h - $(MINIPERL) [.vms]gen_shrfls.pl "~~NOCC~~perl.i~~$(CC)$(CFLAGS)" "$(O)" "$(DBG)" "$(OLB)" "$(EXT)" "$(CRTL)" - @ Delete/NoLog/NoConfirm perl.i; + @ $(MINIPERL) -e "print join('|',@ARGV),'|';" "~~NOCC~~perl.i~~$(CC)$(CFLAGS)" >gen_shrfls.opt + @ $(MINIPERL) -e "print join('|',@ARGV);" "$(O)" "$(DBG)" "$(OLB)" "$(EXT)" "$(CRTL)" >>gen_shrfls.opt + $(MINIPERL) [.vms]gen_shrfls.pl -f gen_shrfls.opt + @ Delete/NoLog/NoConfirm perl.i;, gen_shrfls.opt; @ If F$Search("$(DBG)perlshr_xtras.ts").nes."" Then Delete/NoLog/NoConfirm $(DBG)perlshr_xtras.ts;* @ Copy NLA0: $(DBG)perlshr_xtras.ts .else $(DBG)perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl $(MINIPERL_EXE) $(MAKEFILE) $(CRTL) - $(MINIPERL) [.vms]gen_shrfls.pl "$(CC)$(CFLAGS)" "$(O)" "$(DBG)" "$(OLB)" "$(EXT)" "$(CRTL)" + @ $(MINIPERL) -e "print join('|',@ARGV),'|';" "$(CC)$(CFLAGS)" >gen_shrfls.opt + @ $(MINIPERL) -e "print join('|',@ARGV);" "$(O)" "$(DBG)" "$(OLB)" "$(EXT)" "$(CRTL)" >>gen_shrfls.opt + $(MINIPERL) [.vms]gen_shrfls.pl -f gen_shrfls.opt + @ Delete/NoLog/NoConfirm gen_shrfls.opt; @ If F$Search("$(DBG)perlshr_xtras.ts").nes."" Then Delete/NoLog/NoConfirm $(DBG)perlshr_xtras.ts;* @ Copy NLA0: $(DBG)perlshr_xtras.ts .endif @@ -317,8 +331,12 @@ $(DBG)perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl $( Create/Directory [.lib.$(ARCH)] Copy $(MMS$SOURCE) $(MMS$TARGET) +# Once again, we accomodate DCL's 255 character buffer [.lib]config.pm : [.vms]config.vms [.vms]genconfig.pl $(MINIPERL_EXE) - $(MINIPERL) [.VMS]GenConfig.Pl cc=$(CC)$(CFLAGS) ldflags=$(LINKFLAGS) obj_ext=$(O) exe_ext=$(E) lib_ext=$(OLB) + @ $(MINIPERL) -e "print join('|',@ARGV),'|';" "cc=$(CC)$(CFLAGS)" >genconfig.opt + @ $(MINIPERL) -e "print join('|',@ARGV),'|';" "ldflags=$(LINKFLAGS)|obj_ext=$(O)|exe_ext=$(E)|lib_ext=$(OLB)" >>genconfig.opt + $(MINIPERL) [.VMS]GenConfig.Pl -f genconfig.opt + @ Delete/NoLog/NoConfirm genconfig.opt; $(MINIPERL) ConfigPM. [.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs $(MINIPERL_EXE) @@ -335,6 +353,7 @@ Safe : [.lib]Safe.pm [.lib.auto]Safe$(E) @ $(NOOP) [.lib]Safe.pm : [.ext.Safe]Descrip.MMS + @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto] @ Set Default [.ext.Safe] $(MMS) @ Set Default [--] @@ -347,12 +366,13 @@ Safe : [.lib]Safe.pm [.lib.auto]Safe$(E) # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> # ${@} necessary to distract different versions of MM[SK]/make [.ext.Safe]Descrip.MMS : [.ext.Safe]Makefile.PL [.lib.$(ARCH)]Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E) - $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Safe]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" 2>_nla0: + $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Safe]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" 2>_nla0: FileHandle : [.lib]FileHandle.pm [.lib.auto]FileHandle$(E) @ $(NOOP) [.lib]FileHandle.pm : [.ext.FileHandle]Descrip.MMS + @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto] @ Set Default [.ext.FileHandle] $(MMS) @ Set Default [--] @@ -365,7 +385,26 @@ FileHandle : [.lib]FileHandle.pm [.lib.auto]FileHandle$(E) # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> # ${@} necessary to distract different versions of MM[SK]/make [.ext.FileHandle]Descrip.MMS : [.ext.FileHandle]Makefile.PL [.lib.$(ARCH)]Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E) - $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.FileHandle]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" 2>_nla0: + $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.FileHandle]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" 2>_nla0: + +Fcntl : [.lib]Fcntl.pm [.lib.auto]Fcntl$(E) + @ $(NOOP) + +[.lib]Fcntl.pm : [.ext.Fcntl]Descrip.MMS + @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto] + @ Set Default [.ext.Fcntl] + $(MMS) + @ Set Default [--] + +[.lib.auto]Fcntl$(E) : [.ext.Fcntl]Descrip.MMS + @ Set Default [.ext.Fcntl] + $(MMS) + @ Set Default [--] + +# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir> +# ${@} necessary to distract different versions of MM[SK]/make +[.ext.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL [.lib.$(ARCH)]Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E) + $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]" 2>_nla0: [.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm @ If F$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS] @@ -557,8 +596,18 @@ printconfig : @ @[.vms]myconfig "$(CC)" "$(CFLAGS)" "$(LINKFLAGS)" "$(LIBS1)" "$(LIBS2)" "$(SOCKLIB)" "$(EXT)" "$(DBG)" .ifdef SOCKET + +.ifdef LINK_ONLY +.else $(SOCKOBJ) : $(SOCKC) $(SOCKH) +[.ext.Socket]Socket$(O) : [.ext.Socket]Socket.c + $(CC) $(CFLAGS) /Object=$(MMS$TARGET) $(MMS$SOURCE) + +[.ext.Socket]Socket.c : [.ext.Socket]Socket.xs $(MINIPERL_EXE) + $(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET) +.endif # !LINK_ONLY + vmsish.h : $(SOCKH) $(SOCKC) : [.vms]$(SOCKC) @@ -567,12 +616,6 @@ $(SOCKC) : [.vms]$(SOCKC) $(SOCKH) : [.vms]$(SOCKH) Copy/Log/NoConfirm [.vms]$(SOCKH) []$(SOCKH) -[.ext.Socket]Socket.c : [.ext.Socket]Socket.xs $(MINIPERL_EXE) - $(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET) - -[.ext.Socket]Socket$(O) : [.ext.Socket]Socket.c - $(CC) $(CFLAGS) /Object=$(MMS$TARGET) $(MMS$SOURCE) - [.lib]Socket.pm : [.ext.Socket]Socket.pm Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET) .endif @@ -607,8 +650,11 @@ perly.h : [.vms]perly_h.vms # rename y.tab.h perly.h # $(INSTPERL) [.vms]vms_yfix.pl perly.c perly.h [.vms]perly_c.vms [.vms]perly_h.vms +.ifdef LINK_ONLY +.else perly$(O) : perly.c, perly.h, $(h) $(CC) $(CFLAGS) $(MMS$SOURCE) +.endif test : all - @[.VMS]Test.Com @@ -714,6 +760,8 @@ $(ARCHAUTO)time.stamp : @ If F$Search("[.lib.$(ARCH)]auto.dir").eqs."" Then Create/Directory $(ARCHAUTO) @ If F$Search("$(MMS$TARGET)").eqs."" Then Copy/NoConfirm _NLA0: $(MMS$TARGET) +.ifdef LINK_ONLY +.else # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE av$(O) : EXTERN.h av$(O) : av.c @@ -1340,6 +1388,7 @@ globals$(O) : scope.h globals$(O) : sv.h globals$(O) : vmsish.h globals$(O) : util.h +.endif # !LINK_ONLY config.h : [.vms]config.vms Copy/Log/NoConfirm [.vms]config.vms []config.h @@ -1409,6 +1458,9 @@ clean : tidy - If F$Search("[.Ext.Socket]Socket.C").nes."" Then Delete/NoConfirm/Log [.Ext.Socket]Socket.C;* - If F$Search("[.VMS.Ext...]*.C").nes."" Then Delete/NoConfirm/Log [.VMS.Ext...]*.C;* - If F$Search("[.VMS.Ext...]*$(O)").nes."" Then Delete/NoConfirm/Log [.VMS.Ext...]*$(O);* + Set Default [.ext.Fcntl] + - $(MMS) clean + Set Default [--] Set Default [.ext.FileHandle] - $(MMS) clean Set Default [--] @@ -1428,6 +1480,9 @@ realclean : clean - 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*.;* + Set Default [.ext.Fcntl] + - $(MMS) realclean + Set Default [--] Set Default [.ext.FileHandle] - $(MMS) realclean Set Default [--] diff --git a/vms/ext/Filespec.pm b/vms/ext/Filespec.pm index c690ccaee2..3ce67aafda 100644 --- a/vms/ext/Filespec.pm +++ b/vms/ext/Filespec.pm @@ -25,7 +25,7 @@ candelete('my:[VMS.or.Unix]file.specification'); This package provides routines to simplify conversion between VMS and Unix syntax when processing file specifications. This is useful when porting scripts designed to run under either OS, and also allows you -to take advantage of conveniences provided by either syntax (e.g. +to take advantage of conveniences provided by either syntax (I<e.g.> ability to easily concatenate Unix-style specifications). In addition, it provides an additional file test routine, C<candelete>, which determines whether you have delete access to a file. @@ -53,6 +53,12 @@ directory path (e.g [---.foo] when in dev:[dir.sub]) will cause errors. In general, any legal file specification will be converted properly, but garbage input tends to produce garbage output. +Each of these routines is prototyped as taking a single scalar +argument, so you can use them as unary operators in complex +expressions (as long as you don't use the C<&> form of +subroutine call, which bypasses prototype checking). + + The routines provided are: =head2 vmsify @@ -104,11 +110,13 @@ C<candelete> becomes part of the Perl core. =head1 REVISION -This document was last revised 08-Dec-1995, for Perl 5.002. +This document was last revised 22-Feb-1996, for Perl 5.002. =cut package VMS::Filespec; +require 5.002; + # If you want to use this package on a non-VMS system, # uncomment the following line. @@ -182,7 +190,7 @@ sub rmsexpand { $fspec; } -sub vmsify { +sub vmsify ($) { my($fspec) = @_; my($hasdev,$dev,$defdirs,$dir,$base,@dirs,@realdirs); @@ -215,7 +223,7 @@ sub vmsify { } } -sub unixify { +sub unixify ($) { my($fspec) = @_; return $fspec if $fspec !~ m#[:>\]]#; @@ -244,7 +252,7 @@ sub unixify { } -sub fileify { +sub fileify ($) { my($path) = @_; if (!$path) { return undef } @@ -279,7 +287,7 @@ sub fileify { } } -sub pathify { +sub pathify ($) { my($fspec) = @_; if (!$fspec) { return undef } @@ -304,15 +312,15 @@ sub pathify { } } -sub vmspath { +sub vmspath ($) { pathify(vmsify($_[0])); } -sub unixpath { +sub unixpath ($) { pathify(unixify($_[0])); } -sub candelete { +sub candelete ($) { my($fspec) = @_; my($parent); diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl index e39b7c2630..56ebc4b7da 100644 --- a/vms/gen_shrfls.pl +++ b/vms/gen_shrfls.pl @@ -34,11 +34,24 @@ # (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)? # # Author: Charles Bailey bailey@genetics.upenn.edu -# Revised: 4-Dec-1995 +# Revised: 20-Feb-1996 require 5.000; $debug = $ENV{'GEN_SHRFLS_DEBUG'}; + +if ($ARGV[0] eq '-f') { + open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n"; + print "Input taken from file $ARGV[1]\n" if $debug; + @ARGV = (); + while (<INP>) { + chomp; + push(@ARGV,split(/\|/,$_)); + } + close INP; + print "Read input data | ",join(' | ',@ARGV)," |\n" if $debug > 1; +} + $cc_cmd = shift @ARGV; # Someday, we'll have $GetSyI built into perl . . . @@ -75,7 +88,7 @@ if ($docc) { else { die "$0: Can't find perl.h\n"; } } else { - ($junk,$ccvers,$cpp_file,$cc_cmd) = split(/~~/,$cc_cmd,4); + ($junk,$junk,$cpp_file,$cc_cmd) = split(/~~/,$cc_cmd,4); $isgcc = $cc_cmd =~ /case_hack/i or 0; # for nice debug output $isvaxc = (!$isgcc && $cc_cmd !~ /standard=/i) @@ -158,7 +171,7 @@ if ($docc) { or die "$0: Can't preprocess ${dir}perl.h: $!\n"; } else { - open(CPP,"$cpp_file") or die "$0: Can't read $cpp_file: $!\n"; + open(CPP,"$cpp_file") or die "$0: Can't read preprocessed file $cpp_file: $!\n"; } LINE: while (<CPP>) { while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) { @@ -320,7 +333,7 @@ if ($isvax) { # Linker wants /Include and /Library on different lines print OPTBLD "$libperl/Include=($incstr)\n"; print OPTBLD "$libperl/Library\n"; -open(RTLOPT,$rtlopt) or die "$0: Can't read $rtlopt: $!\n"; +open(RTLOPT,$rtlopt) or die "$0: Can't read options file $rtlopt: $!\n"; while (<RTLOPT>) { print OPTBLD; } close RTLOPT; close OPTBLD; diff --git a/vms/genconfig.pl b/vms/genconfig.pl index 781a0b72a7..d4194bd3e1 100644 --- a/vms/genconfig.pl +++ b/vms/genconfig.pl @@ -12,6 +12,15 @@ unshift(@INC,'lib'); # In case someone didn't define Perl_Root # before the build +if ($ARGV[0] eq '-f') { + open(ARGS,$ARGV[1]) or die "Can't read data from $ARGV[1]: $!\n"; + @ARGV = (); + while (<ARGS>) { + push(@ARGV,split(/\|/,$_)); + } + close ARGS; +} + if (-f "config.vms") { $infile = "config.vms"; $outdir = "[-]"; } elsif (-f "[.vms]config.vms") { $infile = "[.vms]config.vms"; $outdir = "[]"; } elsif (-f "config.h") { $infile = "config.h"; $outdir = "[]";} @@ -194,6 +203,7 @@ $archlib = &VMS::Filespec::vmspath($privlib); $installarchlib = &VMS::Filespec::vmspath($installprivlib); $sitearch = &VMS::Filespec::vmspath($sitelib); $archlib =~ s#\]#.VMS_$archsufx\]#; +$sitearch =~ s#\]#.VMS_$archsufx\]#; print OUT "oldarchlib='$archlib'\n"; print OUT "oldarchlibexp='$archlib'\n"; ($vers = $]) =~ tr/./_/; diff --git a/vms/perlvms.pod b/vms/perlvms.pod index 47ee3d3afd..377d97f6fe 100644 --- a/vms/perlvms.pod +++ b/vms/perlvms.pod @@ -242,45 +242,6 @@ documented L<perl>, except that the element separator is '|' instead of ':'. The directory specifications may use either VMS or Unix syntax. -=head1 %ENV - -Reading the elements of the %ENV array returns the -translation of the logical name specified by the key, -according to the normal search order of access modes and -logical name tables. If you append a semicolon to the -logical name, followed by an integer, that integer is -used as the translation index for the logical name, -so that you can look up successive values for search -list logical names. For instance, if you say - - $ Define STORY once,upon,a,time,there,was - $ perl -e "for ($i = 0; $i <= 6; $i++) " - - _$ -e "{ print $ENV{'foo'.$i},' '}" - -Perl will print C<ONCE UPON A TIME THERE WAS>. - -The %ENV keys C<home>, C<path>,C<term>, and C<user> -return the CRTL "environment variables" of the same -names, if these logical names are not defined. The -key C<default> returns the current default device -and directory specification, regardless of whether -there is a logical name DEFAULT defined.. - -Setting an element of %ENV defines a supervisor-mode logical -name in the process logical name table. C<Undef>ing or -C<delete>ing an element of %ENV deletes the equivalent user- -mode or supervisor-mode logical name from the process logical -name table. If you use C<undef>, the %ENV element remains -empty. If you use C<delete>, another attempt is made at -logical name translation after the deletion, so an inner-mode -logical name or a name in another logical name table will -replace the logical name just deleted. It is not possible -at present to define a search list logical name via %ENV. - -In all operations on %ENV, the key string is treated as if it -were entirely uppercase, regardless of the case actually -specified in the Perl expression. - =head1 Perl functions As of the time this document was last revised, the following @@ -558,6 +519,67 @@ and you invoked Perl with the C<-w> switch, a warning will be issued.) The FLAGS argument is ignored in all cases. +=head1 Perl variables + +=item %ENV + +Reading the elements of the %ENV array returns the +translation of the logical name specified by the key, +according to the normal search order of access modes and +logical name tables. If you append a semicolon to the +logical name, followed by an integer, that integer is +used as the translation index for the logical name, +so that you can look up successive values for search +list logical names. For instance, if you say + + $ Define STORY once,upon,a,time,there,was + $ perl -e "for ($i = 0; $i <= 6; $i++) " - + _$ -e "{ print $ENV{'foo'.$i},' '}" + +Perl will print C<ONCE UPON A TIME THERE WAS>. + +The %ENV keys C<home>, C<path>,C<term>, and C<user> +return the CRTL "environment variables" of the same +names, if these logical names are not defined. The +key C<default> returns the current default device +and directory specification, regardless of whether +there is a logical name DEFAULT defined.. + +Setting an element of %ENV defines a supervisor-mode logical +name in the process logical name table. C<Undef>ing or +C<delete>ing an element of %ENV deletes the equivalent user- +mode or supervisor-mode logical name from the process logical +name table. If you use C<undef>, the %ENV element remains +empty. If you use C<delete>, another attempt is made at +logical name translation after the deletion, so an inner-mode +logical name or a name in another logical name table will +replace the logical name just deleted. It is not possible +at present to define a search list logical name via %ENV. + +In all operations on %ENV, the key string is treated as if it +were entirely uppercase, regardless of the case actually +specified in the Perl expression. + +=item $? + +Since VMS status values are 32 bits wide, the value of C<$?> +is simply the final status value of the last subprocess to +complete. This differs from the behavior of C<$?> under Unix, +and under VMS' POSIX environment, in that the low-order 8 bits +of C<$?> do not specify whether the process terminated normally +or due to a signal, and you do not need to shift C<$?> 8 bits +to the right in order to find the process' exit status. + +=item $! + +The string value of C<$!> is that returned by the CRTL's +strerror() function, so it will include the VMS message for +VMS-specific errors. The numeric value of C<$!> is the +value of C<errno>, except if errno is EVMSERR, in which +case C<$!> contains the value of vaxc$errno. Setting C<$!> +always sets errno to the value specified, and sets vaxc$errno +to 4 (NONAME-F-NOMSG). + =head1 Revision date This document was last updated on 16-Dec-1994, for Perl 5, diff --git a/vms/perly_c.vms b/vms/perly_c.vms index 86449982b7..9904682399 100644 --- a/vms/perly_c.vms +++ b/vms/perly_c.vms @@ -1319,7 +1319,7 @@ dEXT int yyerrflag; dEXT int yychar; dEXT YYSTYPE yyval; dEXT YYSTYPE yylval; -#line 572 "perly.y" +#line 571 "perly.y" /* PROGRAM */ #line 1394 "y_tab.c" #define YYABORT goto yyabort @@ -2084,19 +2084,18 @@ break; case 122: #line 455 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, - append_elem(OP_LIST, - yyvsp[0].opval, newCVREF(0,scalar(yyvsp[-1].opval)))); } + append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 123: -#line 459 "perly.y" +#line 458 "perly.y" { yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } break; case 124: -#line 461 "perly.y" +#line 460 "perly.y" { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; case 125: -#line 463 "perly.y" +#line 462 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, @@ -2106,7 +2105,7 @@ case 125: )),Nullop)); dep();} break; case 126: -#line 471 "perly.y" +#line 470 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, @@ -2117,138 +2116,138 @@ case 126: )))); dep();} break; case 127: -#line 480 "perly.y" +#line 479 "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 128: -#line 484 "perly.y" +#line 483 "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 129: -#line 489 "perly.y" +#line 488 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); hints |= HINT_BLOCK_SCOPE; } break; case 130: -#line 492 "perly.y" +#line 491 "perly.y" { yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; case 131: -#line 494 "perly.y" +#line 493 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 132: -#line 496 "perly.y" +#line 495 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 133: -#line 498 "perly.y" +#line 497 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 134: -#line 500 "perly.y" +#line 499 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 135: -#line 502 "perly.y" +#line 501 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 136: -#line 505 "perly.y" +#line 504 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 137: -#line 507 "perly.y" +#line 506 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, 0); } break; case 138: -#line 509 "perly.y" +#line 508 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; case 139: -#line 512 "perly.y" +#line 511 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; case 140: -#line 514 "perly.y" +#line 513 "perly.y" { yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 141: -#line 516 "perly.y" +#line 515 "perly.y" { yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; case 142: -#line 518 "perly.y" +#line 517 "perly.y" { yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; case 145: -#line 524 "perly.y" +#line 523 "perly.y" { yyval.opval = Nullop; } break; case 146: -#line 526 "perly.y" +#line 525 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 147: -#line 530 "perly.y" +#line 529 "perly.y" { yyval.opval = Nullop; } break; case 148: -#line 532 "perly.y" +#line 531 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 149: -#line 534 "perly.y" +#line 533 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 150: -#line 538 "perly.y" +#line 537 "perly.y" { yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); } break; case 151: -#line 542 "perly.y" +#line 541 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; case 152: -#line 546 "perly.y" +#line 545 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 153: -#line 550 "perly.y" +#line 549 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; case 154: -#line 554 "perly.y" +#line 553 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 155: -#line 558 "perly.y" +#line 557 "perly.y" { yyval.opval = newGVREF(0,yyvsp[0].opval); } break; case 156: -#line 562 "perly.y" +#line 561 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 157: -#line 564 "perly.y" +#line 563 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 158: -#line 566 "perly.y" +#line 565 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 159: -#line 569 "perly.y" +#line 568 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2237 "y_tab.c" +#line 2236 "y_tab.c" } yyssp -= yym; yystate = *yyssp; @@ -1190,7 +1190,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts) if (cp1) { for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS '-' ==> Unix '../' */ } - New(7015,rslt,retlen+1+2*dashes,char); + New(7015,rslt,retlen+2+2*dashes,char); } else rslt = __tounixspec_retbuf; if (strchr(spec,'/') != NULL) { @@ -1207,12 +1207,16 @@ static char *do_tounixspec(char *spec, char *buf, int ts) strcpy(rslt,spec); return rslt; } - if (*cp2 != '[') { + if (*cp2 != '[' && *cp2 != '<') { *(cp1++) = '/'; } else { /* the VMS spec begins with directories */ cp2++; - if (*cp2 == '-') { + if (*cp2 == ']' || *cp2 == '>') { + strcpy(rslt,"./"); + return rslt; + } + else if (*cp2 == '-') { while (*cp2 == '-') { *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/'; cp2++; @@ -1693,7 +1697,7 @@ getredirection(int *ac, char ***av) /* Check for input from a pipe (mailbox) */ - if (1 == isapipe(0)) + if (in == NULL && 1 == isapipe(0)) { char mbxname[L_tmpnam]; long int bufsize; @@ -1704,11 +1708,6 @@ getredirection(int *ac, char ***av) /* Input from a pipe, reopen it in binary mode to disable */ /* carriage control processing. */ - if (in != NULL) - { - fprintf(stderr,"'|' and '<' may not both be specified on command line"); - exit(LIB$_INVARGORD); - } fgetname(stdin, mbxname,1); mbxnam.dsc$a_pointer = mbxname; mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer); @@ -2986,7 +2985,7 @@ cando_by_name(I32 bit, I32 effective, char *fname) static char usrname[L_cuserid]; static struct dsc$descriptor_s usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname}; - + char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1]; unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2]; unsigned short int retlen; struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; @@ -2997,12 +2996,21 @@ cando_by_name(I32 bit, I32 effective, char *fname) {0,0,0,0}}; if (!fname || !*fname) return FALSE; + if (!do_tovmsspec(fname,vmsname,1)) return FALSE; + retlen = namdsc.dsc$w_length = strlen(vmsname); + namdsc.dsc$a_pointer = vmsname; + if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' || + vmsname[retlen-1] == ':') { + if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE; + namdsc.dsc$w_length = strlen(fileified); + namdsc.dsc$a_pointer = fileified; + } + if (!usrdsc.dsc$w_length) { cuserid(usrname); usrdsc.dsc$w_length = strlen(usrname); } - namdsc.dsc$w_length = strlen(fname); - namdsc.dsc$a_pointer = fname; + switch (bit) { case S_IXUSR: case S_IXGRP: @@ -3126,6 +3134,158 @@ my_getlogin() /*}}}*/ +/* rmscopy - copy a file using VMS RMS routines + * + * Copies contents and attributes of spec_in to spec_out, except owner + * and protection information. Name and type of spec_in are used as + * defaults for spec_out. Returns 1 on success; returns 0 and sets + * errno and vaxc$errno on failure. + * + * Copyright 1996 by Charles Bailey <bailey@genetics.upenn.edu>. + * Incorporates, with permission, some code from EZCOPY by Tim Adye + * <T.J.Adye@rl.ac.uk>. Permission is given to use and distribute this + * code under the same terms as Perl itself. (See the GNU General Public + * License or the Perl Artistic License supplied as part of the Perl + * distribution.) + */ +/*{{{int rmscopy(char *src, char *dst)*/ +int +rmscopy(char *spec_in, char *spec_out) +{ + char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS], + rsa[NAM$C_MAXRSS], ubf[32256]; + unsigned long int i, sts, sts2; + struct FAB fab_in, fab_out; + struct RAB rab_in, rab_out; + struct NAM nam; + struct XABDAT xabdat; + struct XABFHC xabfhc; + struct XABRDT xabrdt; + struct XABSUM xabsum; + + if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) || + !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) { + set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); + return 0; + } + + fab_in = cc$rms_fab; + fab_in.fab$l_fna = vmsin; + fab_in.fab$b_fns = strlen(vmsin); + fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI; + fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET; + fab_in.fab$l_fop = FAB$M_SQO; + fab_in.fab$l_nam = &nam; + fab_in.fab$l_xab = (void*) &xabdat; + + nam = cc$rms_nam; + nam.nam$l_rsa = rsa; + nam.nam$b_rss = sizeof(rsa); + nam.nam$l_esa = esa; + nam.nam$b_ess = sizeof (esa); + nam.nam$b_esl = nam.nam$b_rsl = 0; + + xabdat = cc$rms_xabdat; /* To get creation date */ + xabdat.xab$l_nxt = (void*) &xabfhc; + + xabfhc = cc$rms_xabfhc; /* To get record length */ + xabfhc.xab$l_nxt = (void*) &xabsum; + + xabsum = cc$rms_xabsum; /* To get key and area information */ + + if (!((sts = sys$open(&fab_in)) & 1)) { + set_vaxc_errno(sts); + switch (sts) { + case RMS$_FNF: + case RMS$_DIR: + set_errno(ENOENT); break; + case RMS$_DEV: + set_errno(ENODEV); break; + case RMS$_SYN: + set_errno(EINVAL); break; + case RMS$_PRV: + set_errno(EACCES); break; + default: + set_errno(EVMSERR); + } + return 0; + } + + fab_out = fab_in; + fab_out.fab$w_ifi = 0; + fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT; + fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI; + fab_out.fab$l_fop = FAB$M_SQO; + fab_out.fab$l_fna = vmsout; + fab_out.fab$b_fns = strlen(vmsout); + fab_out.fab$l_dna = nam.nam$l_name; + fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0; + if (!((sts = sys$create(&fab_out)) & 1)) { + set_vaxc_errno(sts); + switch (sts) { + case RMS$_DIR: + set_errno(ENOENT); break; + case RMS$_DEV: + set_errno(ENODEV); break; + case RMS$_SYN: + set_errno(EINVAL); break; + case RMS$_PRV: + set_errno(EACCES); break; + default: + set_errno(EVMSERR); + } + return 0; + } + fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */ + /* sys$close() will process xabrdt, not xabdat */ + xabrdt = cc$rms_xabrdt; + xabrdt.xab$q_rdt = xabdat.xab$q_rdt; + fab_out.fab$l_xab = &xabrdt; + + rab_in = cc$rms_rab; + rab_in.rab$l_fab = &fab_in; + rab_in.rab$l_rop = RAB$M_BIO; + rab_in.rab$l_ubf = ubf; + rab_in.rab$w_usz = sizeof ubf; + if (!((sts = sys$connect(&rab_in)) & 1)) { + sys$close(&fab_in); sys$close(&fab_out); + set_errno(EVMSERR); set_vaxc_errno(sts); + return 0; + } + + rab_out = cc$rms_rab; + rab_out.rab$l_fab = &fab_out; + rab_out.rab$l_rbf = ubf; + if (!((sts = sys$connect(&rab_out)) & 1)) { + sys$close(&fab_in); sys$close(&fab_out); + set_errno(EVMSERR); set_vaxc_errno(sts); + return 0; + } + + while ((sts = sys$read(&rab_in))) { /* always true */ + if (sts == RMS$_EOF) break; + rab_out.rab$w_rsz = rab_in.rab$w_rsz; + if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) { + sys$close(&fab_in); sys$close(&fab_out); + set_errno(EVMSERR); set_vaxc_errno(sts); + return 0; + } + } + + fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */ + sys$close(&fab_in); sys$close(&fab_out); + sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts; + if (!(sts & 1)) { + set_errno(EVMSERR); set_vaxc_errno(sts); + return 0; + } + + return 1; + +} /* end of rmscopy() */ +/*}}}*/ + + /*** The following glue provides 'hooks' to make some of the routines * from this file available from Perl. These routines are sufficiently * basic, and are required sufficiently early in the build process, @@ -3217,12 +3377,80 @@ void candelete_fromperl(CV *cv) { dXSARGS; - char vmsspec[NAM$C_MAXRSS+1]; + char fspec[NAM$C_MAXRSS+1], *fsp; + SV *mysv; + IO *io; if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)"); - if (do_tovmsspec(SvPV(ST(0),na),buf,0) && cando_by_name(S_IDUSR,0,buf)) - ST(0) = &sv_yes; - else ST(0) = &sv_no; + + mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0); + if (SvTYPE(mysv) == SVt_PVGV) { + if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),fspec)) { + set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); + ST(0) = &sv_no; + XSRETURN(1); + } + fsp = fspec; + } + else { + if (mysv != ST(0) || !(fsp = SvPV(mysv,na)) || !*fsp) { + set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); + ST(0) = &sv_no; + XSRETURN(1); + } + } + + ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no; + XSRETURN(1); +} + +void +rmscopy_fromperl(CV *cv) +{ + dXSARGS; + char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp; + struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}, + outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + unsigned long int sts; + SV *mysv; + IO *io; + + if (items != 2) croak("Usage: File::Copy::rmscopy(from,to)"); + + mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0); + if (SvTYPE(mysv) == SVt_PVGV) { + if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),inspec)) { + set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); + ST(0) = &sv_no; + XSRETURN(1); + } + inp = inspec; + } + else { + if (mysv != ST(0) || !(inp = SvPV(mysv,na)) || !*inp) { + set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); + ST(0) = &sv_no; + XSRETURN(1); + } + } + mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); + if (SvTYPE(mysv) == SVt_PVGV) { + if (!(io = GvIOp(mysv)) || !fgetname(IoIFP(io),outspec)) { + set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); + ST(0) = &sv_no; + XSRETURN(1); + } + outp = outspec; + } + else { + if (mysv != ST(1) || !(outp = SvPV(mysv,na)) || !*outp) { + set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); + ST(0) = &sv_no; + XSRETURN(1); + } + } + + ST(0) = rmscopy(inp,outp) ? &sv_yes : &sv_no; XSRETURN(1); } @@ -3231,13 +3459,14 @@ init_os_extras() { char* file = __FILE__; - newXS("VMS::Filespec::vmsify",vmsify_fromperl,file); - newXS("VMS::Filespec::unixify",unixify_fromperl,file); - newXS("VMS::Filespec::pathify",pathify_fromperl,file); - newXS("VMS::Filespec::fileify",fileify_fromperl,file); - newXS("VMS::Filespec::vmspath",vmspath_fromperl,file); - newXS("VMS::Filespec::unixpath",unixpath_fromperl,file); - newXS("VMS::Filespec::candelete",candelete_fromperl,file); + newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$"); + newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$"); + newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$"); + newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$"); + newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$"); + newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$"); + newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$"); + newXS("File::Copy::rmscopy",rmscopy_fromperl,file); return; } diff --git a/vms/vmsish.h b/vms/vmsish.h index 55508b9f97..000ba29c2a 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -189,6 +189,9 @@ struct tms { #define Stat(name,bufptr) flex_stat(name,bufptr) #define Fstat(fd,bufptr) flex_fstat(fd,bufptr) +/* By default, flush data all the way to disk, not just to RMS buffers */ +#define Fflush(fp) ((fflush(fp) || fsync(fileno(fp))) ? EOF : 0) + /* Setup for the dirent routines: * opendir(), closedir(), readdir(), seekdir(), telldir(), and * vmsreaddirversions(), and preprocessor stuff on which these depend: @@ -348,6 +351,7 @@ struct passwd * my_getpwuid _((Uid_t uid)); struct passwd * my_getpwent _(()); void my_endpwent _(()); char * my_getlogin _(()); +int rmscopy _((char *, char *)); void init_os_extras _(()); typedef char __VMS_SEPYTOTORP__; /* prototype section end marker; `typedef' passes through cpp */ |