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
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
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
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
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
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
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
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
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
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
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
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
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
# $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!!!!!
d_shmctl=''
d_shmdt=''
d_shmget=''
+d_sigsetjmp=''
d_sigaction=''
d_sigintrp=''
d_sigvec=''
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
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:
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
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
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'
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
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
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
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
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
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.
*/
#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.
open CONFIG, ">$config_pm" or die "Can't open $config_pm: $!\n";
-$myver = sprintf("%.3f", $]);
+$myver = $];
print CONFIG <<"ENDOFBEG";
package Config;
\@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.
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
#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)
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)
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
#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)
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;
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:
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
--- /dev/null
+# 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'];
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
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
#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
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");
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);
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(...)
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;
GvNAME(gv) = savepvn(name, len);
GvNAMELEN(gv) = len;
if (multi)
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
}
static void
gv = *gvp;
if (SvTYPE(gv) == SVt_PVGV)
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
else if (!add)
return Nullgv;
else
{
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);
gv = *gvp;
if (SvTYPE(gv) == SVt_PVGV) {
if (add) {
- SvMULTI_on(gv);
+ GvMULTI_on(gv);
gv_init_sv(gv, sv_type);
}
return gv;
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)
{
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;
if (strEQ(name, "SIG")) {
HV *hv;
siggv = gv;
- SvMULTI_on(siggv);
+ GvMULTI_on(siggv);
hv = GvHVn(siggv);
hv_magic(hv, siggv, 'S');
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;
}
}
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));
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))
#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)
#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
#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
alignbytes=8
+usemymalloc='n'
+
# Make setsockopt work correctly. See man page.
# ccflags='-D_BSD=44'
# 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"
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"
#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
# 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.
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"
;;
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
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
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
sub catdir {
shift;
- my $result = join('/',@_,'/');
+ my $result = join('/',@_);
$result =~ s:/\./:/:g;
$result =~ s:/+:/:g;
$result;
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){
$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};
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;
}
# 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
.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;
}
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
# 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;
use File::Basename;
Exporter::import('ExtUtils::MakeMaker', '$Verbose', '&neatvalue');
-unshift @MM::ISA, 'ExtUtils::MM_VMS';
sub eliminate_macros {
$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;
}
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;
}
}
+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 _;
$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';
&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});
}
$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)
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.)
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);"
+!;
}
}
my(@m);
push @m, '
-all :: config $(INST_PM) subdirs linkext manifypods reorg_packlist
+all :: config $(INST_PM) subdirs linkext manifypods
$(NOOP)
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}}) {
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);
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
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;" -
$(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)');
'.$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 ---
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);
",' ',$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")
# --- 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){
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);
}
',$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."
';
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:
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);
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.'
';
}
',$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
join '', @m;
}
-sub extliblist {
+sub ext {
my($self) = @_;
unless (ref $self){
ExtUtils::MakeMaker::TieAtt::warndirectuse((caller(0))[3]);
# 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) = @_;
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;
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.
-
}
#
-# 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;
}
$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};
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.
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
=head1 REVISION
-Last revised 14-Jan-1996, for Perl 5.002.
+Last revised 14-Feb-1996, for Perl 5.002.
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 = $\;
1;
__END__
+
=head1 NAME
File::Copy - Copy files or filehandles
-=head1 USAGE
+=head1 SYNOPSIS
use File::Copy;
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.
=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
=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;
$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
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));
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: $!";
}
@EXPORT = qw(collate_xfrm setlocale LC_COLLATE);
@EXPORT_OK = qw();
-%OVERLOAD = qw(
+use overload qw(
fallback 1
cmp collate_cmp
);
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
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'.
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
-
-\f
# Convert a number to canonical string form.
# Takes something that looks like a number and converts it to
# the form /^[+-]\d+E[+-]\d+$/.
&norm(Math::BigInt::bmul($xm,$ym),$xe+$ye);
}
}
-\f
+
# addition
sub fadd { #(fnum_str, fnum_str) return fnum_str
local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1]));
$xe-$ye-$scale);
}
}
-\f
+
# 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) = @_;
}
}
}
-\f
+
# round $x at the 10 to the $scale digit place
sub ffround { #(fnum_str, scale) return fnum_str
local($x,$scale) = (fnorm($_[$[]),$_[$[+1]);
);
}
}
-\f
+
# square root by Newtons method.
sub fsqrt { #(fnum_str[, scale]) return fnum_str
local($x, $scale) = (fnorm($_[$[]), $_[$[+1]);
$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
package Math::BigInt;
-%OVERLOAD = (
- # Anonymous subroutines:
+use overload
'+' => sub {new Math::BigInt &badd},
'-' => sub {new Math::BigInt
$_[2]? bsub($_[1],${$_[0]}) : bsub(${$_[0]},$_[1])},
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;
-\f
+
# 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'.
s/^-/+/;
$_;
}
-\f
+
# 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]));
$x;
}
}
-\f
+
# 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
sub bmod { #(num_str, num_str) return num_str
(&bdiv(@_))[$[+1];
}
-\f
+
sub bdiv { #(dividend: num_str, divisor: num_str) return num_str
local (*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1]));
return wantarray ? ('NaN','NaN') : 'NaN'
}
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
-#
-# 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;
# just to make use happy
-%OVERLOAD= (
+use overload
'+' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]});
bless [ $x1+$x2, $y1+$y2];
},
},
qw("" stringify)
-);
+;
sub new {
- shift;
+ my $class = shift;
my @C = @_;
- bless \@C;
+ bless \@C, $class;
}
sub Re {
$_ = 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
}
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
@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);
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,$_);
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.
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;
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);
#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]) \
SvFLAGS(sv) |= SVf_FAKE;
}
av_store(comppad, newoff, SvREFCNT_inc(oldsv));
- SvFLAGS(compcv) |= SVpcv_CLONE;
+ CvCLONE_on(compcv);
return newoff;
}
}
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;
}
}
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;
}
}
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;
}
}
SAVESPTR(curpad);
curpad = 0;
- if (!(SvFLAGS(cv) & SVpcv_CLONED))
+ if (!CvCLONED(cv))
op_free(CvROOT(cv));
CvROOT(cv) = Nullop;
LEAVE;
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));
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;
LEAVE_SCOPE(floor);
if (!op) {
GvCV(gv) = 0; /* Will remember in SVOP instead. */
- SvFLAGS(cv) |= SVpcv_ANON;
+ CvANON_on(cv);
}
return cv;
}
char *filename;
{
CV* cv = newXS(name, (void(*)())subaddr, filename);
- CvOLDSTYLE(cv) = TRUE;
+ CvOLDSTYLE_on(cv);
CvXSUBANY(cv).any_i32 = ix;
return cv;
}
}
if (!name) {
GvCV(gv) = 0; /* Will remember elsewhere instead. */
- SvFLAGS(cv) |= SVpcv_ANON;
+ CvANON_on(cv);
}
return cv;
}
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;
0x00000604, /* binmode */
0x00021755, /* tie */
0x00000714, /* untie */
- 0x0000070c, /* tied */
+ 0x00000704, /* tied */
0x00011414, /* dbmopen */
0x00000414, /* dbmclose */
0x00111108, /* sselect */
0x00000000, /* leavewrite */
0x00002e15, /* prtf */
0x00002e15, /* print */
- 0x0091160c, /* sysopen */
+ 0x00911604, /* sysopen */
0x0091761d, /* sysread */
0x0091161d, /* syswrite */
0x0091161d, /* send */
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
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?
! 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
! 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
+++ /dev/null
-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)
#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
#define Stat(fname,bufptr) stat((fname),(bufptr))
#define Fstat(fd,bufptr) fstat((fd),(bufptr))
+#define FFlush(fp) fflush(fp)
#endif
#define PATCHLEVEL 2
+#define SUBVERSION 0
#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 */
op_free(main_root);
main_root = 0;
- switch (setjmp(top_env)) {
+ switch (Sigsetjmp(top_env,1)) {
case 1:
#ifdef VMS
statusvalue = 255;
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;
curstash = defstash;
preprocess = FALSE;
if (e_fp) {
+ fclose(e_fp);
e_fp = Nullfp;
(void)UNLINK(e_tmpname);
}
{
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;
POPBLOCK(cx,curpm);
LEAVE;
}
- longjmp(top_env, 2);
+ Siglongjmp(top_env, 2);
}
SV*
SV** sp = stack_sp;
I32 oldmark = TOPMARK;
I32 retval;
- jmp_buf oldtop;
+ Sigjmp_buf oldtop;
I32 oldscope;
if (flags & G_DISCARD) {
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--;
markstack_ptr++;
restart:
- switch (setjmp(top_env)) {
+ switch (Sigsetjmp(top_env,1)) {
case 0:
break;
case 1:
/* 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);
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;
SV** sp = stack_sp;
I32 oldmark = sp - stack_base;
I32 retval;
- jmp_buf oldtop;
+ Sigjmp_buf oldtop;
I32 oldscope;
if (flags & G_DISCARD) {
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:
/* 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);
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;
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 != '=') {
}
} 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)
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);
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
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));
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;
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 */
}
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++) {
}
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 */
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)
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) {
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);
}
/* 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;
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 */
# extra globals not included above.
cat <<END >> perl.exp
+perl_init_i18nl14n
perl_init_ext
perl_alloc
perl_construct
int yychar;
YYSTYPE yyval;
YYSTYPE yylval;
-#line 572 "perly.y"
+#line 571 "perly.y"
/* PROGRAM */
#line 1394 "y.tab.c"
#define YYABORT goto yyabort
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,
)),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,
)))); 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;
-*** 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");
- 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 ----
#endif
yym = yylen[yyn];
***************
-*** 2243,2250 ****
+*** 2242,2249 ****
{
#if YYDEBUG
if (yydebug)
#endif
yystate = YYFINAL;
*++yyssp = YYFINAL;
---- 2257,2265 ----
+--- 2256,2264 ----
{
#if YYDEBUG
if (yydebug)
yystate = YYFINAL;
*++yyssp = YYFINAL;
***************
-*** 2258,2264 ****
+*** 2257,2263 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
YYFINAL, yychar, yys);
}
#endif
---- 2273,2279 ----
+--- 2272,2278 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
}
#endif
***************
-*** 2273,2292 ****
+*** 2272,2291 ****
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
yyaccept:
! return (0);
}
---- 2288,2322 ----
+--- 2287,2321 ----
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
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 '('
(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
(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
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
right = += -= *= etc.
left , =>
nonassoc list operators (rightward)
- left not
+ right not
left and
left or xor
\n newline
\r return
\f form feed
- \v vertical tab, whatever that is
\b backspace
\a alarm (bell)
\e escape
\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)
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
=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);
The next examples will use the following C++ class.
- class colors {
+ class color {
public:
- colors();
- ~colors();
+ color();
+ ~color();
int blue();
void set_blue( int );
=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
if (op->op_flags & OPf_SPECIAL) {
GvGP(sv)->gp_refcnt++; /* will soon be assigned */
- GvFLAGS(sv) |= GVf_INTRO;
+ GvINTRO_on(sv);
}
else {
GP *gp;
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;
}
restartop = die_where(message);
if ((!restartop && was_in_eval) || oldrunlevel > 1)
- longjmp(top_env, 3);
+ Siglongjmp(top_env, 3);
return restartop;
}
}
}
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);
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 */
}
}
if (do_dump) {
+#ifdef VMS
+ if (!retop) retop = main_start;
+#endif
restartop = retop;
do_undump = TRUE;
if (stack == signalstack) {
restartop = retop;
- longjmp(top_env, 3);
+ Siglongjmp(top_env, 3);
}
RETURNOP(retop);
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);
goto just_say_no;
if (IoFLAGS(io) & IOf_FLUSH)
- if (fflush(fp) == EOF)
+ if (Fflush(fp) == EOF)
goto just_say_no;
}
}
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);
#ifdef DOSISH
#ifdef atarist
- if (!fflush(fp) && (fp->_flag |= _IOBIN))
+ if (!Fflush(fp) && (fp->_flag |= _IOBIN))
RETPUSHYES;
else
RETPUSHUNDEF;
PP(pp_tied)
{
- dSP; dTARGET ;
+ dSP;
SV * sv ;
MAGIC * mg ;
SvCUR_set(formtarget, 0);
*SvEND(formtarget) = '\0';
if (IoFLAGS(io) & IOf_FLUSH)
- (void)fflush(fp);
+ (void)Fflush(fp);
PUSHs(&sv_yes);
}
}
goto just_say_no;
if (IoFLAGS(io) & IOf_FLUSH)
- if (fflush(fp) == EOF)
+ if (Fflush(fp) == EOF)
goto just_say_no;
}
SvREFCNT_dec(sv);
PP(pp_sysopen)
{
- dSP; dTARGET;
+ dSP;
GV *gv;
- IO *io;
SV *sv;
char *tmps;
STRLEN len;
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)];
if (SvTYPE(sv) == mt)
return TRUE;
+ if (mt < SVt_PVIV)
+ (void)SvOOK_off(sv);
+
switch (SvTYPE(sv)) {
case SVt_NULL:
pv = 0;
GvNAME(sv) = 0;
GvNAMELEN(sv) = 0;
GvSTASH(sv) = 0;
+ GvFLAGS(sv) = 0;
break;
case SVt_PVBM:
SvANY(sv) = new_XPVBM();
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);
}
break;
}
if (SvNOKp(sv)) {
+ (void)SvIOK_on(sv);
if (SvNVX(sv) < 0.0)
SvIVX(sv) = I_V(SvNVX(sv));
else
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 {
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);
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;
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);
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 */
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)
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)
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)
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)
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)
* 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);
memcpy((char*)bp, (char*)ptr, cnt); /* this | eat */
bp += cnt; /* screams | dust */
ptr += cnt; /* louder | sed :-) */
+ cnt = 0;
}
}
mg_get(sv);
flags = SvFLAGS(sv);
if (flags & SVp_IOK) {
- ++SvIVX(sv);
(void)SvIOK_only(sv);
+ ++SvIVX(sv);
return;
}
if (flags & SVp_NOK) {
mg_get(sv);
flags = SvFLAGS(sv);
if (flags & SVp_IOK) {
- --SvIVX(sv);
(void)SvIOK_only(sv);
+ --SvIVX(sv);
return;
}
if (flags & SVp_NOK) {
gp_free(sv);
sv_unmagic(sv, '*');
Safefree(GvNAME(sv));
- SvMULTI_off(sv);
+ GvMULTI_off(sv);
SvFLAGS(sv) &= ~SVTYPEMASK;
SvFLAGS(sv) |= SVt_PVMG;
}
#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 */
char* xgv_name;
STRLEN xgv_namelen;
HV* xgv_stash;
+ U8 xgv_flags;
};
struct xpvbm {
#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)
#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)
--- /dev/null
+#!./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;
if (rsfp == stdin)
clearerr(rsfp);
- else if (rsfp != fp)
+ else if (rsfp && (rsfp != fp))
fclose(rsfp);
rsfp = fp;
}
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;
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;
}
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;
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;
PREBLOCK(LSTOPSUB);
}
}
+ nextval[nexttoke].opval = yylval.opval;
expect = XTERM;
force_next(WORD);
TOKEN(NOAMP);
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;
#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)
}
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);
#ifdef LEAKTEST
DEBUG_L(xstat());
#endif
- (void)fflush(stderr);
+ (void)Fflush(stderr);
}
}
}
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);
#ifdef LEAKTEST
DEBUG_L(xstat());
#endif
- (void)fflush(stderr);
+ (void)Fflush(stderr);
}
}
#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
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
$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
}
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
+ }
}
}
}
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;
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);
# 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
CRTLOPTS =,$(CRTL)/Options
.SUFFIXES
+
+.ifdef LINK_ONLY
+.else
.SUFFIXES $(O) .c .xs
.xs.c :
.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)
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
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)
@ $(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 [--]
# 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 [--]
# 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]
@ @[.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)
$(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
# 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
@ 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
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
- 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 [--]
- 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 [--]
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.
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
=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.
$fspec;
}
-sub vmsify {
+sub vmsify ($) {
my($fspec) = @_;
my($hasdev,$dev,$defdirs,$dir,$base,@dirs,@realdirs);
}
}
-sub unixify {
+sub unixify ($) {
my($fspec) = @_;
return $fspec if $fspec !~ m#[:>\]]#;
}
-sub fileify {
+sub fileify ($) {
my($path) = @_;
if (!$path) { return undef }
}
}
-sub pathify {
+sub pathify ($) {
my($fspec) = @_;
if (!$fspec) { return undef }
}
}
-sub vmspath {
+sub vmspath ($) {
pathify(vmsify($_[0]));
}
-sub unixpath {
+sub unixpath ($) {
pathify(unixify($_[0]));
}
-sub candelete {
+sub candelete ($) {
my($fspec) = @_;
my($parent);
# (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 . . .
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)
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) {
# 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;
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 = "[]";}
$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/./_/;
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
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,
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
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,
)),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,
)))); 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;
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) {
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++;
/* Check for input from a pipe (mailbox) */
- if (1 == isapipe(0))
+ if (in == NULL && 1 == isapipe(0))
{
char mbxname[L_tmpnam];
long int bufsize;
/* 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);
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};
{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:
/*}}}*/
+/* 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,
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);
}
{
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;
}
#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:
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 */
projects / p5sagit/p5-mst-13.2.git / commitdiff