+-------------
+Version 5.001
+-------------
+
+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.
+
+There were a few that can be construed as enhancements:
+ NETaa13059: now warns of use of \1 where $1 is necessary.
+ NETaa13512: added $SIG{__WARN__} and $SIG{__DIE__} hooks
+ NETaa13520: added closures
+ NETaa13530: scalar keys now resets hash iterator
+ NETaa13641: added Tim's fancy new import whizbangers
+ NETaa13710: cryptswitch needed to be more "useable"
+ NETaa13716: Carp now allows multiple packages to be skipped out of
+ NETaa13716: now counts imported routines as "defined" for redef warnings
+ (and, of course, much of the stuff from the perl5-porters)
+
+NETaa12974: README incorrectly said it was a pre-release.
+Files patched: README
+
+NETaa13033: goto pushed a bogus scope on the context stack.
+From: Steve Vinoski
+Files patched: pp_ctl.c
+ The goto operator pushed an extra bogus scope onto the context stack. (This
+ often didn't matter, since many things pop extra unrecognized scopes off.)
+
+NETaa13034: tried to get valid pointer from undef.
+From: Castor Fu
+Also: Achille Hui, the Day Dreamer
+Also: Eric Arnold
+Files patched: pp_sys.c
+ Now treats undef specially, and calls SvPV_force on any non-numeric scalar
+ value to get a real pointer to somewhere.
+
+NETaa13035: included package info with filehandles.
+From: Jack Shirazi - BIU
+Files patched: pp_hot.c pp_sys.c
+ Now passes a glob to filehandle methods to keep the package info intact.
+
+NETaa13048: didn't give strict vars message on every occurrence.
+From: Doug Campbell
+Files patched: gv.c
+ It now complains about every occurrence. (The bug resulted from an
+ ill-conceived attempt to suppress a duplicate error message in a
+ suboptimal fashion.)
+
+NETaa13052: test for numeric sort sub return value fooled by taint magic.
+From: Peter Jaspers-Fayer
+Files patched: pp_ctl.c sv.h
+ The test to see if the sort sub return value was numeric looked at the
+ public flags rather than the private flags of the SV, so taint magic
+ hid that info from the sort.
+
+NETaa13053: forced a2p to use byacc
+From: Andy Dougherty
+Files patched: MANIFEST x2p/Makefile.SH x2p/a2p.c
+ a2p.c is now pre-byacced and shipped with the kit.
+
+NETaa13055: misnamed constant in previous patch.
+From: Conrad Augustin
+Files patched: op.c op.h toke.c
+ The tokener translates $[ to a constant, but with a special marking in case
+ the constant gets assigned to or localized. Unfortunately, the marking
+ was done with a combination of OPf_SPECIAL and OPf_MOD that was easily
+ spoofed. There is now a private OPpCONST_ARYLEN flag for this purpose.
+
+NETaa13055: use of OPf_SPECIAL for $[ lvaluehood was too fragile.
+Files patched: op.c op.h toke.c
+ (same)
+
+NETaa13056: convert needs to throw away any number info on its list.
+From: Jack Shirazi - BIU
+Files patched: op.c
+ The listiness of the argument list leaked out to the subroutine call because
+ of how prepend_elem and append_elem reuse an existing list. The convert()
+ routine just needs to discard any listiness it finds on its argument.
+
+NETaa13058: AUTOLOAD shouldn't assume size of @_ is meaningful.
+From: Florent Guillaume
+Files patched: ext/DB_File/DB_File.pm ext/Fcntl/Fcntl.pm ext/GDBM_File/GDBM_File.pm ext/Socket/Socket.pm h2xs.SH
+ I just deleted the optimization, which is silly anyway since the eventual
+ subroutine definition is cached.
+
+NETaa13059: now warns of use of \1 where $1 is necessary.
+From: Gustaf Neumann
+Files patched: toke.c
+ Now says
+
+ Can't use \1 to mean $1 in expression at foo line 2
+
+ along with an explanation in perldiag.
+
+NETaa13060: no longer warns on attempt to read <> operator's transition state.
+From: Chaim Frenkel
+Files patched: pp_hot.c
+ No longer warns on <> operator's transitional state.
+
+NETaa13140: warning said $ when @ would be more appropriate.
+From: David J. MacKenzie
+Files patched: op.c pod/perldiag.pod
+ Now says
+
+ (Did you mean $ or @ instead of %?)
+
+ and added more explanation to perldiag.
+
+NETaa13149: was reading freed memory to make incorrect error message.
+Files patched: pp_ctl.c
+ It was reading freed memory to make an error message that would be
+ incorrect in any event because it had the inner filename rather than
+ the outer.
+
+NETaa13149: confess was sometimes less informative than croak
+From: Jack Shirazi
+Files patched: lib/Carp.pm
+ (same)
+
+NETaa13150: stderr needs to be STDERR in package
+From: Jack Shirazi
+Files patched: lib/File/CheckTree.pm
+ Also fixed pl2pm to translate the filehandles to uppercase.
+
+NETaa13150: uppercases stdin, stdout and stderr
+Files patched: pl2pm
+ (same)
+
+NETaa13154: array assignment didn't notice package magic.
+From: Brian Reichert
+Files patched: pp_hot.c
+ The list assignment operator looked for only set magic, but set magic is
+ only on the elements of a magical hash, not on the hash as a whole. I made
+ the operator look for any magic at all on the target array or hash.
+
+NETaa13155: &DB::DB left trash on the stack.
+From: Thomas Koenig
+Files patched: lib/perl5db.pl pp_ctl.c
+ The call by pp_dbstate() to &DB::DB left trash on the stack. It now
+ calls DB in list context, and DB returns ().
+
+NETaa13156: lexical variables didn't show up in debugger evals.
+From: Joergen Haegg
+Files patched: op.c
+ The code that searched back up the context stack for the lexical scope
+ outside the eval only partially took into consideration that there
+ might be extra debugger subroutine frames that shouldn't be used, and
+ ended up comparing the wrong statement sequence number to the range of
+ valid sequence numbers for the scope of the lexical variable. (There
+ was also a bug fixed in passing that caused the scope of lexical to go
+ clear to the end of the subroutine even if it was within an inner block.)
+
+NETaa13157: any request for autoloaded DESTROY should create a null one.
+From: Tom Christiansen
+Files patched: lib/AutoLoader.pm
+ If DESTROY.al is not located, it now creates sub DESTROY {} automatically.
+
+NETaa13158: now preserves $@ around destructors while leaving eval.
+From: Tim Bunce
+Files patched: pp_ctl.c
+ Applied supplied patch, except the whole second hunk can be replaced with
+
+ sv_insert(errsv, 0, 0, message, strlen(message));
+
+NETaa13160: clarified behavior of split without arguments
+From: Harry Edmon
+Files patched: pod/perlfunc.pod
+ Clarified the behavior of split without arguments.
+
+NETaa13162: eval {} lost list/scalar context
+From: Dov Grobgeld
+Files patched: op.c
+ LEAVETRY didn't propagate number to ENTERTRY.
+
+NETaa13163: clarified documentation of foreach using my variable
+From: Tom Christiansen
+Files patched: pod/perlsyn.pod
+ Explained that foreach using a lexical is still localized.
+
+NETaa13164: the dot detector for the end of formats was over-rambunctious.
+From: John Stoffel
+Files patched: toke.c
+ The dot detector for the end of formats was over-rambunctious. It would
+ pick up any dot that didn't have a space in front of it.
+
+NETaa13165: do {} while 1 never linked outer block into next chain.
+From: Gisle Aas
+Files patched: op.c
+ When the conditional of do {} while 1; was optimized away, it confused the
+ postfix order construction so that the block that ordinarily sits around the
+ whole loop was never executed. So when the loop tried to unstack between
+ iterations, it got the wrong context, and blew away the lexical variables
+ of the outer scope. Fixed it by introducing a NULL opcode that will be
+ optimized away later.
+
+NETaa13167: coercion was looking at public bits rather than private bits.
+From: Randal L. Schwartz
+Also: Thomas Riechmann
+Also: Shane Castle
+Files patched: sv.c
+ There were some bad ifdefs around the various varieties of set*id(). In
+ addition, tainting was interacting badly with assignment to $> because
+ sv_2iv() was examining SvPOK rather than SvPOKp, and so couldn't coerce
+ a string uid to an integer one.
+
+NETaa13167: had some ifdefs wrong on set*id.
+Files patched: mg.c pp_hot.c
+ (same)
+
+NETaa13168: relaxed test for comparison of new and old fds
+From: Casper H.S. Dik
+Files patched: t/lib/posix.t
+ I relaxed the comparison to just check that the new fd is greater.
+
+NETaa13169: autoincrement can corrupt scalar value state.
+From: Gisle Aas
+Also: Tom Christiansen
+Files patched: sv.c
+ It assumed a PV didn't need to be upgraded to become an NV.
+
+NETaa13169: previous patch could leak a string pointer.
+Files patched: sv.c
+ (same)
+
+NETaa13170: symbols missing from global.sym
+From: Tim Bunce
+Files patched: global.sym
+ Applied suggested patch.
+
+NETaa13171: \\ in <<'END' shouldn't reduce to \.
+From: Randal L. Schwartz
+Files patched: toke.c
+ <<'END' needed to bypass ordinary single-quote processing.
+
+NETaa13172: 'use integer' turned off magical autoincrement.
+From: Erich Rickheit KSC
+Files patched: pp.c pp_hot.c
+ The integer versions of the increment and decrement operators were trying too
+ hard to be efficient.
+
+NETaa13172: deleted duplicate increment and decrement code
+Files patched: opcode.h opcode.pl pp.c
+ (same)
+
+NETaa13173: install should make shared libraries executable.
+From: Brian Grossman
+Also: Dave Nadler
+Also: Eero Pajarre
+Files patched: installperl
+ Now gives permission 555 to any file ending with extension specified by $dlext.
+
+NETaa13176: ck_rvconst didn't free the const it used up.
+From: Nick Duffek
+Files patched: op.c
+ I checked in many random memory leaks under this bug number, since it
+ was an eval that brought many of them out.
+
+NETaa13176: didn't delete XRV for temp ref of destructor.
+Files patched: sv.c
+ (same)
+
+NETaa13176: didn't delete op_pmshort in matching operators.
+Files patched: op.c
+ (same)
+
+NETaa13176: eval leaked the name of the eval.
+Files patched: scope.c
+ (same)
+
+NETaa13176: gp_free didn't free the format.
+Files patched: gv.c
+ (same)
+
+NETaa13176: minor leaks in loop exits and constant subscript optimization.
+Files patched: op.c
+ (same)
+
+NETaa13176: plugged some duplicate struct allocation memory leaks.
+Files patched: perl.c
+ (same)
+
+NETaa13176: sv_clear of an FM didn't clear anything.
+Files patched: sv.c
+ (same)
+
+NETaa13176: tr/// didn't mortalize its return value.
+Files patched: pp.c
+ (same)
+
+NETaa13177: SCOPE optimization hid line number info
+From: David J. MacKenzie
+Also: Hallvard B Furuseth
+Files patched: op.c
+ Every pass on the syntax tree has to keep track of the current statement.
+ Unfortunately, the single-statement block was optimized into a single
+ statement between the time the variable was parsed and the time the
+ void code scan was done, so that pass didn't see the OP_NEXTSTATE
+ operator, because it has been optimized to an OP_NULL.
+
+ Fortunately, null operands remember what they were, so it was pretty easy
+ to make it set the correct line number anyway.
+
+NETaa13178: some linux doesn't handle nm well
+From: Alan Modra
+Files patched: hints/linux.sh
+ Applied supplied patch.
+
+NETaa13180: localized slice now pre-extends array
+From: Larry Schuler
+Files patched: pp.c
+ A localized slice now pre-extends its array to avoid reallocation during
+ the scope of the local.
+
+NETaa13181: m//g didn't keep track of whether previous match matched null.
+From: "philippe.verdret"
+Files patched: mg.h pp_hot.c
+ A pattern isn't allowed to match a null string in the same place twice in
+ a row. m//g wasn't keeping track of whether the previous match matched
+ the null string.
+
+NETaa13182: now includes whitespace as a regexp metacharacter.
+From: Larry Wall
+Files patched: toke.c
+ scan_const() now counts " \t\n\r\f\v" as metacharacters when scanning a pattern.
+
+NETaa13183: sv_setsv shouldn't try to clone an object.
+From: Peter Gordon
+Files patched: sv.c
+ The sv_mortalcopy() done by the return in STORE called sv_setsv(),
+ which cloned the object. sv_setsv() shouldn't be in the business of
+ cloning objects.
+
+NETaa13184: bogus warning on quoted signal handler name removed.
+From: Dan Carson
+Files patched: toke.c
+ Now doesn't complain unless the first non-whitespace character after the =
+ is an alphabetic character.
+
+NETaa13186: now croaks on chop($')
+From: Casper H.S. Dik
+Files patched: doop.c
+ Now croaks on chop($') and such.
+
+NETaa13187: "${foo::bar}" now counts as mere delimitation, not as a bareword.
+From: Jay Rogers
+Files patched: toke.c
+ "${foo::bar}" now counts as mere delimitation, not as a bareword inside a
+ reference block.
+
+NETaa13188: for backward compatibility, looks for "perl -" before "perl".
+From: Russell Mosemann
+Files patched: toke.c
+ Now allows non-whitespace characters on the #! line between the "perl"
+ and the "-".
+
+NETaa13188: now allows non-whitespace after #!...perl before switches.
+Files patched: toke.c
+ (same)
+
+NETaa13189: derivative files need to be removed before recreation
+From: Simon Leinen
+Also: Dick Middleton
+Also: David J. MacKenzie
+Files patched: embed_h.sh x2p/Makefile.SH
+ Fixed various little nits as suggested in several messages.
+
+NETaa13190: certain assignments can spoof pod directive recognizer
+From: Ilya Zakharevich
+Files patched: toke.c
+ The lexer now only recognizes pod directives where a statement is expected.
+
+NETaa13194: now returns undef when there is no curpm.
+From: lusol@Dillon.CC.Lehigh.EDU
+Files patched: mg.c
+ Since there was no regexp prior to the "use", it was returning whatever the
+ last successful match was within the "use", because there was no current
+ regexp, so it treated it as a normal variable. It now returns undef.
+
+NETaa13195: semop had one S too many.
+From: Joachim Huober
+Files patched: opcode.pl
+ The entry in opcode.pl had one too many S's.
+
+NETaa13196: always assumes it's a Perl script if -c is used.
+From: Dan Carson
+Files patched: toke.c
+ It now will assume it's a Perl script if the -c switch is used.
+
+NETaa13197: changed implicit -> message to be more understandable.
+From: Bruce Barnett
+Files patched: op.c pod/perldiag.pod
+ I changed the error message to be more understandable. It now says
+
+ Can't use subscript on sort...
+
+
+NETaa13201: added OPpCONST_ENTERED flag to properly enter filehandle symbols.
+From: E. Jay Berkenbilt
+Also: Tom Christiansen
+Files patched: op.c op.h toke.c
+ The grammatical reduction of a print statement didn't properly count
+ the filehandle as a symbol reference because it couldn't distinguish
+ between a symbol entered earlier in the program and a symbol entered
+ for the first time down in the lexer.
+
+NETaa13203: README shouldn't mention uperl.o any more.
+From: Anno Siegel
+Files patched: README
+
+NETaa13204: .= shouldn't warn on uninitialized target.
+From: Pete Peterson
+Files patched: pp_hot.c
+ No longer warns on uninitialized target of .= operator.
+
+NETaa13206: handy macros in XSUB.h
+From: Tim Bunce
+Files patched: XSUB.h
+ Added suggested macros.
+
+NETaa13228: commonality checker didn't treat lexicals as variables.
+From: mcook@cognex.com
+Files patched: op.c opcode.pl
+ The list assignment operator tries to avoid unnecessary copies by doing the
+ assignment directly if there are no common variables on either side of the
+ equals. Unfortunately, the code that decided that only recognized references
+ to dynamic variables, not lexical variables.
+
+NETaa13229: fixed sign stuff for complement, integer coercion.
+From: Larry Wall
+Files patched: perl.h pp.c sv.c
+ Fixed ~0 and integer coercions.
+
+NETaa13230: no longer tries to reuse scratchpad temps if tainting in effect.
+From: Luca Fini
+Files patched: op.c
+ I haven't reproduced it, but I believe the problem is the reuse of scratchpad
+ temporaries between statements. I've made it not try to reuse them if
+ tainting is in effect.
+
+NETaa13231: *foo = *bar now prevents typo warnings on "foo"
+From: Robin Barker
+Files patched: sv.c
+ Aliasing of the form *foo = *bar is now protected from the typo warnings.
+ Previously only the *foo = \$bar form was.
+
+NETaa13235: require BAREWORD now introduces package name immediately.
+From: Larry Wall
+Files patched: toke.c
+ require BAREWORD now introduces package name immediately. This lets the
+ method intuit code work right even though the require hasn't actually run
+ yet.
+
+NETaa13289: didn't calculate correctly using arybase.
+From: Jared Rhine
+Files patched: pp.c pp_hot.c
+ The runtime code didn't use curcop->cop_arybase correctly.
+
+NETaa13301: store now throws exception on error
+From: Barry Friedman
+Files patched: ext/GDBM_File/GDBM_File.xs ext/NDBM_File/NDBM_File.xs ext/ODBM_File/ODBM_File.xs ext/SDBM_File/SDBM_File.xs
+ Changed warn to croak in ext/*DBM_File/*.xs.
+
+NETaa13302: ctime now takes Time_t rather than Time_t*.
+From: Rodger Anderson
+Files patched: ext/POSIX/POSIX.xs
+ Now declares a Time_t and takes the address of that in CODE.
+
+NETaa13302: shorter way to do this patch
+Files patched: ext/POSIX/POSIX.xs
+ (same)
+
+NETaa13304: could feed too large $@ back into croak, whereupon it croaked.
+From: Larry Wall
+Files patched: perl.c
+ callist() could feed $@ back into croak with more than a bare %s. (croak()
+ handles long strings with a bare %s okay.)
+
+NETaa13305: compiler misoptimized RHS to outside of s/a/print/e
+From: Brian S. Cashman <bsc@umich.edu>
+Files patched: op.c
+ The syntax tree was being misconstructed because the compiler felt that
+ the RHS was invariant, so it did it outside the s///.
+
+NETaa13314: assigning mortal to lexical leaks
+From: Larry Wall
+Files patched: sv.c
+ In stealing strings, sv_setsv was checking SvPOK to see if it should free
+ the destination string. It should have been checking SvPVX.
+
+NETaa13316: wait4pid now recalled when errno == EINTR
+From: Robert J. Pankratz
+Files patched: pp_sys.c util.c
+ system() and the close() of a piped open now recall wait4pid if it returned
+ prematurely with errno == EINTR.
+
+NETaa13329: needed to localize taint magic
+From: Brian Katzung
+Files patched: sv.c doio.c mg.c pp_hot.c pp_sys.c scope.c taint.c
+ Taint magic is now localized better, though I had to resort to a kludge
+ to allow a value to be both tainted and untainted simultaneously during
+ the assignment of
+
+ local $foo = $_[0];
+
+ when $_[0] is a reference to the variable $foo already.
+
+NETaa13341: clarified interaction of AnyDBM_File::ISA and "use"
+From: Ian Phillipps
+Files patched: pod/modpods/AnyDBMFile.pod
+ The doc was misleading.
+
+NETaa13342: grep and map with block would enter block but never leave it.
+From: Ian Phillipps
+Files patched: op.c
+ The compiler use some sort-checking code to handle the arguments of
+ grep and map. Unfortunately, this wiped out the block exit opcode while
+ leaving the block entry opcode. This doesn't matter to sort, but did
+ matter to grep and map. It now leave the block entry intact.
+
+ The reason it worked without the my is because the block entry and exit
+ were optimized away to an OP_SCOPE, which it doesn't matter if it's there
+ or not.
+
+NETaa13343: goto needed to longjmp when in a signal handler.
+From: Robert Partington
+Files patched: pp_ctl.c
+ goto needed to longjmp() when in a signal handler to get back into the
+ right run() context.
+
+
+NETaa13344: strict vars shouldn't apply to globs or filehandles.
+From: Andrew Wilcox
+Files patched: gv.c
+ Filehandles and globs will be excepted from "strict vars", so that you can
+ do the standard Perl 4 trick of
+
+ use strict;
+ sub foo {
+ local(*IN);
+ open(IN,"file");
+ }
+
+
+NETaa13345: assert.pl didn't use package DB
+From: Hans Mulder
+Files patched: lib/assert.pl
+ Now it does.
+
+NETaa13348: av_undef didn't free scalar representing $#foo.
+From: David Filo
+Files patched: av.c
+ av_undef didn't free scalar representing $#foo.
+
+NETaa13349: sort sub accumulated save stack entries
+From: David Filo
+Files patched: pp_ctl.c
+ COMMON only gets set if assigning to @_, which is reasonable. Most of the
+ problem was a memory leak.
+
+NETaa13351: didn't treat indirect filehandles as references.
+From: Andy Dougherty
+Files patched: op.c
+ Now produces
+
+ Can't use an undefined value as a symbol reference at ./foo line 3.
+
+
+NETaa13352: OP_SCOPE allocated as UNOP rather than LISTOP.
+From: Andy Dougherty
+Files patched: op.c
+
+NETaa13353: scope() didn't release filegv on OP_SCOPE optimization.
+From: Larry Wall
+Files patched: op.c
+ When scope() nulled out a NEXTSTATE, it didn't release its filegv reference.
+
+NETaa13355: hv_delete now avoids useless mortalcopy
+From: Larry Wall
+Files patched: hv.c op.c pp.c pp_ctl.c proto.h scope.c util.c
+ hv_delete now avoids useless mortalcopy.
+
+
+NETaa13359: comma operator section missing its heading
+From: Larry Wall
+Files patched: pod/perlop.pod
+
+NETaa13359: random typo
+Files patched: pod/perldiag.pod
+
+NETaa13360: code to handle partial vec values was bogus.
+From: Conrad Augustin
+Files patched: pp.c
+ The code that Mark J. added a long time ago to handle values that were partially
+ off the end of the string was incorrect.
+
+NETaa13361: made it not interpolate inside regexp comments
+From: Martin Jost
+Files patched: toke.c
+ To avoid surprising people, it no longer interpolates inside regexp
+ comments.
+
+NETaa13362: ${q[1]} should be interpreted like it used to
+From: Hans Mulder
+Files patched: toke.c
+ Now resolves ${keyword[1]} to $keyword[1] and warns if -w. Likewise for {}.
+
+NETaa13363: meaning of repeated search chars undocumented in tr///
+From: Stephen P. Potter
+Files patched: pod/perlop.pod
+ Documented that repeated characters use the first translation given.
+
+NETaa13365: if closedir fails, don't try it again.
+From: Frank Crawford
+Files patched: pp_sys.c
+ Now does not attempt to closedir a second time.
+
+NETaa13366: can't do block scope optimization on $1 et al when tainting.
+From: Andrew Vignaux
+Files patched: toke.c
+ The tainting mechanism assumes that every statement starts out
+ untainted. Unfortunately, the scope removal optimization for very
+ short blocks removed the statementhood of statements that were
+ attempting to read $1 as an untainted value, with the effect that $1
+ appeared to be tainted anyway. The optimization is now disabled when
+ tainting and the block contains $1 (or equivalent).
+
+NETaa13366: fixed this a better way in toke.c.
+Files patched: op.c
+ (same)
+
+NETaa13366: need to disable scope optimization when tainting.
+Files patched: op.c
+ (same)
+
+NETaa13367: Did a SvCUR_set without nulling out final char.
+From: "Rob Henderson" <robh@cs.indiana.edu>
+Files patched: doop.c pp.c pp_sys.c
+ When do_vop set the length on its result string it neglected to null-terminate
+ it.
+
+NETaa13368: bigrat::norm sometimes chucked sign
+From: Greg Kuperberg
+Files patched: lib/bigrat.pl
+ The normalization routine was assuming that the gcd of two numbers was
+ never negative, and based on that assumption managed to move the sign
+ to the denominator, where it was deleted on the assumption that the
+ denominator is always positive.
+
+NETaa13368: botched previous patch
+Files patched: lib/bigrat.pl
+ (same)
+
+NETaa13369: # is now a comment character, and \# should be left for regcomp.
+From: Simon Parsons
+Files patched: toke.c
+ It was not skipping the comment when it skipped the white space, and constructed
+ an opcode that tried to match a null string. Unfortunately, the previous
+ star tried to use the first character of the null string to optimize where
+ to recurse, so it never matched.
+
+NETaa13369: comment after regexp quantifier induced non-match.
+Files patched: regcomp.c
+ (same)
+
+NETaa13370: some code assumed SvCUR was of type int.
+From: Spider Boardman
+Files patched: pp_sys.c
+ Did something similar to the proposed patch. I also fixed the problem that
+ it assumed the type of SvCUR was int. And fixed get{peer,sock}name the
+ same way.
+
+NETaa13375: sometimes dontbother wasn't added back into strend.
+From: Jamshid Afshar
+Files patched: regexec.c
+ When the /g modifier was used, the regular expression code would calculate
+ the end of $' too short by the minimum number of characters the pattern could
+ match.
+
+NETaa13375: sv_setpvn now disallows negative length.
+Files patched: sv.c
+ (same)
+
+NETaa13376: suspected indirect objecthood prevented recognition of lexical.
+From: Gisle.Aas@nr.no
+Files patched: toke.c
+ When $data[0] is used in a spot that might be an indirect object, the lexer
+ was getting confused over the rule that says the $data in $$data[0] isn't
+ an array element. (The lexer uses XREF state for both indirect objects
+ and for variables used as names.)
+
+NETaa13377: -I processesing ate remainder of #! line.
+From: Darrell Schiebel
+Files patched: perl.c
+ I made the -I processing in moreswitches look for the end of the string,
+ delimited by whitespace.
+
+NETaa13379: ${foo} now treated the same outside quotes as inside
+From: Hans Mulder
+Files patched: toke.c
+ ${bareword} is now treated the same outside quotes as inside.
+
+NETaa13379: previous fix for this bug was botched
+Files patched: toke.c
+ (same)
+
+NETaa13381: TEST should check for perl link
+From: Andy Dougherty
+Files patched: t/TEST
+ die "You need to run \"make test\" first to set things up.\n" unless -e 'perl';
+
+
+NETaa13384: fixed version 0.000 botch.
+From: Larry Wall
+Files patched: installperl
+
+NETaa13385: return 0 from required file loses message
+From: Malcolm Beattie
+Files patched: pp_ctl.c
+ Works right now.
+
+NETaa13387: added pod2latex
+From: Taro KAWAGISHI
+Files patched: MANIFEST pod/pod2latex
+ Added most recent copy to pod directory.
+
+NETaa13388: constant folding now prefers integer results over double
+From: Ilya Zakharevich
+Files patched: op.c
+ Constant folding now prefers integer results over double.
+
+NETaa13389: now treats . and exec as shell metathingies
+From: Hans Mulder
+Files patched: doio.c
+ Now treats . and exec as shell metathingies.
+
+NETaa13395: eval didn't check taintedness.
+From: Larry Wall
+Files patched: pp_ctl.c
+
+NETaa13396: $^ coredumps at end of string
+From: Paul Rogers
+Files patched: toke.c
+ The scan_ident() didn't check for a null following $^.
+
+NETaa13397: improved error messages when operator expected
+From: Larry Wall
+Files patched: toke.c
+ Added message (Do you need to predeclare BAR?). Also fixed the missing
+ semicolon message.
+
+NETaa13399: cleanup by Andy
+From: Larry Wall
+Files patched: Changes Configure Makefile.SH README cflags.SH config.H config_h.SH deb.c doop.c dump.c ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs ext/DynaLoader/DynaLoader.pm ext/Fcntl/Fcntl.pm ext/GDBM_File/GDBM_File.pm ext/POSIX/POSIX.pm ext/SDBM_File/sdbm/sdbm.h ext/Socket/Socket.pm ext/util/make_ext h2xs.SH hints/aix.sh hints/bsd386.sh hints/dec_osf.sh hints/esix4.sh hints/freebsd.sh hints/irix_5.sh hints/next_3_2.sh hints/sunos_4_1.sh hints/svr4.sh hints/ultrix_4.sh installperl lib/AutoSplit.pm lib/Cwd.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/xsubpp lib/Term/Cap.pm mg.c miniperlmain.c perl.c perl.h perl_exp.SH pod/Makefile pod/perldiag.pod pod/pod2html pp.c pp_ctl.c pp_hot.c pp_sys.c proto.h sv.h t/re_tests util.c x2p/Makefile.SH x2p/a2p.h x2p/a2py.c x2p/handy.h x2p/hash.c x2p/hash.h x2p/str.c x2p/str.h x2p/util.c x2p/util.h x2p/walk.c
+
+NETaa13399: cleanup from Andy
+Files patched: MANIFEST
+
+NETaa13399: configuration cleanup
+Files patched: Configure Configure MANIFEST MANIFEST Makefile.SH Makefile.SH README config.H config.H config_h.SH config_h.SH configpm ext/DynaLoader/DynaLoader.pm ext/DynaLoader/dl_hpux.xs ext/NDBM_File/Makefile.PL ext/ODBM_File/Makefile.PL ext/util/make_ext handy.h hints/aix.sh hints/hpux_9.sh hints/hpux_9.sh hints/irix_4.sh hints/linux.sh hints/mpeix.sh hints/next_3_2.sh hints/solaris_2.sh hints/svr4.sh installperl installperl lib/AutoSplit.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/xsubpp lib/Getopt/Long.pm lib/Text/Tabs.pm makedepend.SH makedepend.SH mg.c op.c perl.h perl_exp.SH pod/perl.pod pod/perldiag.pod pod/perlsyn.pod pod/pod2man pp_sys.c proto.h proto.h unixish.h util.c util.c vms/config.vms writemain.SH x2p/a2p.h x2p/a2p.h x2p/a2py.c x2p/a2py.c x2p/handy.h x2p/util.c x2p/walk.c x2p/walk.c
+
+NETaa13399: new files from Andy
+Files patched: ext/DB_File/Makefile.PL ext/DynaLoader/Makefile.PL ext/Fcntl/Makefile.PL ext/GDBM_File/Makefile.PL ext/NDBM_File/Makefile.PL ext/ODBM_File/Makefile.PL ext/POSIX/Makefile.PL ext/SDBM_File/Makefile.PL ext/SDBM_File/sdbm/Makefile.PL ext/Socket/Makefile.PL globals.c hints/convexos.sh hints/irix_6.sh
+
+NETaa13399: patch0l from Andy
+Files patched: Configure MANIFEST Makefile.SH config.H config_h.SH ext/DB_File/Makefile.PL ext/GDBM_File/Makefile.PL ext/NDBM_File/Makefile.PL ext/POSIX/POSIX.xs ext/SDBM_File/sdbm/Makefile.PL ext/util/make_ext h2xs.SH hints/next_3_2.sh hints/solaris_2.sh hints/unicos.sh installperl lib/Cwd.pm lib/ExtUtils/MakeMaker.pm makeaperl.SH vms/config.vms x2p/util.c x2p/util.h
+
+NETaa13399: stuff from Andy
+Files patched: Configure MANIFEST Makefile.SH configpm hints/dec_osf.sh hints/linux.sh hints/machten.sh lib/ExtUtils/MakeMaker.pm util.c
+
+NETaa13399: Patch 0k from Andy
+Files patched: Configure MANIFEST Makefile.SH config.H config_h.SH hints/dec_osf.sh hints/mpeix.sh hints/next_3_0.sh hints/ultrix_4.sh installperl lib/ExtUtils/MakeMaker.pm lib/File/Path.pm makeaperl.SH minimod.PL perl.c proto.h vms/config.vms vms/ext/MM_VMS.pm x2p/a2p.h
+
+NETaa13399: Patch 0m from Andy
+Files patched: Configure MANIFEST Makefile.SH README config.H config_h.SH ext/DynaLoader/README ext/POSIX/POSIX.xs ext/SDBM_File/sdbm/sdbm.h ext/util/extliblist hints/cxux.sh hints/linux.sh hints/powerunix.sh lib/ExtUtils/MakeMaker.pm malloc.c perl.h pp_sys.c util.c
+
+NETaa13400: pod2html update from Bill Middleton
+From: Larry Wall
+Files patched: pod/pod2html
+
+NETaa13401: Boyer-Moore code attempts to compile string longer than 255.
+From: Kyriakos Georgiou
+Files patched: util.c
+ The Boyer-Moore table uses unsigned char offsets, but the BM compiler wasn't
+ rejecting strings longer than 255 chars, and was miscompiling them.
+
+NETaa13403: missing a $ on variable name
+From: Wayne Scott
+Files patched: installperl
+ Yup, it was missing.
+
+NETaa13406: didn't wipe out dead match when proceeding to next BRANCH
+From: Michael P. Clemens
+Files patched: regexec.c
+ The code to check alternatives didn't invalidate backreferences matched by the
+ failed branch.
+
+NETaa13407: overload upgrade
+From: owner-perl5-porters@nicoh.com
+Also: Ilya Zakharevich
+Files patched: MANIFEST gv.c lib/Math/BigInt.pm perl.h pod/perlovl.pod pp.c pp.h pp_hot.c sv.c t/lib/bigintpm.t t/op/overload.t
+ Applied supplied patch, and fixed bug induced by use of sv_setsv to do
+ a deep copy, since sv_setsv no longer copies objecthood.
+
+NETaa13409: sv_gets tries to grow string at EOF
+From: Harold O Morris
+Files patched: sv.c
+ Applied suggested patch, only two statements earlier, since the end code
+ also does SvCUR_set.
+
+NETaa13410: delaymagic did =~ instead of &= ~
+From: Andreas Schwab
+Files patched: pp_hot.c
+ Applied supplied patch.
+
+NETaa13411: POSIX didn't compile under -DLEAKTEST
+From: Frederic Chauveau
+Files patched: ext/POSIX/POSIX.xs
+ Used NEWSV instead of newSV.
+
+NETaa13412: new version from Tony Sanders
+From: Tony Sanders
+Files patched: lib/Term/Cap.pm
+ Installed as Term::Cap.pm
+
+NETaa13413: regmust extractor needed to restart loop on BRANCH for (?:) to work
+From: DESARMENIEN
+Files patched: regcomp.c
+ The BRANCH skipper should have restarted the loop from the top.
+
+NETaa13414: the check for accidental list context was done after pm_short check
+From: Michael H. Coen
+Files patched: pp_hot.c
+ Moved check for accidental list context to before the pm_short optimization.
+
+NETaa13418: perlre.pod babbled nonsense about | in character classes
+From: Philip Hazel
+Files patched: pod/perlre.pod
+ Removed bogus brackets. Now reads:
+ Note however that "|" is interpreted as a literal with square brackets,
+ so if you write C<[fee|fie|foe]> you're really only matching C<[feio|]>.
+
+NETaa13419: need to document introduction of lexical variables
+From: "Heading, Anthony"
+Files patched: pod/perlfunc.pod
+ Now mentions that lexicals aren't introduced till after the current statement.
+
+NETaa13420: formats that overflowed a page caused endless top of forms
+From: Hildo@CONSUL.NL
+Files patched: pp_sys.c
+ If a record is too large to fit on a page, it now prints whatever will
+ fit and then calls top of form again on the remainder.
+
+NETaa13423: the code to do negative list subscript in scalar context was missing
+From: Steve McDougall
+Files patched: pp.c
+ The negative subscript code worked right in list context but not in scalar
+ context. In fact, there wasn't code to do it in the scalar context.
+
+NETaa13424: existing but undefined CV blocked inheritance
+From: Spider Boardman
+Files patched: gv.c
+ Applied supplied patch.
+
+NETaa13425: removed extra argument to croak
+From: "R. Bernstein"
+Files patched: regcomp.c
+ Removed extra argument.
+
+NETaa13427: added return types
+From: "R. Bernstein"
+Files patched: x2p/a2py.c
+ Applied suggested patch.
+
+NETaa13427: added static declarations
+Files patched: x2p/walk.c
+ (same)
+
+NETaa13428: split was assuming that all backreferences were defined
+From: Dave Schweisguth
+Files patched: pp.c
+ split was assuming that all backreferences were defined.
+
+NETaa13430: hoistmust wasn't hoisting anchored shortcircuit's length
+From: Tom Christiansen
+Also: Rob Hooft
+Files patched: toke.c
+
+NETaa13432: couldn't call code ref under debugger
+From: Mike Fletcher
+Files patched: op.c pp_hot.c sv.h
+ The debugging code assumed it could remember a name to represent a subroutine,
+ but anonymous subroutines don't have a name. It now remembers a CV reference
+ in that case.
+
+NETaa13435: 1' dumped core
+From: Larry Wall
+Files patched: toke.c
+ Didn't check a pointer for nullness.
+
+NETaa13436: print foo(123) didn't treat foo as subroutine
+From: mcook@cognex.com
+Files patched: toke.c
+ Now treats it as a subroutine rather than a filehandle.
+
+NETaa13437: &$::foo didn't think $::foo was a variable name
+From: mcook@cognex.com
+Files patched: toke.c
+ Now treats $::foo as a global variable.
+
+NETaa13439: referred to old package name
+From: Tom Christiansen
+Files patched: lib/Sys/Syslog.pm
+ Wasn't a strict refs problem after all. It was simply referring to package
+ syslog, which had been renamed to Sys::Syslog.
+
+NETaa13440: stat operations didn't know what to do with glob or ref to glob
+From: mcook@cognex.com
+Files patched: doio.c pp_sys.c
+ Now knows about the kinds of filehandles returned by FileHandle constructors
+ and such.
+
+NETaa13442: couldn't find name of copy of deleted symbol table entry
+From: Spider Boardman
+Files patched: gv.c gv.h
+ I did a much simpler fix. When gp_free notices that it's freeing the
+ master GV, it nulls out gp_egv. The GvENAME and GvESTASH macros know
+ to revert to gv if egv is null.
+
+ This has the advantage of not creating a reference loop.
+
+NETaa13443: couldn't override an XSUB
+From: William Setzer
+Files patched: op.c
+ When the newSUB and newXS routines checked for whether the old sub was
+ defined, they only looked at CvROOT(cv), not CvXSUB(cv).
+
+NETaa13443: needed to do same thing in newXS
+Files patched: op.c
+ (same)
+
+NETaa13444: -foo now doesn't warn unless sub foo is defined
+From: Larry Wall
+Files patched: toke.c
+ Made it not warn on -foo, unless there is a sub foo defined.
+
+NETaa13451: in scalar context, pp_entersub now guarantees one item from XSUB
+From: Nick Gianniotis
+Files patched: pp_hot.c
+ The pp_entersub routine now guarantees that an XSUB in scalar context
+ returns one and only one value. If there are fewer, it pushes undef,
+ and if there are more, it returns the last one.
+
+NETaa13457: now explicitly disallows printf format with 'n' or '*'.
+From: lees@cps.msu.edu
+Files patched: doop.c
+ Now says
+
+ Use of n in printf format not supported at ./foo line 3.
+
+
+NETaa13458: needed to call SvPOK_only() in pp_substr
+From: Wayne Scott
+Files patched: pp.c
+ Needed to call SvPOK_only() in pp_substr.
+
+NETaa13459: umask and chmod now warn about missing initial 0 even with paren
+From: Andreas Koenig
+Files patched: toke.c
+ Now skips parens as well as whitespace looking for argument.
+
+NETaa13460: backtracking didn't work on .*? because reginput got clobbered
+From: Andreas Koenig
+Files patched: regexec.c
+ When .*? did a probe of the rest of the string, it clobbered reginput,
+ so the next call to match a . tried to match the newline and failed.
+
+NETaa13475: \(@ary) now treats array as list of scalars
+From: Tim Bunce
+Files patched: op.c
+ The mod() routine now refrains from marking @ary as an lvalue if it's in parens
+ and is the subject of an OP_REFGEN.
+
+NETaa13481: accept buffer wasn't aligned good enough
+From: Holger Bechtold
+Also: Christian Murphy
+Files patched: pp_sys.c
+ Applied suggested patch.
+
+NETaa13486: while (<>) now means while (defined($_ = <>))
+From: Jim Balter
+Files patched: op.c pod/perlop.pod
+ while (<HANDLE>) now means while (defined($_ = <HANDLE>)).
+
+NETaa13500: needed DESTROY in FileHandle
+From: Tim Bunce
+Files patched: ext/POSIX/POSIX.pm
+ Added DESTROY method. Also fixed ungensym to use POSIX:: instead of _POSIX.
+ Removed ungensym from close method, since DESTROY should do that now.
+
+NETaa13502: now complains if you use local on a lexical variable
+From: Larry Wall
+Files patched: op.c
+ Now says something like
+
+ Can't localize lexical variable $var at ./try line 6.
+
+NETaa13512: added $SIG{__WARN__} and $SIG{__DIE__} hooks
+From: Larry Wall
+Files patched: embed.h gv.c interp.sym mg.c perl.h pod/perlvar.pod pp_ctl.c util.c Todo pod/perldiag.pod
+
+NETaa13514: statements before intro of lex var could see lex var
+From: William Setzer
+Files patched: op.c
+ When a lexical variable is declared, introduction is delayed until
+ the start of the next statement, so that any initialization code runs
+ outside the scope of the new variable. Thus,
+
+ my $y = 3;
+ my $y = $y;
+ print $y;
+
+ should print 3. Unfortunately, the declaration was marked with the
+ beginning location at the time that "my $y" was processed instead of
+ when the variable was introduced, so any embedded statements within
+ an anonymous subroutine picked up the wrong "my". The declaration
+ is now labelled correctly when the variable is actually introduced.
+
+NETaa13520: added closures
+From: Larry Wall
+Files patched: Todo cv.h embed.h global.sym gv.c interp.sym op.c perl.c perl.h pod/perlform.pod pp.c pp_ctl.c pp_hot.c sv.c sv.h toke.c
+
+NETaa13520: test to see if lexical works in a format now
+Files patched: t/op/write.t
+
+NETaa13522: substitution couldn't be used on a substr()
+From: Hans Mulder
+Files patched: pp_ctl.c pp_hot.c
+ Changed pp_subst not to use sv_replace() anymore, which didn't handle lvalues
+ and was overkill anyway. Should be slightly faster this way too.
+
+NETaa13525: G_EVAL mode in perl_call_sv didn't return values right.
+Files patched: perl.c
+
+NETaa13525: consolidated error message
+From: Larry Wall
+Files patched: perl.h toke.c
+
+NETaa13525: derived it
+Files patched: perly.h
+
+NETaa13525: missing some values from embed.h
+Files patched: embed.h
+
+NETaa13525: random cleanup
+Files patched: MANIFEST Todo cop.h lib/TieHash.pm lib/perl5db.pl opcode.h patchlevel.h pod/perldata.pod pod/perlsub.pod t/op/ref.t toke.c
+
+NETaa13525: random cleanup
+Files patched: pp_ctl.c util.c
+
+NETaa13527: File::Find needed to export $name and $dir
+From: Chaim Frenkel
+Files patched: lib/File/Find.pm
+ They are now exported.
+
+NETaa13528: cv_undef left unaccounted-for GV pointer in CV
+From: Tye McQueen
+Also: Spider Boardman
+Files patched: op.c
+
+NETaa13530: scalar keys now resets hash iterator
+From: Tim Bunce
+Files patched: doop.c
+ scalar keys() now resets the hash iterator.
+
+NETaa13531: h2ph doesn't check defined right
+From: Casper H.S. Dik
+Files patched: h2ph.SH
+
+NETaa13540: VMS update
+From: Larry Wall
+Files patched: MANIFEST README.vms doio.c embed.h ext/DynaLoader/dl_vms.xs interp.sym lib/Cwd.pm lib/ExtUtils/xsubpp lib/File/Basename.pm lib/File/Find.pm lib/File/Path.pm mg.c miniperlmain.c perl.c perl.h perly.c perly.c.diff pod/perldiag.pod pp_ctl.c pp_hot.c pp_sys.c proto.h util.c vms/Makefile vms/config.vms vms/descrip.mms vms/ext/Filespec.pm vms/ext/MM_VMS.pm vms/ext/VMS/stdio/Makefile.PL vms/ext/VMS/stdio/stdio.pm vms/ext/VMS/stdio/stdio.xs vms/genconfig.pl vms/perlvms.pod vms/sockadapt.c vms/sockadapt.h vms/vms.c vms/vmsish.h vms/writemain.pl
+
+NETaa13540: got some duplicate code
+Files patched: lib/File/Path.pm
+
+NETaa13540: stuff from Charles
+Files patched: MANIFEST README.vms lib/ExtUtils/MakeMaker.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/xsubpp lib/File/Basename.pm lib/File/Path.pm perl.c perl.h pod/perldiag.pod pod/perldiag.pod vms/Makefile vms/Makefile vms/config.vms vms/config.vms vms/descrip.mms vms/descrip.mms vms/ext/Filespec.pm vms/ext/Filespec.pm vms/ext/MM_VMS.pm vms/ext/MM_VMS.pm vms/ext/VMS/stdio/stdio.pm vms/ext/VMS/stdio/stdio.xs vms/gen_shrfls.pl vms/gen_shrfls.pl vms/genconfig.pl vms/genconfig.pl vms/mms2make.pl vms/perlvms.pod vms/sockadapt.h vms/test.com vms/vms.c vms/vms.c vms/vmsish.h vms/vmsish.h vms/writemain.pl
+
+NETaa13540: tweak from Charles
+Files patched: lib/File/Path.pm
+
+NETaa13552: scalar unpack("P4",...) ignored the 4
+From: Eric Arnold
+Files patched: pp.c
+ The optimization that tried to do only one item in a scalar context didn't
+ realize that the argument to P was not a repeat count.
+
+NETaa13553: now warns about 8 or 9 in octal escapes
+From: Mike Rogers
+Files patched: util.c
+ Now warns if it finds 8 or 9 before the end of the octal escape sequence.
+ So \039 produces a warning, but \0339 does not.
+
+NETaa13554: now allows foreach ${"name"}
+From: Johan Holtman
+Files patched: op.c
+ Instead of trying to remove OP_RV2SV, the compiler now just transmutes it into an
+ OP_RV2GV, which is a no-op for ordinary variables and does the right
+ thing for ${"name"}.
+
+NETaa13559: substitution now always checks for readonly
+From: Rodger Anderson
+Files patched: pp_hot.c
+ Substitution now always checks for readonly.
+
+NETaa13561: added explanations of closures and curly-quotes
+From: Larry Wall
+Files patched: pod/perlref.pod
+
+NETaa13562: null components in path cause indigestion
+From: Ambrose Kofi Laing
+Files patched: lib/Cwd.pm lib/pwd.pl
+
+NETaa13575: documented semantics of negative substr length
+From: Jeff Bouis
+Files patched: pod/perlfunc.pod
+ Documented the fact that negative length now leaves characters off the end,
+ and while I was at it, made it work right even if offset wasn't 0.
+
+NETaa13575: negative length to substr didn't work when offset non-zero
+Files patched: pp.c
+ (same)
+
+NETaa13575: random cleanup
+Files patched: pod/perlfunc.pod
+ (same)
+
+NETaa13580: couldn't localize $ACCUMULATOR
+From: Larry Wall
+Files patched: gv.c lib/English.pm mg.c perl.c sv.c
+ Needed to make $^A a real magical variable. Also lib/English.pm wasn't
+ exporting good.
+
+NETaa13583: doc mods from Tom
+From: Larry Wall
+Files patched: pod/modpods/AnyDBMFile.pod pod/modpods/Basename.pod pod/modpods/Benchmark.pod pod/modpods/Cwd.pod pod/modpods/Dynaloader.pod pod/modpods/Exporter.pod pod/modpods/Find.pod pod/modpods/Finddepth.pod pod/modpods/Getopt.pod pod/modpods/MakeMaker.pod pod/modpods/Open2.pod pod/modpods/POSIX.pod pod/modpods/Ping.pod pod/modpods/less.pod pod/modpods/strict.pod pod/perlapi.pod pod/perlbook.pod pod/perldata.pod pod/perlform.pod pod/perlfunc.pod pod/perlipc.pod pod/perlmod.pod pod/perlobj.pod pod/perlref.pod pod/perlrun.pod pod/perlsec.pod pod/perlsub.pod pod/perltrap.pod pod/perlvar.pod
+
+NETaa13589: return was enforcing list context on its arguments
+From: Tim Freeman
+Files patched: opcode.pl
+ A return was being treated like a normal list operator, in that it was
+ setting list context on its arguments. This was bogus.
+
+NETaa13591: POSIX::creat used wrong argument
+From: Paul Marquess
+Files patched: ext/POSIX/POSIX.pm
+ Applied suggested patch.
+
+NETaa13605: use strict refs error message now displays bad ref
+From: Peter Gordon
+Files patched: perl.h pod/perldiag.pod pp.c pp_hot.c
+ Now says
+
+ Can't use string ("2") as a HASH ref while "strict refs" in use at ./foo line 12.
+
+NETaa13630: eof docs were unclear
+From: Hallvard B Furuseth
+Files patched: pod/perlfunc.pod
+ Applied suggested patch.
+
+NETaa13636: $< and $> weren't refetched on undump restart
+From: Steve Pearlmutter
+Files patched: perl.c
+ The code in main() bypassed perl_construct on an undump restart, which bypassed
+ the code that set $< and $>.
+
+NETaa13641: added Tim's fancy new import whizbangers
+From: Tim Bunce
+Files patched: lib/Exporter.pm
+ Applied suggested patch.
+
+NETaa13649: couldn't AUTOLOAD a symbol reference
+From: Larry Wall
+Files patched: pp_hot.c
+ pp_entersub needed to guarantee a CV so it would get to the AUTOLOAD code.
+
+NETaa13651: renamed file had wrong package name
+From: Andreas Koenig
+Files patched: lib/File/Path.pm
+ Applied suggested patch.
+
+NETaa13660: now that we're testing distribution we can diagnose RANDBITS errors
+From: Karl Glazebrook
+Files patched: t/op/rand.t
+ Changed to suggested algorithm. Also duplicated it to test rand(100) too.
+
+NETaa13660: rand.t didn't test for proper distribution within range
+Files patched: t/op/rand.t
+ (same)
+
+NETaa13671: array slice misbehaved in a scalar context
+From: Tye McQueen
+Files patched: pp.c
+ A spurious else prevented the scalar-context-handling code from running.
+
+NETaa13672: filehandle constructors in POSIX don't return failure successfully
+From: Ian Phillipps
+Files patched: ext/POSIX/POSIX.pm
+ Applied suggested patch.
+
+
+NETaa13678: forced $1 to always be untainted
+From: Ka-Ping Yee
+Files patched: mg.c
+ I believe the bug that triggered this was fixed elsewhere, but just in case,
+ I put in explicit code to force $1 et al not to be tainted regardless.
+
+NETaa13682: formline doc need to discuss ~ and ~~ policy
+From: Peter Gordon
+Files patched: pod/perlfunc.pod
+
+NETaa13686: POSIX::open and POSIX::mkfifo didn't check tainting
+From: Larry Wall
+Files patched: ext/POSIX/POSIX.xs
+ open() and mkfifo() now check tainting.
+
+NETaa13687: new Exporter.pm
+From: Tim Bunce
+Files patched: lib/Exporter.pm
+ Added suggested changes, except for @EXPORTABLE, because it looks too much
+ like @EXPORTTABLE. Decided to stick with @EXPORT_OK because it looks more
+ like an adjunct. Also added an export_tags routine. The keys in the
+ %EXPORT_TAGS hash no longer use colons, to make the initializers prettier.
+
+NETaa13687: new Exporter.pm
+Files patched: ext/POSIX/POSIX.pm
+ (same)
+
+NETaa13694: add sockaddr_in to Socket.pm
+From: Tim Bunce
+Files patched: ext/Socket/Socket.pm
+ Applied suggested patch.
+
+NETaa13695: library routines should use qw() as good example
+From: Dean Roehrich
+Files patched: ext/DB_File/DB_File.pm ext/DynaLoader/DynaLoader.pm ext/Fcntl/Fcntl.pm ext/GDBM_File/GDBM_File.pm ext/POSIX/POSIX.pm ext/Socket/Socket.pm
+ Applied suggested patch.
+
+NETaa13696: myconfig should be a routine in Config.pm
+From: Kenneth Albanowski
+Files patched: configpm
+ Applied suggested patch.
+
+NETaa13704: fdopen closed fd on failure
+From: Hallvard B Furuseth
+Files patched: doio.c
+ Applied suggested patch.
+
+NETaa13706: Term::Cap doesn't work
+From: Dean Roehrich
+Files patched: lib/Term/Cap.pm
+ Applied suggested patch.
+
+NETaa13710: cryptswitch needed to be more "useable"
+From: Tim Bunce
+Files patched: embed.h global.sym perl.h toke.c
+ The cryptswitch_fp function now can operate in two modes. It can
+ modify the global rsfp to redirect input as before, or it can modify
+ linestr and return true, indicating that it is not necessary for yylex
+ to read another line since cryptswitch_fp has just done it.
+
+NETaa13712: new_tmpfile() can't be called as constructor
+From: Hans Mulder
+Files patched: ext/POSIX/POSIX.xs
+ Now allows new_tmpfile() to be called as a constructor.
+
+NETaa13714: variable method call not documented
+From: "Randal L. Schwartz"
+Files patched: pod/perlobj.pod
+ Now indicates that OBJECT->$method() works.
+
+NETaa13715: PACK->$method produces spurious warning
+From: Larry Wall
+Files patched: toke.c
+ The -> operator was telling the lexer to expect an operator when the
+ next thing was a variable.
+
+NETaa13716: Carp now allows multiple packages to be skipped out of
+From: Larry Wall
+Files patched: lib/Carp.pm
+ The subroutine redefinition warnings now warn on import collisions.
+
+NETaa13716: Exporter catches warnings and gives a better line number
+Files patched: lib/Exporter.pm
+ (same)
+
+NETaa13716: now counts imported routines as "defined" for redef warnings
+Files patched: op.c sv.c
+ (same)
+
+-------------
+Version 5.000
+-------------
+
New things
----------
The -w switch is much more informative.
handy.h Handy definitions
hints/3b1.sh Hints for named architecture
hints/3b1cc Hints for named architecture
-hints/PowerUNIX.sh Hints for named architecture
hints/README.hints Notes about hints.
hints/aix.sh Hints for named architecture
hints/altos486.sh Hints for named architecture
hints/next_3_0.sh Hints for named architecture
hints/next_3_2.sh Hints for named architecture
hints/opus.sh Hints for named architecture
+hints/powerunix.sh Hints for named architecture
hints/sco_2_3_0.sh Hints for named architecture
hints/sco_2_3_1.sh Hints for named architecture
hints/sco_2_3_2.sh Hints for named architecture
lib/Text/Soundex.pm Perl module to implement Soundex
lib/Text/Tabs.pm Do expand and unexpand
lib/TieHash.pm Base class for tied hashes
+lib/SubstrHash.pm Compact hash for known key, value and table size
lib/Time/Local.pm Reverse translation of localtime, gmtime
lib/abbrev.pl An abbreviation table builder
lib/assert.pl assertion and panic with stack trace
pod/perltrap.pod Trap info
pod/perlvar.pod Variable info
pod/pod2html Translator to turn pod into HTML
+pod/pod2latex Translator to turn pod into LaTeX
pod/pod2man Translator to turn pod into manpage
pod/splitman Splits perlfunc into multiple man pages
pp.c Push/Pop code
t/io/tell.t See if file seeking works
t/lib/anydbm.t See if AnyDBM_File works
t/lib/bigint.t See if bigint.pl works
+t/lib/bigintpm.t See if BigInt.pm works
t/lib/db-btree.t See if DB_File works
t/lib/db-hash.t See if DB_File works
t/lib/db-recno.t See if DB_File works
t/op/my.t See if lexical scoping works
t/op/oct.t See if oct and hex work
t/op/ord.t See if ord works
+t/op/overload.t See if operator overload works
t/op/pack.t See if pack and unpack work
t/op/pat.t See if esoteric patterns work
t/op/push.t See if push and pop work
unixish.h Defines that are assumed on Unix
util.c Utility routines
util.h Public declarations for the above
+vms/Makefile VMS port
vms/config.vms VMS port
vms/descrip.mms VMS port
-vms/ext/MM_VMS.pm VMS port
+vms/ext/Filespec.pm VMS-Unix file syntax interconversion
+vms/ext/MM_VMS.pm VMS-specific methods for MakeMaker
+vms/ext/VMS/stdio/Makefile.PL MakeMaker driver for VMS::stdio
+vms/ext/VMS/stdio/stdio.pm VMS options to stdio routines
+vms/ext/VMS/stdio/stdio.xs VMS options to stdio routines
vms/gen_shrfls.pl VMS port
vms/genconfig.pl VMS port
vms/genopt.com VMS port
-vms/makefile. VMS port
vms/mms2make.pl VMS port
vms/perlshr.c VMS port
vms/perlvms.pod VMS port
x2p/EXTERN.h Same as above
x2p/INTERN.h Same as above
x2p/Makefile.SH Precursor to Makefile
-x2p/a2p.c A byacc'ed a2p.y
+x2p/a2p.c Output of a2p.y run through byacc
x2p/a2p.h Global declarations
x2p/a2p.man Manual page for awk to perl translator
x2p/a2p.y A yacc grammer for awk
+++ /dev/null
-Artistic The "Artistic License"
-Changes Differences between Perl 4 and Perl 5
-Configure Portability tool
-Copying The GNU General Public License
-Doc/perl5-notes Samples of new functionality
-EXTERN.h Included before foreign .h files
-INTERN.h Included before domestic .h files
-MANIFEST This list of files
-Makefile.SH A script that generates Makefile
-README The Instructions
-README.vms Notes about VMS
-Todo The Wishlist
-XSUB.h Include file for extension subroutines
-autosplit Splits up autoloader functions
-av.c Array value code
-av.h Array value header
-c2ph.SH program to translate dbx stabs to perl
-c2ph.doc documentation for c2ph
-cflags.SH A script that emits C compilation flags per file
-config.H Sample config.h
-config_h.SH Produces config.h
-configpm Produces lib/Config.pm
-cop.h Control operator header
-cv.h Code value header
-deb.c Debugging routines
-doSH Script to run all the *.SH files
-doio.c I/O operations
-doop.c Support code for various operations
-dosish.h Some defines for MS/DOSish machines
-dump.c Debugging output
-eg/ADB An adb wrapper to put in your crash dir
-eg/README Intro to example perl scripts
-eg/changes A program to list recently changed files
-eg/client A sample client
-eg/down A program to do things to subdirectories
-eg/dus A program to do du -s on non-mounted dirs
-eg/findcp A find wrapper that implements a -cp switch
-eg/findtar A find wrapper that pumps out a tar file
-eg/g/gcp A program to do a global rcp
-eg/g/gcp.man Manual page for gcp
-eg/g/ged A program to do a global edit
-eg/g/ghosts A sample /etc/ghosts file
-eg/g/gsh A program to do a global rsh
-eg/g/gsh.man Manual page for gsh
-eg/muck A program to find missing make dependencies
-eg/muck.man Manual page for muck
-eg/myrup A program to find lightly loaded machines
-eg/nih Script to insert #! workaround
-eg/relink A program to change symbolic links
-eg/rename A program to rename files
-eg/rmfrom A program to feed doomed filenames to
-eg/scan/scan_df Scan for filesystem anomalies
-eg/scan/scan_last Scan for login anomalies
-eg/scan/scan_messages Scan for console message anomalies
-eg/scan/scan_passwd Scan for passwd file anomalies
-eg/scan/scan_ps Scan for process anomalies
-eg/scan/scan_sudo Scan for sudo anomalies
-eg/scan/scan_suid Scan for setuid anomalies
-eg/scan/scanner An anomaly reporter
-eg/server A sample server
-eg/shmkill A program to remove unused shared memory
-eg/sysvipc/README Intro to Sys V IPC examples
-eg/sysvipc/ipcmsg Example of SYS V IPC message queues
-eg/sysvipc/ipcsem Example of Sys V IPC semaphores
-eg/sysvipc/ipcshm Example of Sys V IPC shared memory
-eg/travesty A program to print travesties of its input text
-eg/unuc Un-uppercases an all-uppercase text
-eg/uudecode A version of uudecode
-eg/van/empty A program to empty the trashcan
-eg/van/unvanish A program to undo what vanish does
-eg/van/vanexp A program to expire vanished files
-eg/van/vanish A program to put files in a trashcan
-eg/who A sample who program
-eg/wrapsuid A setuid script wrapper generator
-emacs/cperl-mode An alternate perl-mode
-emacs/emacs19 Notes about emacs 19
-emacs/perl-mode.el Emacs major mode for perl
-emacs/perldb.el Emacs debugging
-emacs/perldb.pl Emacs debugging
-emacs/tedstuff Some optional patches
-embed.h Maps symbols to safer names
-embed_h.sh Produces embed.h
-ext/DB_File/DB_File.pm Berkeley DB extension Perl module
-ext/DB_File/DB_File.xs Berkeley DB extension external subroutines
-ext/DB_File/DB_File_BS Berkeley DB extension mkbootstrap fodder
-ext/DB_File/Makefile.PL Berkeley DB extension makefile writer
-ext/DB_File/typemap Berkeley DB extension interface types
-ext/DynaLoader/DynaLoader.doc Dynamic Loader specification
-ext/DynaLoader/DynaLoader.pm Dynamic Loader perl module
-ext/DynaLoader/Makefile.PL Dynamic Loader makefile writer
-ext/DynaLoader/README Dynamic Loader notes and intro
-ext/DynaLoader/dl_aix.xs AIX implementation
-ext/DynaLoader/dl_dld.xs GNU dld style implementation
-ext/DynaLoader/dl_dlopen.xs BSD/SunOS4&5 dlopen() style implementation
-ext/DynaLoader/dl_hpux.xs HP-UX implementation
-ext/DynaLoader/dl_next.xs Next implementation
-ext/DynaLoader/dl_none.xs Stub implementation
-ext/DynaLoader/dl_vms.xs VMS implementation
-ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files
-ext/Fcntl/Fcntl.pm Fcntl extension Perl module
-ext/Fcntl/Fcntl.xs Fcntl extension external subroutines
-ext/Fcntl/MANIFEST Fcntl extension file list
-ext/Fcntl/Makefile.PL Fcntl extension makefile writer
-ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
-ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines
-ext/GDBM_File/Makefile.PL GDBM extension makefile writer
-ext/GDBM_File/typemap GDBM extension interface types
-ext/NDBM_File/Makefile.PL NDBM extension makefile writer
-ext/NDBM_File/NDBM_File.pm NDBM extension Perl module
-ext/NDBM_File/NDBM_File.xs NDBM extension external subroutines
-ext/NDBM_File/typemap NDBM extension interface types
-ext/ODBM_File/Makefile.PL ODBM extension makefile writer
-ext/ODBM_File/ODBM_File.pm ODBM extension Perl module
-ext/ODBM_File/ODBM_File.xs ODBM extension external subroutines
-ext/ODBM_File/typemap ODBM extension interface types
-ext/POSIX/Makefile.PL POSIX extension makefile writer
-ext/POSIX/POSIX.pm POSIX extension Perl module
-ext/POSIX/POSIX.xs POSIX extension external subroutines
-ext/POSIX/typemap POSIX extension interface types
-ext/SDBM_File/Makefile.PL SDBM extension makefile writer
-ext/SDBM_File/SDBM_File.pm SDBM extension Perl module
-ext/SDBM_File/SDBM_File.xs SDBM extension external subroutines
-ext/SDBM_File/sdbm/CHANGES SDBM kit
-ext/SDBM_File/sdbm/COMPARE SDBM kit
-ext/SDBM_File/sdbm/Makefile.PL SDBM kit
-ext/SDBM_File/sdbm/README SDBM kit
-ext/SDBM_File/sdbm/README.too SDBM kit
-ext/SDBM_File/sdbm/biblio SDBM kit
-ext/SDBM_File/sdbm/dba.c SDBM kit
-ext/SDBM_File/sdbm/dbd.c SDBM kit
-ext/SDBM_File/sdbm/dbe.1 SDBM kit
-ext/SDBM_File/sdbm/dbe.c SDBM kit
-ext/SDBM_File/sdbm/dbm.c SDBM kit
-ext/SDBM_File/sdbm/dbm.h SDBM kit
-ext/SDBM_File/sdbm/dbu.c SDBM kit
-ext/SDBM_File/sdbm/grind SDBM kit
-ext/SDBM_File/sdbm/hash.c SDBM kit
-ext/SDBM_File/sdbm/linux.patches SDBM kit
-ext/SDBM_File/sdbm/makefile.sdbm SDBM kit
-ext/SDBM_File/sdbm/pair.c SDBM kit
-ext/SDBM_File/sdbm/pair.h SDBM kit
-ext/SDBM_File/sdbm/readme.ms SDBM kit
-ext/SDBM_File/sdbm/readme.ps SDBM kit
-ext/SDBM_File/sdbm/sdbm.3 SDBM kit
-ext/SDBM_File/sdbm/sdbm.c SDBM kit
-ext/SDBM_File/sdbm/sdbm.h SDBM kit
-ext/SDBM_File/sdbm/tune.h SDBM kit
-ext/SDBM_File/sdbm/util.c SDBM kit
-ext/SDBM_File/typemap SDBM extension interface types
-ext/Socket/Makefile.PL Socket extension makefile writer
-ext/Socket/Socket.pm Socket extension Perl module
-ext/Socket/Socket.xs Socket extension external subroutines
-ext/util/extliblist Used by extension Makefile.PL to make lib lists
-ext/util/make_ext Used by Makefile to execute extension Makefiles
-ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info
-form.h Public declarations for the above
-global.sym Symbols that need hiding when embedded
-globals.c File to declare global symbols (for shared library)
-gv.c Glob value code
-gv.h Glob value header
-h2ph.SH A thing to turn C .h files into perl .ph files
-h2pl/README How to turn .ph files into .pl files
-h2pl/cbreak.pl cbreak routines using .ph
-h2pl/cbreak2.pl cbreak routines using .pl
-h2pl/eg/sizeof.ph Sample sizeof array initialization
-h2pl/eg/sys/errno.pl Sample translated errno.pl
-h2pl/eg/sys/ioctl.pl Sample translated ioctl.pl
-h2pl/eg/sysexits.pl Sample translated sysexits.pl
-h2pl/getioctlsizes Program to extract types from ioctl.h
-h2pl/mksizes Program to make %sizeof array
-h2pl/mkvars Program to make .pl from .ph files
-h2pl/tcbreak cbreak test routine using .ph
-h2pl/tcbreak2 cbreak test routine using .pl
-h2xs.SH Program to make .xs files from C header files
-handy.h Handy definitions
-hints/3b1.sh Hints for named architecture
-hints/3b1cc Hints for named architecture
-hints/PowerUNIX.sh Hints for named architecture
-hints/README.hints Notes about hints.
-hints/aix.sh Hints for named architecture
-hints/altos486.sh Hints for named architecture
-hints/apollo.sh Hints for named architecture
-hints/aux.sh Hints for named architecture
-hints/bsd386.sh Hints for named architecture
-hints/convexos.sh Hints for named architecture
-hints/cxux.sh Hints for named architecture
-hints/dec_osf.sh Hints for named architecture
-hints/dgux.sh Hints for named architecture
-hints/dnix.sh Hints for named architecture
-hints/dynix.sh Hints for named architecture
-hints/esix4.sh Hints for named architecture
-hints/fps.sh Hints for named architecture
-hints/freebsd.sh Hints for named architecture
-hints/genix.sh Hints for named architecture
-hints/greenhills.sh Hints for named architecture
-hints/hpux_9.sh Hints for named architecture
-hints/i386.sh Hints for named architecture
-hints/irix_4.sh Hints for named architecture
-hints/irix_5.sh Hints for named architecture
-hints/irix_6.sh Hints for named architecture
-hints/isc.sh Hints for named architecture
-hints/isc_2.sh Hints for named architecture
-hints/linux.sh Hints for named architecture
-hints/machten.sh Hints for named architecture
-hints/mips.sh Hints for named architecture
-hints/mpc.sh Hints for named architecture
-hints/mpeix.sh Hints for named architecture
-hints/ncr_tower.sh Hints for named architecture
-hints/netbsd.sh Hints for named architecture
-hints/next_3_0.sh Hints for named architecture
-hints/next_3_2.sh Hints for named architecture
-hints/opus.sh Hints for named architecture
-hints/sco_2_3_0.sh Hints for named architecture
-hints/sco_2_3_1.sh Hints for named architecture
-hints/sco_2_3_2.sh Hints for named architecture
-hints/sco_2_3_3.sh Hints for named architecture
-hints/sco_2_3_4.sh Hints for named architecture
-hints/sco_3.sh Hints for named architecture
-hints/solaris_2.sh Hints for named architecture
-hints/stellar.sh Hints for named architecture
-hints/sunos_4_0.sh Hints for named architecture
-hints/sunos_4_1.sh Hints for named architecture
-hints/svr4.sh Hints for named architecture
-hints/ti1500.sh Hints for named architecture
-hints/titanos.sh Hints for named architecture
-hints/ultrix_4.sh Hints for named architecture
-hints/unicos.sh Hints for named architecture
-hints/unisysdynix.sh Hints for named architecture
-hints/utekv.sh Hints for named architecture
-hints/uts.sh Hints for named architecture
-hv.c Hash value code
-hv.h Hash value header
-installperl Perl script to do "make install" dirty work
-interp.sym Interpreter specific symbols to hide in a struct
-ioctl.pl Sample ioctl.pl
-keywords.h The keyword numbers
-keywords.pl Program to write keywords.h
-lib/AnyDBM_File.pm Perl module to emulate dbmopen
-lib/AutoLoader.pm Autoloader base class
-lib/AutoSplit.pm A module to split up autoload functions
-lib/Benchmark.pm A module to time pieces of code and such
-lib/Carp.pm Error message base class
-lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir)
-lib/English.pm Readable aliases for short variables
-lib/Env.pm Map environment into ordinary variables
-lib/Exporter.pm Exporter base class
-lib/ExtUtils/MakeMaker.pm Write Makefiles for extensions
-lib/ExtUtils/typemap Extension interface types
-lib/ExtUtils/xsubpp External subroutine preprocessor
-lib/File/Basename.pm A module to emulate the basename program
-lib/File/CheckTree.pm Perl module supporting wholesale file mode validation
-lib/File/Find.pm Routines to do a find
-lib/File/Path.pm A module to do things like `mkdir -p' and `rm -r'
-lib/FileHandle.pm FileHandle methods
-lib/Getopt/Long.pm A module to fetch command options (GetOptions)
-lib/Getopt/Std.pm A module to fetch command options (getopt, getopts)
-lib/I18N/Collate.pm Routines to do strxfrm-based collation
-lib/IPC/Open2.pm Open a two-ended pipe
-lib/IPC/Open3.pm Open a three-ended pipe!
-lib/Math/BigFloat.pm An arbitrary precision floating-point arithmetic package
-lib/Math/BigInt.pm An arbitrary precision integer arithmetic package
-lib/Math/Complex.pm A Complex package
-lib/Net/Ping.pm Ping methods
-lib/Search/Dict.pm A module to do binary search on dictionaries
-lib/Shell.pm A module to make AUTOLOADEed system() calls
-lib/Sys/Hostname.pm Hostname methods
-lib/Sys/Syslog.pm Perl module supporting syslogging
-lib/Term/Cap.pm Perl module supporting termcap usage
-lib/Term/Complete.pm A command completion subroutine
-lib/Test/Harness.pm A test harness
-lib/Text/Abbrev.pm An abbreviation table builder
-lib/Text/ParseWords.pm Perl module to split words on arbitrary delimiter
-lib/Text/Soundex.pm Perl module to implement Soundex
-lib/Text/Tabs.pm Do expand and unexpand
-lib/TieHash.pm Base class for tied hashes
-lib/Time/Local.pm Reverse translation of localtime, gmtime
-lib/abbrev.pl An abbreviation table builder
-lib/assert.pl assertion and panic with stack trace
-lib/bigfloat.pl An arbitrary precision floating point package
-lib/bigint.pl An arbitrary precision integer arithmetic package
-lib/bigrat.pl An arbitrary precision rational arithmetic package
-lib/cacheout.pl Manages output filehandles when you need too many
-lib/chat2.inter A chat2 with interaction
-lib/chat2.pl Randal's famous expect-ish routines
-lib/complete.pl A command completion subroutine
-lib/ctime.pl A ctime workalike
-lib/dotsh.pl Code to "dot" in a shell script
-lib/dumpvar.pl A variable dumper
-lib/exceptions.pl catch and throw routines
-lib/fastcwd.pl a faster but more dangerous getcwd
-lib/find.pl A find emulator--used by find2perl
-lib/finddepth.pl A depth-first find emulator--used by find2perl
-lib/flush.pl Routines to do single flush
-lib/ftp.pl FTP code
-lib/getcwd.pl A getcwd() emulator
-lib/getopt.pl Perl library supporting option parsing
-lib/getopts.pl Perl library supporting option parsing
-lib/hostname.pl Old hostname code
-lib/importenv.pl Perl routine to get environment into variables
-lib/integer.pm For "use integer"
-lib/less.pm For "use less"
-lib/look.pl A "look" equivalent
-lib/newgetopt.pl A perl library supporting long option parsing
-lib/open2.pl Open a two-ended pipe
-lib/open3.pl Open a three-ended pipe
-lib/perl5db.pl Perl debugging routines
-lib/pwd.pl Routines to keep track of PWD environment variable
-lib/shellwords.pl Perl library to split into words with shell quoting
-lib/sigtrap.pm For trapping an abort and giving traceback
-lib/stat.pl Perl library supporting stat function
-lib/strict.pm For "use strict"
-lib/subs.pm Declare overriding subs
-lib/syslog.pl Perl library supporting syslogging
-lib/tainted.pl Old code for tainting
-lib/termcap.pl Perl library supporting termcap usage
-lib/timelocal.pl Perl library supporting inverse of localtime, gmtime
-lib/validate.pl Perl library supporting wholesale file mode validation
-makeaperl.SH perl script that produces a new perl binary
-makedepend.SH Precursor to makedepend
-makedir.SH Precursor to makedir
-malloc.c A version of malloc you might not want
-mg.c Magic code
-mg.h Magic header
-minimod.PL Writes lib/ExtUtils/Miniperl.pm
-miniperlmain.c Basic perl w/o dynamic loading or extensions
-mv-if-diff Script to mv a file if it changed
-myconfig Prints summary of the current configuration
-op.c Opcode syntax tree code
-op.h Opcode syntax tree header
-opcode.h Automatically generated opcode header
-opcode.pl Opcode header generatore
-patchlevel.h The current patch level of perl
-perl.c main()
-perl.h Global declarations
-perl_exp.SH Creates list of exported symbols for AIX.
-perlsh A poor man's perl shell
-perly.c A byacc'ed perly.y
-perly.c.diff Fixup perly.c to allow recursion
-perly.fixer A program to remove yacc stack limitations
-perly.h The header file for perly.c
-perly.y Yacc grammar for perl
-pl2pm A pl to pm translator
-pod/Makefile Make pods into something else
-pod/modpods/Abbrev.pod Doc for Abbrev.pm
-pod/modpods/AnyDBMFile.pod Doc for AnyDBMFile.pm
-pod/modpods/AutoLoader.pod Doc for AutoLoader.pm
-pod/modpods/AutoSplit.pod Doc for AutoSplit.pm
-pod/modpods/Basename.pod Doc for Basename.pm
-pod/modpods/Benchmark.pod Doc for Benchmark.pm
-pod/modpods/Carp.pod Doc for Carp.pm
-pod/modpods/CheckTree.pod Doc for CheckTree.pm
-pod/modpods/Collate.pod Doc for Collate.pm
-pod/modpods/Config.pod Doc for Config.pm
-pod/modpods/Cwd.pod Doc for Cwd.pm
-pod/modpods/DB_File.pod Doc for File.pm
-pod/modpods/Dynaloader.pod Doc for Dynaloader.pm
-pod/modpods/English.pod Doc for English.pm
-pod/modpods/Env.pod Doc for Env.pm
-pod/modpods/Exporter.pod Doc for Exporter.pm
-pod/modpods/Fcntl.pod Doc for Fcntl.pm
-pod/modpods/FileHandle.pod Doc for FileHandle.pm
-pod/modpods/Find.pod Doc for Find.pm
-pod/modpods/Finddepth.pod Doc for Finddepth.pm
-pod/modpods/GetOptions.pod Doc for GetOptions.pm
-pod/modpods/Getopt.pod Doc for Getopt.pm
-pod/modpods/MakeMaker.pod Doc for MakeMaker.pm
-pod/modpods/Open2.pod Doc for Open2.pm
-pod/modpods/Open3.pod Doc for Open3.pm
-pod/modpods/POSIX.pod Doc for POSIX.pm
-pod/modpods/Ping.pod Doc for Ping.pm
-pod/modpods/Socket.pod Doc for Socket.pm
-pod/modpods/integer.pod Doc for integer.pm
-pod/modpods/less.pod Doc for less.pm
-pod/modpods/sigtrap.pod Doc for sigtrap.pm
-pod/modpods/strict.pod Doc for strict.pm
-pod/modpods/subs.pod Doc for subs.pm
-pod/perl.pod Top level perl man page
-pod/perlapi.pod XS api info
-pod/perlbook.pod Book info
-pod/perlbot.pod Object-oriented Bag o' Tricks
-pod/perlcall.pod Callback info
-pod/perldata.pod Data structure info
-pod/perldebug.pod Debugger info
-pod/perldiag.pod Diagnostic info
-pod/perlembed.pod Embedding info
-pod/perlform.pod Format info
-pod/perlfunc.pod Function info
-pod/perlguts.pod Internals info
-pod/perlipc.pod IPC info
-pod/perlmod.pod Module info
-pod/perlobj.pod Object info
-pod/perlop.pod Operator info
-pod/perlovl.pod Overloading info
-pod/perlpod.pod Pod info
-pod/perlre.pod Regular expression info
-pod/perlref.pod References info
-pod/perlrun.pod Execution info
-pod/perlsec.pod Security info
-pod/perlstyle.pod Style info
-pod/perlsub.pod Subroutine info
-pod/perlsyn.pod Syntax info
-pod/perltrap.pod Trap info
-pod/perlvar.pod Variable info
-pod/pod2html Translator to turn pod into HTML
-pod/pod2man Translator to turn pod into manpage
-pod/splitman Splits perlfunc into multiple man pages
-pp.c Push/Pop code
-pp.h Push/Pop code defs
-pp_ctl.c Push/Pop code for control flow
-pp_hot.c Push/Pop code for heavily used opcodes
-pp_sys.c Push/Pop code for system interaction
-proto.h Prototypes
-regcomp.c Regular expression compiler
-regcomp.h Private declarations for above
-regexec.c Regular expression evaluator
-regexp.h Public declarations for the above
-run.c The interpreter loop
-scope.c Scope entry and exit code
-scope.h Scope entry and exit header
-sv.c Scalar value code
-sv.h Scalar value header
-t/README Instructions for regression tests
-t/TEST The regression tester
-t/base/cond.t See if conditionals work
-t/base/if.t See if if works
-t/base/lex.t See if lexical items work
-t/base/pat.t See if pattern matching works
-t/base/term.t See if various terms work
-t/cmd/elsif.t See if else-if works
-t/cmd/for.t See if for loops work
-t/cmd/mod.t See if statement modifiers work
-t/cmd/subval.t See if subroutine values work
-t/cmd/switch.t See if switch optimizations work
-t/cmd/while.t See if while loops work
-t/comp/cmdopt.t See if command optimization works
-t/comp/cpp.t See if C preprocessor works
-t/comp/decl.t See if declarations work
-t/comp/multiline.t See if multiline strings work
-t/comp/package.t See if packages work
-t/comp/script.t See if script invokation works
-t/comp/term.t See if more terms work
-t/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
-t/io/inplace.t See if inplace editing works
-t/io/pipe.t See if secure pipes work
-t/io/print.t See if print commands work
-t/io/tell.t See if file seeking works
-t/lib/anydbm.t See if AnyDBM_File works
-t/lib/bigint.t See if bigint.pl works
-t/lib/db-btree.t See if DB_File works
-t/lib/db-hash.t See if DB_File works
-t/lib/db-recno.t See if DB_File works
-t/lib/english.t See if English works
-t/lib/gdbm.t See if GDBM_File works
-t/lib/ndbm.t See if NDBM_File works
-t/lib/odbm.t See if ODBM_File works
-t/lib/posix.t See if POSIX works
-t/lib/sdbm.t See if SDBM_File works
-t/lib/soundex.t See if Soundex works
-t/op/append.t See if . works
-t/op/array.t See if array operations work
-t/op/auto.t See if autoincrement et all work
-t/op/chop.t See if chop works
-t/op/cond.t See if conditional expressions work
-t/op/delete.t See if delete works
-t/op/do.t See if subroutines work
-t/op/each.t See if associative iterators work
-t/op/eval.t See if eval operator works
-t/op/exec.t See if exec and system work
-t/op/exp.t See if math functions work
-t/op/flip.t See if range operator works
-t/op/fork.t See if fork works
-t/op/glob.t See if <*> works
-t/op/goto.t See if goto works
-t/op/groups.t See if $( works
-t/op/index.t See if index works
-t/op/int.t See if int works
-t/op/join.t See if join works
-t/op/list.t See if array lists work
-t/op/local.t See if local works
-t/op/magic.t See if magic variables work
-t/op/misc.t See if miscellaneous bugs have been fixed
-t/op/mkdir.t See if mkdir works
-t/op/my.t See if lexical scoping works
-t/op/oct.t See if oct and hex work
-t/op/ord.t See if ord works
-t/op/pack.t See if pack and unpack work
-t/op/pat.t See if esoteric patterns work
-t/op/push.t See if push and pop work
-t/op/quotemeta.t See if quotemeta works
-t/op/rand.t See if rand works
-t/op/range.t See if .. works
-t/op/re_tests Input file for op.regexp
-t/op/read.t See if read() works
-t/op/readdir.t See if readdir() works
-t/op/ref.t See if refs and objects work
-t/op/regexp.t See if regular expressions work
-t/op/repeat.t See if x operator works
-t/op/sleep.t See if sleep works
-t/op/sort.t See if sort works
-t/op/split.t See if split works
-t/op/sprintf.t See if sprintf works
-t/op/stat.t See if stat works
-t/op/study.t See if study works
-t/op/subst.t See if substitution works
-t/op/substr.t See if substr works
-t/op/time.t See if time functions work
-t/op/undef.t See if undef works
-t/op/unshift.t See if unshift works
-t/op/vec.t See if vectors work
-t/op/write.t See if write works
-t/re_tests Regular expressions for regexp.t
-taint.c Tainting code
-toke.c The tokener
-unixish.h Defines that are assumed on Unix
-util.c Utility routines
-util.h Public declarations for the above
-vms/config.vms VMS port
-vms/descrip.mms VMS port
-vms/ext/MM_VMS.pm VMS port
-vms/gen_shrfls.pl VMS port
-vms/genconfig.pl VMS port
-vms/genopt.com VMS port
-vms/makefile. VMS port
-vms/mms2make.pl VMS port
-vms/perlshr.c VMS port
-vms/perlvms.pod VMS port
-vms/sockadapt.c VMS port
-vms/sockadapt.h VMS port
-vms/test.com VMS port
-vms/vms.c VMS port
-vms/vmsish.h VMS port
-vms/writemain.pl VMS port
-writemain.SH Generate perlmain.c from miniperlmain.c+extensions
-x2p/EXTERN.h Same as above
-x2p/INTERN.h Same as above
-x2p/Makefile.SH Precursor to Makefile
-x2p/a2p.c A byacc'ed a2p.y
-x2p/a2p.h Global declarations
-x2p/a2p.man Manual page for awk to perl translator
-x2p/a2p.y A yacc grammer for awk
-x2p/a2py.c Awk compiler, sort of
-x2p/cflags.SH A script that emits C compilation flags per file
-x2p/find2perl.SH A find to perl translator
-x2p/handy.h Handy definitions
-x2p/hash.c Associative arrays again
-x2p/hash.h Public declarations for the above
-x2p/s2p.SH Sed to perl translator
-x2p/s2p.man Manual page for sed to perl translator
-x2p/str.c String handling package
-x2p/str.h Public declarations for the above
-x2p/util.c Utility routines
-x2p/util.h Public declarations for the above
-x2p/walk.c Parse tree walker
-xf A script to translate Perl 4 symbols to Perl 5
-[This is an unsupported, pre-release version of Perl 5.0.]
Perl Kit, Version 5.0
my interpretation of the GNU General Public License is that no Perl
script falls under the terms of the GPL unless you explicitly put
said script under the terms of the GPL yourself. Furthermore, any
- object code linked with uperl.o does not automatically fall under the
+ object code linked with perl does not automatically fall under the
terms of the GPL, provided such object code only adds definitions
of subroutines and variables, and does not otherwise impair the
resulting interpreter from executing any standard Perl script. I
-Last revised: 09-Oct-1994 by Charles Bailey bailey@genetics.upenn.edu
+Last revised: 08-Feb-1995 by Charles Bailey bailey@genetics.upenn.edu
-The VMS port of perl5 is still under development. At this time, the perl
+The VMS port of Perl is still under development. At this time, the Perl
binaries built under VMS handle internal operations properly, for the most
part, as well as most of the system calls which have close equivalents under
VMS. There are still some incompatibilities in process handling (e.g the
fork/exec model for creating subprocesses doesn't do what you might expect
-under Unix), and there remain some file handling differences from Unix. There
-is a VMS implementation of the DynaLoader, but it hasn't been tested much, so
-it may still have some bugs in it. Over the longer term, we'll try to get many
-of the useful VMS system services integrated as well, depending on time and
-people available. Of course, if you'd like to add something yourself, or join
-the porting team, we'd love to have you!
+under Unix), and there remain some file handling differences from Unix. Over
+the longer term, we'll try to get many of the useful VMS system services
+integrated as well, depending on time and people available. Of course, if
+you'd like to add something yourself, or join the porting team, we'd love to
+have you!
The current sources and build procedures have been tested on a VAX using VAXC
-and on an AXP using DECC. IF you run into problems with other compilers,
+and on an AXP using DECC. If you run into problems with other compilers,
please let us know.
+Note to DECC users: Some early versions of the DECCRTL contained a few bugs
+which affect Perl performance:
+ - Newlines are lost on I/O through pipes, causing lines to run together.
+ This shows up as RMS RTB errors when reading from a pipe. You can
+ work around this by having one process write data to a file, and
+ then having the other read the file, instead of the pipe.
+ - The modf() routine returns a non-integral value for some values above
+ INT_MAX; the Perl "int" operator will return a non-integral value in
+ these cases.
+Both of these bugs have been fixed in later releases of the DECCRTL, but some
+systems running AXP/VMS 1.5 still have the old RTLs.
* Other software required
* Socket support
-Perl5 includes a number of IP socket routines among its builtin functions,
-which are available if you choose to compile perl with socket support. Since
+Perl includes a number of IP socket routines among its builtin functions,
+which are available if you choose to compile Perl with socket support. Since
IP networking is an optional addition to VMS, there are several different IP
-stacks available, it's difficult to automate the process of building perl5 with
+stacks available, it's difficult to automate the process of building Perl with
socket support in a way which will work on all systems.
-By default, perl5 is built without IP socket support. If you define the macro
+By default, Perl is built without IP socket support. If you define the macro
SOCKET when invoking MMS, however, socket support will be included. As
-distributed, perl5 for VMS includes support for the SOCKETSHR socket library,
+distributed, Perl for VMS includes support for the SOCKETSHR socket library,
which is layered on MadGoat software's vendor-independent NETLIB interface.
-This provides support for all socket calls used by perl5 except the
+This provides support for all socket calls used by Perl except the
[g|s]et*ent() routines, which are replaced for the moment by stubs which
-generate a fatal error if a perl script attempts to call one of these routines.
-If you'd like to link perl directly to your IP stack to take advantage of these
+generate a fatal error if a Perl script attempts to call one of these routines.
+If you'd like to link Perl directly to your IP stack to take advantage of these
routines or to eliminate the intermediate NETLIB, then make the following
changes:
- In Descrip.MMS, locate the section beginning with .ifdef SOCKET, and
includes the In.H, NetDb.H, and, if necessary, Errno.H header files
for your IP stack, or so that it declares the standard TCP/IP data
structures appropriately (see the distributed copy of SockAdapt.H
- for a collection of the structures needed by perl.) You should also
+ for a collection of the structures needed by Perl.) You should also
define any logical names necessary to find these files before invoking
- MMS to build perl.
+ MMS to build Perl.
- Edit the file SockAdapt.C in the [.VMS] subdirectory so that it
contains routines which substitute for any IP library routines
- required by perl which your IP stack does not provide. This may
+ required by Perl which your IP stack does not provide. This may
require a little trial and error; we'll try to compile a complete
- list soon of socket routines required by perl5.
+ list soon of socket routines required by Perl.
-* Building perl under VMS
+* Building Perl under VMS
-Since you're reading this, presumable you've unpacked the perl distribution
+Since you're reading this, presumably you've unpacked the Perl distribution
into its directory tree, in which you will find a [.vms] subdirectory below
the directory in which this file is found. If this isn't the case, then you'll
need to unpack the distribution properly, or manually edit Descrip.MMS or
-the VMS Makefile. to alter directory paths as necessary. (I'd advise using the
+the VMS Makefile to alter directory paths as necessary. (I'd advise using the
`normal' directory tree, at least for the first time through.) This
subdirectory contains several files, among which are the following:
Config.VMS - A template C header file set up for VMS.
- Descrip.MMS - The MMS/MMK dependency file for building perl
- GenConfig.Pl - A perl script to generate Config.SH retrospectively
+ Descrip.MMS - The MMS/MMK dependency file for building Perl
+ GenConfig.Pl - A Perl script to generate Config.SH retrospectively
from Config.VMS, since the Configure shell script which
normally generates Config.SH doesn't run under VMS.
GenOpt.Com - A little DCL procedure used to write some linker options
files, since not all make utilities can do this easily.
- Gen_ShrFls.Pl - A perl script which generates linker options files and
+ Gen_ShrFls.Pl - A Perl script which generates linker options files and
MACRO declarations for PerlShr.Exe.
- Makefile. - The make dependency file for building perl
- MMS2Make.Pl - A perl script used to generate Makefile. from Descrip.MMS
+ Makefile - The make dependency file for building Perl
+ MMS2Make.Pl - A Perl script used to generate Makefile from Descrip.MMS
VMSish.H - C header file containing VMS-specific definitions
VMS.C - C source code for VMS-specific routines
- WriteMain.Pl - A perl script used to generate perlmain.c during the build.
+ WriteMain.Pl - A Perl script used to generate perlmain.c during the build.
There may also be other files pertaining to features under development; for the
most part, you can ignore them.
-Config.VMS and Decrip.MMS/Makefile. are set up to build a version of perl which
+Config.VMS and Decrip.MMS/Makefile are set up to build a version of Perl which
includes all features known to work when this release was assembled. If you
have code at your site which would support additional features (e.g. emulation
of Unix system calls), feel free to make the appropriate changes to these
-files. (Note: Do not use or edit config.h in the main perl source directory;
+files. (Note: Do not use or edit config.h in the main Perl source directory;
it is superseded by the current Config.VMS during the build.) You may also
-wish to make site-specific changes to Descrip.MMS or Makefile. to reflect local
+wish to make site-specific changes to Descrip.MMS or Makefile to reflect local
conventions for naming of files, etc.
-At the moment, system-specific information which becomes part of the perl5
+At the moment, system-specific information which becomes part of the Perl
Config extension is hard-coded into the file genconfig.pl in the vms
-subdirectory. Before you build perl, you should make any changes to the list
+subdirectory. Before you build Perl, you should make any changes to the list
at the end of this file necessary to reflect your system (e.g your hostname and
VMS version).
Examine the information at the beginning of Descrip.MMS for information about
-specifying alternate C compilers or building a version of perl with debugging
+specifying alternate C compilers or building a version of Perl with debugging
support. For instance, if you want to use DECC, you'll need to include the
/macro="decc=1" qualifier to MMS (If you're using make, these options are not
supported.) If you're on an AXP system, define the macro __AXP__ (MMK does
this for you), and DECC will automatically be selected.
-To start the build, set default to the main source directory.
-Then, if you are using MMS or MMK, issue the command
+To start the build, set default to the main source directory. Since
+Descrip.MMS assumes that VMS commands have their usual meaning, and makes use
+of command-line macros, you may want to be certain that you haven't defined DCL
+symbols which would interfere with the build. Then, if you are using MMS or
+MMK, say
$ MMS/Descrip=[.VMS] ! or MMK
-If you are using make, issue the command
-$ Make -f [.VMS]Makefile.
-Note that the Makefile. doesn't support conditional compilation, and is
+If you are using make, say
+$ Make -f [.VMS]Makefile
+Note that the Makefile doesn't support conditional compilation, is
set up to use VAXC on a VAX, and does not include socket support. You can
-either edit the Makefile. by hand, using Descrip.MMS as a guide, or use the
-Makefile. to build Miniperl.Exe, and then run the Perl script MMS@Make.pl,
+either edit the Makefile by hand, using Descrip.MMS as a guide, or use the
+Makefile to build Miniperl.Exe, and then run the Perl script MMS2Make.pl,
found in the [.VMS] subdirectory, to generate a new Makefile with the options
appropriate to your site.
This will build the following files:
Miniperl.Exe - a stand-alone version of without any extensions.
- Miniperl has all the intrinsic capabilities of perl,
+ Miniperl has all the intrinsic capabilities of Perl,
but cannot make use of the DynaLoader or any
extensions which use XS code.
- PerlShr.Exe - a shareable image containing most of perl's internal
+ PerlShr.Exe - a shareable image containing most of Perl's internal
routines and global variables. Perl.Exe is linked to
this image, as are all dynamic extensions, so everyone's
using the same set of global variables and routines.
- Perl.Exe - the main perl executable image. It's contains the
+ Perl.Exe - the main Perl executable image. It's contains the
main() routine, plus code for any statically linked
extensions.
PerlShr_Attr.Opt - A linker options file which specifies psect attributes
matching those in PerlShr.Exe. It should be used when
linking images against PerlShr.Exe
- [.Lib]Config.pm - the perl extension which saves configuration information
- about perl and your system.
- [.lib]DynaLoader.pm - The perl extension which performs dynamic linking of
+ PerlShr_Bld.Opt - A linker options file which specifies various things
+ used to build PerlShr.Exe. It should be used when
+ rebuilding PerlShr.Exe via MakeMaker-produced
+ Descrip.MMS files for static extensions.
+ [.Lib]Config.pm - the Perl extension which saves configuration information
+ about Perl and your system.
+ [.lib]DynaLoader.pm - The Perl extension which performs dynamic linking of
shareable images for extensions.
There are, of course, a number of other files created for use during the build.
Once you've got the binaries built, you may wish to `build' the `tidy' or
`clean' targets to remove extra files.
-* Installing perl once it's built
+* Installing Perl once it's built
Once the build is complete, you'll need to do the following:
- Put PerlShr.Exe in a common directory, and make it world-readable.
If you place it in a location other than Sys$Share, you'll need to
define the logical name PerlShr to point to the image.
- Put Perl.Exe in a common directory, and make it world executable
- - Define a foreign command to invoke perl, using a statement like
+ - Define a foreign command to invoke Perl, using a statement like
$ Perl == "$dev:[dir]Perl.Exe"
- - Create a world-readable directory tree for perl library modules,
+ - Create a world-readable directory tree for Perl library modules,
scripts, and what-have-you, and define PERL_ROOT as a rooted logical
- name pointing to the top of this tree (i.e. if your perl files were
- going to live in DKA1:[Perl5...], then you should
- $ Define/Translation=Concealed Perl_Root DKA1:[Perl5.]
+ name pointing to the top of this tree (i.e. if your Perl files were
+ going to live in DKA1:[Util.Perl5...], then you should
+ $ Define/Translation=Concealed Perl_Root DKA1:[Util.Perl5.]
+ (Be careful to follow the rules for rooted logical names; in particular,
+ remember that a rooted logical name cannot have as its device portion
+ another rooted logical name - you've got to supply the actual device name
+ and directory path to the root directory.)
- Define the logical name PERLSHR as the full file specification of
PERLSHR.EXE, so executable images linked to it can find it. Alternatively,
you can justput PERLSHR.EXE int SYS$SHARE.
- Place the files from the [.lib] subdirectory in the distribution package
into a [.lib] subdirectory off the root directory described above.
- - Most of the perl5 documentation lives in the [.pod] subdirectory, and
+ - Most of the Perl documentation lives in the [.pod] subdirectory, and
is written in a simple markup format which can be easily read. In this
directory as well are pod2man and pod2html translators to reformat the
docs for common display engines; a pod2hlp translator is under development.
- Information on perl5 can also be gleaned from the files in the [.doc]
+ Information on Perl can also be gleaned from the files in the [.doc]
subdirectory (internals documents and summaries of changes), and from
the test scripts in the [.t...] subdirectories.
For now, that's it.
* For more information
-If you're interested in more information on perl in general, consult the Usenet
+If you're interested in more information on Perl in general, consult the Usenet
newsgroup comp.lang.perl. The FAQ for that group provides pointers to other
-online sources of information, as well as books describing perl in depth.
+online sources of information, as well as books describing Perl in depth.
-If you're interested in up-to-date information on perl5 development and
+If you're interested in up-to-date information on Perl development and
internals, you might want to subscribe to the perl5-porters mailing list. You
-can do this by sending a message to perl5-porters-request@isi.edu, containing
+can do this by sending a message to perl5-porters-request@nicoh.com, containing
the single line
subscribe perl5-porters Your Name Here
This is a moderately high-volume list at the moment (25-50 messages/day).
like to offer - you can send mail to bailey@genetics.upenn.edu or directly to
the VMSperl list at vmsperl@genetics.upenn.edu.
-Good luck using perl. Please let us know how it works for you - we can't
+Good luck using Perl. Please let us know how it works for you - we can't
guarantee that we'll be able to fix bugs quickly, but we'll try, and we'd
certainly like to know they're out there.
* Acknowledgements
There are, of course, far too many people involved in the porting and testing
-of perl5 to mention everyone who deserves it, so please forgive us if we've
+of Perl to mention everyone who deserves it, so please forgive us if we've
missed someone. That said, special thanks are due to the following:
+ Tim Adye <T.J.Adye@rl.ac.uk>
+ for the VMS emulations of getpw*()
David Denholm <denholm@conmat.phys.soton.ac.uk>
for extensive testing and provision of pipe and SocketShr code,
Mark Pizzolato <mark@infocomm.com>
Rich Salz <rsalz@bbn.com>
for readdir() and related routines
Denis Haskin <DWH@epub.ziff.com>
- for work on a pod-to-hlp translator for the perl5 documentation
+ for work on a pod-to-hlp translator for the Perl documentation
Richard Dyson <dyson@blaze.physics.uiowa.edu> and
Kent Covert <kacovert@miavx1.acs.muohio.edu>
for additional testing on the AXP.
-Modules needed
- X/Motif/Tk etc.
- Curses
-
Tie Modules
VecArray Implement array using vec()
SubstrArray Implement array using substr()
-i rename file only when successfully changed
All ARGV input should act like <>
Multiple levels of warning
- .= shouldn't complain about undefined under -w
report HANDLE [formats].
tie(FILEHANDLE, ...)
__DATA__
support in perlmain to rerun debugger
make 'r' print return value like gdb 'fini'
+ regression tests using __WARN__ and __DIE__ hooks
Possible pragmas
debugger
Populate %SIG at startup if appropriate
sub mysplice(@, $, $, ...)
data prettyprint function? (or is it, as I suspect, a lib routine?)
- Nested destructors
make tr/// return histogram in list context?
undef wantarray in void context
Loop control on do{} et al
autocroak?
Modifiable $1 et al
substr EXPR,OFFSET,LENGTH,STRING
- locally capture warnings into an array
+++ /dev/null
-?RCS: $Id: Extensions.U,v$
-?RCS:
-?RCS: You may redistribute only under the terms of the Artistic Licence,
-?RCS: as specified in the README file that comes with the distribution.
-?RCS: You may reuse parts of this distribution only within the terms of
-?RCS: that same Artistic Licence; a copy of which may be found at the root
-?RCS: of the source tree for dist 3.0.
-?RCS:
-?RCS: $Log: Extensions.U,v $
-?RCS:
-?MAKE:known_extensions extensions dynamic_ext static_ext useposix : \
- Myread usedl d_socket i_db i_dbm i_ndbm i_gdbm package test cat
-?MAKE: -pick add $@ %<
-?S:known_extensions:
-?S: This variable holds a list of all extensions included in
-?S: the package.
-?S:.
-?S:dynamic_ext:
-?S: This variable holds a list of extension files we want to
-?S: link dynamically into the package. It is used by Makefile.
-?S:.
-?S:static_ext:
-?S: This variable holds a list of extension files we want to
-?S: link statically into the package. It is used by Makefile.
-?S:.
-?S:extensions:
-?S: This variable holds a list of all extension files
-?S: linked into the package. It is propagated to Config.pm
-?S: and is typically used to test whether a particular extesion
-?S: is available.
-?S:.
-?S:useposix:
-?S: This variable holds either 'true' or 'false' to indicate
-?S: whether the POSIX extension should be used. The sole
-?S: use for this currently is to allow an easy mechanism
-?S: for hints files to indicate that POSIX will not compile
-?S: on a particular system.
-?S:.
-?T:xxx yyy avail_ext
-?INIT:: set useposix=false in your hint file to disable the POSIX extension.
-?INIT:useposix=true
-echo " "
-echo "Looking for extensions..." >&4
-cd ../ext
-: If we are using the old config.sh, known_extensions may contain
-: old or inaccurate or duplicate values.
-known_extensions=''
-: We do not use find because it might not be available.
-: We do not just use MANIFEST because the user may have dropped
-: some additional extensions into the source tree and expect them
-: to be built.
-for xxx in * ; do
- if $test -f $xxx/$xxx.xs; then
- known_extensions="$known_extensions $xxx"
- else
- if $test -d $xxx; then
- cd $xxx
- for yyy in * ; do
- if $test -f $yyy/$yyy.xs; then
- known_extensions="$known_extensions $xxx/$yyy"
- fi
- done
- cd ..
- fi
- fi
-done
-set X $known_extensions
-shift
-known_extensions="$*"
-cd ../UU
-
-: Now see which are supported on this system.
-avail_ext=''
-for xxx in $known_extensions ; do
- case "$xxx" in
- DB_File) case "$i_db" in
- $define) avail_ext="$avail_ext $xxx" ;;
- esac
- ;;
- GDBM_File) case "$i_gdbm" in
- $define) avail_ext="$avail_ext $xxx" ;;
- esac
- ;;
- NDBM_File) case "$i_ndbm" in
- $define) avail_ext="$avail_ext $xxx" ;;
- esac
- ;;
- ODBM_File) case "$i_dbm" in
- $define) avail_ext="$avail_ext $xxx" ;;
- esac
- ;;
- POSIX) case "$useposix" in
- true|define|y) avail_ext="$avail_ext $xxx" ;;
- esac
- ;;
- Socket) case "$d_socket" in
- $define) avail_ext="$avail_ext $xxx" ;;
- esac
- ;;
- *) avail_ext="$avail_ext $xxx"
- ;;
- esac
-done
-
-set X $avail_ext
-shift
-avail_ext="$*"
-
-case $usedl in
-$define)
- $cat <<EOM
-A number of extensions are supplied with $package. You may choose to
-compile these extensions for dynamic loading (the default), compile
-them into the $package executable (static loading), or not include
-them at all. Answer "none" to include no extensions.
-
-EOM
- case "$dynamic_ext" in
- ''|' ') dflt="$avail_ext" ;;
- *) dflt="$dynamic_ext" ;;
- esac
- case "$dflt" in
- '') dflt=none;;
- esac
- rp="What extensions do you wish to load dynamically?"
- . ./myread
- case "$ans" in
- none) dynamic_ext='' ;;
- *) dynamic_ext="$ans" ;;
- esac
-
- case "$static_ext" in
- ''|' ')
- : Exclude those already listed in dynamic linking
- dflt=''
- for xxx in $avail_ext; do
- case " $dynamic_ext " in
- *" $xxx "*) ;;
- *) dflt="$dflt $xxx" ;;
- esac
- done
- set X $dflt
- shift
- dflt="$*"
- ;;
- *) dflt="$static_ext"
- ;;
- esac
-
- case "$dflt" in
- '') dflt=none;;
- esac
- rp="What extensions do you wish to load statically?"
- . ./myread
- case "$ans" in
- none) static_ext='' ;;
- *) static_ext="$ans" ;;
- esac
- ;;
-*)
- $cat <<EOM
-A number of extensions are supplied with $package. Answer "none"
-to include no extensions.
-
-EOM
- case "$static_ext" in
- ''|' ') dflt="$avail_ext" ;;
- *) dflt="$static_ext" ;;
- esac
-
- case "$dflt" in
- '') dflt=none;;
- esac
- rp="What extensions do you wish to include?"
- . ./myread
- case "$ans" in
- none) static_ext='' ;;
- *) static_ext="$ans" ;;
- esac
- ;;
-esac
-
-set X $dynamic_ext $static_ext
-shift
-extensions="$*"
-
+++ /dev/null
-?RCS: $Id: Extract.U,v 3.0.1.1 1994/10/29 15:51:46 ram Exp $
-?RCS:
-?RCS: Copyright (c) 1991-1993, Raphael Manfredi
-?RCS:
-?RCS: You may redistribute only under the terms of the Artistic Licence,
-?RCS: as specified in the README file that comes with the distribution.
-?RCS: You may reuse parts of this distribution only within the terms of
-?RCS: that same Artistic Licence; a copy of which may be found at the root
-?RCS: of the source tree for dist 3.0.
-?RCS:
-?RCS: This private version for perl5 will also extract files from
-?RCS: extension MANIFEST. (ext/Blah/MANIFEST).
-?RCS:
-?RCS: $Log: Extract.U,v $
-?RCS: Revision 3.0.1.1 1994/10/29 15:51:46 ram
-?RCS: patch36: added ?F: line for metalint file checking
-?RCS:
-?RCS: Revision 3.0 1993/08/18 12:04:52 ram
-?RCS: Baseline for dist 3.0 netwide release.
-?RCS:
-?X:
-?X: This unit produces a shell script which can be doted in order to extract
-?X: .SH files with variable substitutions.
-?X:
-?MAKE:Extract: Nothing
-?MAKE: -pick add $@ %<
-?F:./extract !config_h.SH
-?T:CONFIG dir file shlist xxx
-: script used to extract .SH files with variable substitutions
-cat >extract <<'EOS'
-CONFIG=true
-echo "Doing variable substitutions on .SH files..."
-if test -f MANIFEST; then
- shlist=`awk '{print $1}' <MANIFEST | grep '\.SH'`
- : Pick up possible extension manifests.
- for dir in ext/* ; do
- if test -f $dir/MANIFEST; then
- xxx=`awk '{print $1}' < $dir/MANIFEST |
- sed -n "/\.SH$/ s@^@$dir/@p"`
- shlist="$shlist $xxx"
- fi
- done
- set x $shlist
-else
- echo "(Looking for .SH files under the current directory.)"
- set x `find . -name "*.SH" -print`
-fi
-shift
-case $# in
-0) set x *.SH; shift;;
-esac
-if test ! -f $1; then
- shift
-fi
-for file in $*; do
- case "$file" in
- */*)
- dir=`expr X$file : 'X\(.*\)/'`
- file=`expr X$file : 'X.*/\(.*\)'`
- (cd $dir && . ./$file)
- ;;
- *)
- . ./$file
- ;;
- esac
-done
-if test -f config_h.SH; then
- if test ! -f config.h; then
- : oops, they left it out of MANIFEST, probably, so do it anyway.
- . ./config_h.SH
- fi
-fi
-EOS
-
+++ /dev/null
-?RCS: $Id: Guess.U,v 3.0.1.4 1994/10/29 15:53:55 ram Exp $
-?RCS:
-?RCS: Copyright (c) 1991-1993, Raphael Manfredi
-?RCS:
-?RCS: You may redistribute only under the terms of the Artistic Licence,
-?RCS: as specified in the README file that comes with the distribution.
-?RCS: You may reuse parts of this distribution only within the terms of
-?RCS: that same Artistic Licence; a copy of which may be found at the root
-?RCS: of the source tree for dist 3.0.
-?RCS:
-?RCS: $Log: Guess.U,v $
-?RCS: Revision 3.0.1.4 1994/10/29 15:53:55 ram
-?RCS: patch36: added ?F: line for metalint file checking
-?RCS: patch36: call ./xenix explicitely instead of relying on PATH
-?RCS:
-?RCS: Revision 3.0.1.3 1993/12/15 08:14:35 ram
-?RCS: patch15: variable d_bsd was not always set properly
-?RCS:
-?RCS: Revision 3.0.1.2 1993/08/30 08:57:14 ram
-?RCS: patch8: fixed comment which wrongly attributed the usrinc symbol
-?RCS: patch8: no more ugly messages when no /usr/include/ctype.h
-?RCS:
-?RCS: Revision 3.0.1.1 1993/08/27 14:37:37 ram
-?RCS: patch7: added support for OSF/1 machines
-?RCS:
-?RCS: Revision 3.0 1993/08/18 12:04:57 ram
-?RCS: Baseline for dist 3.0 netwide release.
-?RCS:
-?X:
-?X: This unit hazards some guesses as to what the general nature of the system
-?X: is. The information it collects here is used primarily to establish default
-?X: answers to other questions.
-?X:
-?MAKE:Guess d_eunice d_xenix d_bsd: cat test echo n c contains rm Loc eunicefix
-?MAKE: -pick add $@ %<
-?S:d_eunice:
-?S: This variable conditionally defines the symbols EUNICE and VAX, which
-?S: alerts the C program that it must deal with ideosyncracies of VMS.
-?S:.
-?S:d_xenix:
-?S: This variable conditionally defines the symbol XENIX, which alerts
-?S: the C program that it runs under Xenix.
-?S:.
-?S:d_bsd:
-?S: This symbol conditionally defines the symbol BSD when running on a
-?S: BSD system.
-?S:.
-?C:EUNICE:
-?C: This symbol, if defined, indicates that the program is being compiled
-?C: under the EUNICE package under VMS. The program will need to handle
-?C: things like files that don't go away the first time you unlink them,
-?C: due to version numbering. It will also need to compensate for lack
-?C: of a respectable link() command.
-?C:.
-?C:VMS:
-?C: This symbol, if defined, indicates that the program is running under
-?C: VMS. It is currently only set in conjunction with the EUNICE symbol.
-?C:.
-?C:XENIX:
-?C: This symbol, if defined, indicates thet the program is running under
-?C: Xenix (at least 3.0 ?).
-?C:.
-?X:We don't use BSD in the perl source. It's too vague, and already
-?X:defined in some header files anyway (e.g. NetBSD).
-?X:?C:BSD:
-?X:?C: This symbol, if defined, indicates that the program is running under
-?X:?C: a BSD system.
-?X:?C:.
-?H:#$d_eunice EUNICE /**/
-?H:#$d_eunice VMS /**/
-?H:#$d_xenix XENIX /**/
-?X:?H:#$d_bsd BSD /**/
-?H:.
-?F:./bsd ./usg ./v7 ./osf1 ./eunice ./xenix ./venix
-?T:xxx
-: make some quick guesses about what we are up against
-echo " "
-$echo $n "Hmm... $c"
-echo exit 1 >bsd
-echo exit 1 >usg
-echo exit 1 >v7
-echo exit 1 >osf1
-echo exit 1 >eunice
-echo exit 1 >xenix
-echo exit 1 >venix
-d_bsd="$undef"
-?X:
-?X: Do not use 'usrinc', or we get a circular dependency. because
-?X: usrinc is defined in usrinc.U, which relies on us...
-?X:
-$cat /usr/include/signal.h /usr/include/sys/signal.h >foo 2>/dev/null
-if test -f /osf_boot || $contains 'OSF/1' /usr/include/ctype.h >/dev/null 2>&1
-then
- echo "Looks kind of like an OSF/1 system, but we'll see..."
- echo exit 0 >osf1
-elif test `echo abc | tr a-z A-Z` = Abc ; then
- xxx=`./loc addbib blurfl $pth`
- if $test -f $xxx; then
- echo "Looks kind of like a USG system with BSD features, but we'll see..."
- echo exit 0 >bsd
- echo exit 0 >usg
- else
- if $contains SIGTSTP foo >/dev/null 2>&1 ; then
- echo "Looks kind of like an extended USG system, but we'll see..."
- else
- echo "Looks kind of like a USG system, but we'll see..."
- fi
- echo exit 0 >usg
- fi
-elif $contains SIGTSTP foo >/dev/null 2>&1 ; then
- echo "Looks kind of like a BSD system, but we'll see..."
- d_bsd="$define"
- echo exit 0 >bsd
-else
- echo "Looks kind of like a Version 7 system, but we'll see..."
- echo exit 0 >v7
-fi
-case "$eunicefix" in
-*unixtovms*)
- $cat <<'EOI'
-There is, however, a strange, musty smell in the air that reminds me of
-something...hmm...yes...I've got it...there's a VMS nearby, or I'm a Blit.
-EOI
- echo exit 0 >eunice
- d_eunice="$define"
-: it so happens the Eunice I know will not run shell scripts in Unix format
- ;;
-*)
- echo " "
- echo "Congratulations. You aren't running Eunice."
- d_eunice="$undef"
- ;;
-esac
-if test -f /xenix; then
- echo "Actually, this looks more like a XENIX system..."
- echo exit 0 >xenix
- d_xenix="$define"
-else
- echo " "
- echo "It's not Xenix..."
- d_xenix="$undef"
-fi
-chmod +x xenix
-$eunicefix xenix
-if test -f /venix; then
- echo "Actually, this looks more like a VENIX system..."
- echo exit 0 >venix
-else
- echo " "
- if ./xenix; then
- : null
- else
- echo "Nor is it Venix..."
- fi
-fi
-chmod +x bsd usg v7 osf1 eunice xenix venix
-$eunicefix bsd usg v7 osf1 eunice xenix venix
-$rm -f foo
-
+++ /dev/null
-?RCS: $Id: Loc_sed.U,v $
-?RCS:
-?X: This is used in perl.c.
-?MAKE:full_sed: sed
-?MAKE: -pick add $@ %<
-?S:full_sed:
-?S: This variable contains the full pathname to 'sed', whether or
-?S: not the user has specified 'portability'. This is only used
-?S: in the compiled C program, and we assume that all systems which
-?S: can share this executable will have the same full pathname to
-?S: 'sed.'
-?S:.
-?X: Yes, I know about the C symbol PORTABLE, but I think sed
-?X: is unlikely to move, and I'm too lazy to add all the
-?X: #ifdef PORTABLE sections to the perl source.
-?X:
-?C:LOC_SED:
-?C: This symbol holds the complete pathname to the sed program.
-?C:.
-?H:#define LOC_SED "$full_sed" /**/
-?H:.
-?LINT:use sed
-?LINT:extern sed
-: Store the full pathname to the sed program for use in the C program
-full_sed=$sed
-
+++ /dev/null
-?RCS: $Id: Myinit.U,v 3.0 1993/08/18 12:05:07 ram Exp $
-?RCS:
-?RCS: Copyright (c) 1991-1993, Raphael Manfredi
-?RCS:
-?RCS: You may redistribute only under the terms of the Artistic Licence,
-?RCS: as specified in the README file that comes with the distribution.
-?RCS: You may reuse parts of this distribution only within the terms of
-?RCS: that same Artistic Licence; a copy of which may be found at the root
-?RCS: of the source tree for dist 3.0.
-?RCS:
-?RCS: $Log: Myinit.U,v $
-?RCS: Revision 3.0 1993/08/18 12:05:07 ram
-?RCS: Baseline for dist 3.0 netwide release.
-?RCS:
-?X:
-?X: If you want to initialize any default values, copy this unit to your
-?X: personal U directory and add the assignments to the end. This file
-?X: is included after variables are initialized but before any old
-?X: config.sh file is read in.
-?X:
-?MAKE:Myinit libswanted : Init
-?MAKE: -pick add $@ %<
-?S:libswanted:
-?S: This variable holds a list of all the libraries we want to
-?S: search. The order is chosen to pick up the c library
-?S: ahead of ucb or bsd libraries for SVR4.
-?S:.
-?LINT:extern usevfork glibpth d_portable
-?LINT:change usevfork glibpth d_portable
-: List of libraries we want.
-?X: Put crypt here, even though I should really fix d_crypt.U to look
-?X: for it correctly, including possible shared library versions.
-libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl'
-libswanted="$libswanted dld ld sun m c cposix posix ndir dir crypt"
-libswanted="$libswanted ucb bsd BSD PW x"
-: We probably want to search /usr/shlib before most other libraries.
-: This is only used by the lib/ExtUtils/MakeMaker.pm routine extliblist.
-glibpth=`echo " $glibpth " | sed -e 's! /usr/shlib ! !'`
-glibpth="/usr/shlib $glibpth"
-: Do not use vfork unless overridden by a hint file.
-usevfork=false
-: We might as well always be portable. It makes no difference for
-: perl5, and makes people happy.
-d_portable=define
-
+++ /dev/null
-?X: These units are based on the ones supplied with dist-3.0.
-?X: They have been changed or enhanced to work with perl.
-?X: I would appreciate hearing about any changes, corrections,
-?X: or enhancements.
-?X: Andy Dougherty doughera@lafcol.lafayette.edu
-?X: Dept. of Physics
-?X: Lafayette College
-?X: Easton, PA 18042-1782
-?X: Wed Nov 9 15:34:15 EST 1994
+++ /dev/null
-?RCS: $Id: ccflags.U,v 3.0.1.6 1994/10/29 16:07:02 ram Exp $
-?RCS:
-?RCS: Copyright (c) 1991-1993, Raphael Manfredi
-?RCS:
-?RCS: You may redistribute only under the terms of the Artistic Licence,
-?RCS: as specified in the README file that comes with the distribution.
-?RCS: You may reuse parts of this distribution only within the terms of
-?RCS: that same Artistic Licence; a copy of which may be found at the root
-?RCS: of the source tree for dist 3.0.
-?RCS:
-?RCS: This is the same as dist's ccflags unit except that perl uses
-?RCS: -DDEBUGGING rather than -DDEBUG, and I also suggest a few other
-?RCS: flags the user might set, such as -DCRIPPLED_CC and -D_POSIX_SOURCE.
-?RCS:
-?RCS: $Log: ccflags.U,v $
-?RCS: Revision 3.0.1.6 1994/10/29 16:07:02 ram
-?RCS: patch36: gcc versionning no longer relies on the C compiler's name
-?RCS: patch36: simplified check for gcc version checking (ADO)
-?RCS:
-?RCS: Revision 3.0.1.5 1994/08/29 16:06:35 ram
-?RCS: patch32: propagate -posix flag from ccflags to ldflags
-?RCS:
-?RCS: Revision 3.0.1.4 1994/05/06 14:28:45 ram
-?RCS: patch23: -fpcc-struct-return only needed in gcc 1.x (ADO)
-?RCS: patch23: cppflags now computed on an option-by-option basis
-?RCS: patch23: magically added cc flags now only done the first time
-?RCS:
-?RCS: Revision 3.0.1.3 1993/09/13 15:58:29 ram
-?RCS: patch10: explicitely mention -DDEBUG just in case they need it (WAD)
-?RCS: patch10: removed all the "tans" variable usage (WAD)
-?RCS:
-?RCS: Revision 3.0.1.2 1993/08/27 14:39:38 ram
-?RCS: patch7: added support for OSF/1 machines
-?RCS:
-?RCS: Revision 3.0.1.1 1993/08/25 14:00:24 ram
-?RCS: patch6: added defaults for cppflags, ccflags and ldflags
-?RCS:
-?RCS: Revision 3.0 1993/08/18 12:05:31 ram
-?RCS: Baseline for dist 3.0 netwide release.
-?RCS:
-?MAKE:ccflags ldflags lkflags cppflags optimize: test cat Myread Guess \
- Oldconfig +gccversion mips_type +usrinc package contains rm \
- cppstdin cppminus cpprun cpplast
-?MAKE: -pick add $@ %<
-?S:ccflags:
-?S: This variable contains any additional C compiler flags desired by
-?S: the user. It is up to the Makefile to use this.
-?S:.
-?S:cppflags:
-?S: This variable holds the flags that will be passed to the C pre-
-?S: processor. It is up to the Makefile to use it.
-?S:.
-?S:optimize:
-?S: This variable contains any optimizer/debugger flag that should be used.
-?S: It is up to the Makefile to use it.
-?S:.
-?S:ldflags:
-?S: This variable contains any additional C loader flags desired by
-?S: the user. It is up to the Makefile to use this.
-?S:.
-?S:lkflags:
-?S: This variable contains any additional C partial linker flags desired by
-?S: the user. It is up to the Makefile to use this.
-?S:.
-?T:inctest thisincl xxx flag inclwanted ftry previous
-?D:cppflags=''
-?D:ccflags=''
-?D:ldflags=''
-?INIT:: no include file wanted by default
-?INIT:inclwanted=''
-?INIT:
-: determine optimize, if desired, or use for debug flag also
-case "$optimize" in
-' ') dflt='none';;
-'') dflt='-O';;
-*) dflt="$optimize";;
-esac
-$cat <<EOH
-
-Some C compilers have problems with their optimizers, by default, $package
-compiles with the -O flag to use the optimizer. Alternately, you might want
-to use the symbolic debugger, which uses the -g flag (on traditional Unix
-systems). Either flag can be specified here. To use neither flag, specify
-the word "none".
-
-EOH
-rp="What optimizer/debugger flag should be used?"
-. ./myread
-optimize="$ans"
-case "$optimize" in
-'none') optimize=" ";;
-esac
-
-dflt=''
-case "$ccflags" in
-'')
- case "$gccversion" in
- 1*) dflt='-fpcc-struct-return' ;;
- esac
- case "$optimize" in
- *-g*) dflt="$dflt -DDEBUGGING";;
- esac
-?X: check for POSIXized ISC
- case "$gccversion" in
- 2*) if test -d /etc/conf/kconfig.d &&
- $contains _POSIX_VERSION $usrinc/sys/unistd.h >/dev/null 2>&1
- then
- dflt="$dflt -posix"
- fi
- ;;
- esac
- ;;
-esac
-
-?X: In USG mode, a MIPS system may need some BSD includes
-case "$mips_type" in
-*BSD*) ;;
-'') ;;
-*) inclwanted="$inclwanted $usrinc/bsd";;
-esac
-for thisincl in $inclwanted; do
- if $test -d $thisincl; then
- if $test x$thisincl != x$usrinc; then
- case "$dflt" in
- *$thisincl*);;
- *) dflt="$dflt -I$thisincl";;
- esac
- fi
- fi
-done
-
-?X: Include test function (header, symbol)
-inctest='if $contains $2 $usrinc/$1 >/dev/null 2>&1; then
- xxx=true;
-elif $contains $2 $usrinc/sys/$1 >/dev/null 2>&1; then
- xxx=true;
-else
- xxx=false;
-fi;
-if $xxx; then
- case "$dflt" in
- *$2*);;
- *) dflt="$dflt -D$2";;
- esac;
-fi'
-
-?X:
-?X: SCO unix uses NO_PROTOTYPE instead of _NO_PROTO
-?X: OSF/1 uses __LANGUAGE_C__ instead of LANGUAGE_C
-?X:
-if ./osf1; then
- set signal.h __LANGUAGE_C__; eval $inctest
-else
- set signal.h LANGUAGE_C; eval $inctest
-fi
-set signal.h NO_PROTOTYPE; eval $inctest
-set signal.h _NO_PROTO; eval $inctest
-
-case "$dflt" in
-'') dflt=none;;
-esac
-case "$ccflags" in
-'') ;;
-*) dflt="$ccflags";;
-esac
-$cat <<EOH
-
-Your C compiler may want other flags. For this question you should include
--I/whatever and -DWHATEVER flags and any other flags used by the C compiler,
-but you should NOT include libraries or ld flags like -lwhatever. If you
-want $package to honor its debug switch, you should include -DDEBUGGING here.
-Your C compiler might also need additional flags, such as -D_POSIX_SOURCE,
--DHIDEMYMALLOC or -DCRIPPLED_CC.
-
-To use no flags, specify the word "none".
-
-EOH
-?X: strip leading space
-set X $dflt
-shift
-dflt=${1+"$@"}
-rp="Any additional cc flags?"
-. ./myread
-case "$ans" in
-none) ccflags='';;
-*) ccflags="$ans";;
-esac
-
-: the following weeds options from ccflags that are of no interest to cpp
-cppflags="$ccflags"
-case "$gccversion" in
-1*) cppflags="$cppflags -D__GNUC__"
-esac
-case "$mips_type" in
-'');;
-*BSD*) cppflags="$cppflags -DSYSTYPE_BSD43";;
-esac
-case "$cppflags" in
-'');;
-*)
- echo " "
- echo "Let me guess what the preprocessor flags are..." >&4
- set X $cppflags
- shift
- cppflags=''
- $cat >cpp.c <<'EOM'
-#define BLURFL foo
-
-BLURFL xx LFRULB
-EOM
-?X:
-?X: For each cc flag, try it out with both cppstdin and cpprun, since the
-?X: first is almost surely a cc wrapper. We have to try both in case
-?X: of cc flags like '-Olimit 2900' that are actually two words...
-?X:
- previous=''
- for flag in $*
- do
- case "$flag" in
- -*) ftry="$flag";;
- *) ftry="$previous $flag";;
- esac
- if $cppstdin -DLFRULB=bar $ftry $cppminus <cpp.c \
- >cpp1.out 2>/dev/null && \
- $cpprun -DLFRULB=bar $ftry $cpplast <cpp.c \
- >cpp2.out 2>/dev/null && \
- $contains 'foo.*xx.*bar' cpp1.out >/dev/null 2>&1 && \
- $contains 'foo.*xx.*bar' cpp2.out >/dev/null 2>&1
- then
- cppflags="$cppflags $ftry"
- previous=''
- else
- previous="$flag"
- fi
- done
- set X $cppflags
- shift
- cppflags=${1+"$@"}
- case "$cppflags" in
- *-*) echo "They appear to be: $cppflags";;
- esac
- $rm -f cpp.c cpp?.out
- ;;
-esac
-
-: flags used in final linking phase
-case "$ldflags" in
-'') if ./venix; then
- dflt='-i -z'
- else
- dflt=''
- fi
- case "$ccflags" in
- *-posix*) dflt="$dflt -posix" ;;
- esac
- case "$dflt" in
- '') dflt='none' ;;
- esac
- ;;
-*) dflt="$ldflags";;
-esac
-echo " "
-rp="Any additional ld flags (NOT including libraries)?"
-. ./myread
-case "$ans" in
-none) ldflags='';;
-*) ldflags="$ans";;
-esac
-rmlist="$rmlist pdp11"
-
-@if lkflags
-: partial linking may need other flags
-case "$lkflags" in
-'') case "$ldflags" in
- '') dflt='none';;
- *) dflt="$ldflags";;
- esac;;
-*) dflt="$lkflags";;
-esac
-echo " "
-rp="Partial linking flags to be used (NOT including -r)?"
-. ./myread
-case "$ans" in
-none) lkflags='';;
-*) lkflags="$ans";;
-esac
-
-@end
+++ /dev/null
-?RCS: $Id: d_byacc.U $
-?RCS:
-?RCS: $Log: d_byacc.U,v $
-?RCS:
-?MAKE:d_byacc: byacc Setvar
-?MAKE: -pick add $@ %<
-?LINT:extern byacc
-?S:d_byacc:
-?S: This variable indicates whether byacc is available.
-?S: If the user has specified 'portability', then Makefile.SH
-?S: sees $byacc='byacc' whether or not the user actually has
-?S: byacc. This variable allows us to determine in a makefile
-?S: if we really have byacc.
-?S:.
-?X: We want byacc for perl because the perly.fixer script assumes it.
-?X: We need to patch up yacc-generated parsers to allow dynamic
-?X: allocation of the stack.
-?LINT:set d_byacc
-: Check if we really have byacc
-case "$byacc" in
-''|'byacc') val="$undef" ;;
-*) val="$define" ;;
-esac
-set d_byacc
-eval $setvar
-
+++ /dev/null
-?RCS: $Id: d_csh.U,v 3.0 1993/08/18 12:05:53 ram Exp $
-?RCS:
-?RCS: Copyright (c) 1991-1993, Raphael Manfredi
-?RCS:
-?RCS: You may redistribute only under the terms of the Artistic Licence,
-?RCS: as specified in the README file that comes with the distribution.
-?RCS: You may reuse parts of this distribution only within the terms of
-?RCS: that same Artistic Licence; a copy of which may be found at the root
-?RCS: of the source tree for dist 3.0.
-?RCS:
-?RCS: $Log: d_csh.U,v $
-?RCS: Revision 3.0 1993/08/18 12:05:53 ram
-?RCS: Baseline for dist 3.0 netwide release.
-?RCS:
-?MAKE:d_csh full_csh: csh Setvar
-?MAKE: -pick add $@ %<
-?LINT:extern csh
-?S:d_csh:
-?S: This variable conditionally defines the CSH symbol, which
-?S: indicates to the C program that the C-shell exists.
-?S:.
-?S:full_csh:
-?S: This variable contains the full pathname to 'csh', whether or
-?S: not the user has specified 'portability'. This is only used
-?S: in the compiled C program, and we assume that all systems whic
-?S: can share this executable will have the same full pathname to
-?S: 'csh.'
-?S:.
-?X: Yes, I know about the C symbol PORTABLE, but I think csh
-?X: is unlikely to move, and I'm too lazy to add all the
-?X: #ifdef PORTABLE sections to the perl source.
-?X:
-?C:CSH:
-?C: This symbol, if defined, indicates that the C-shell exists.
-?C: If defined, contains the full pathname of csh.
-?C:.
-?H:#$d_csh CSH "$full_csh" /**/
-?H:.
-?LINT:set d_csh
-: get csh whereabouts
-case "$csh" in
-'csh') val="$undef" ;;
-*) val="$define" ;;
-esac
-set d_csh
-eval $setvar
-full_csh=$csh
-
+++ /dev/null
-?RCS: $Id: d_dlsymun.U,v $
-?RCS:
-?RCS: $Log: d_dlsymun.U,v $
-?RCS:
-?MAKE:d_dlsymun: cat cc ccflags ldflags rm Setvar dlsrc i_dlfcn \
- cccdlflags ccdlflags lddlflags libs dlext
-?MAKE: -pick add $@ %<
-?X: This is specific to perl5.
-?S:d_dlsymun:
-?S: This variable conditionally defines DLSYM_NEEDS_UNDERSCORE, which
-?S: indicates that we need to prepend an underscore to the symbol
-?S: name before calling dlsym().
-?S:.
-?C:DLSYM_NEEDS_UNDERSCORE:
-?C: This symbol, if defined, indicates that we need to prepend an
-?C: underscore to the symbol name before calling dlsym(). This only
-?C: makes sense if you *have* dlsym, which we will presume is the
-?C: case if you're using dl_dlopen.xs.
-?C:.
-?H:#$d_dlsymun DLSYM_NEEDS_UNDERSCORE /* */
-?H:.
-?F: !fred
-?LINT:set d_dlsymun
-?T: xxx
-: Check if dlsym need a leading underscore
-echo " "
-val="$undef"
-
-case "$dlsrc" in
-dl_dlopen.xs)
- echo "Checking whether your dlsym() needs a leading underscore ..." >&4
- $cat >dyna.c <<'EOM'
-fred () { }
-EOM
-
-$cat >fred.c<<EOM
-
-#include <stdio.h>
-#$i_dlfcn I_DLFCN
-#ifdef I_DLFCN
-#include <dlfcn.h> /* the dynamic linker include file for Sunos/Solaris */
-#else
-#include <sys/types.h>
-#include <nlist.h>
-#include <link.h>
-#endif
-
-extern int fred() ;
-
-main()
-{
- void * handle ;
- void * symbol ;
-#ifndef RTLD_LAZY
- int mode = 1 ;
-#else
- int mode = RTLD_LAZY ;
-#endif
- handle = dlopen("./dyna.$dlext", mode) ;
- if (handle == NULL) {
- printf ("1\n") ;
- exit(0);
- }
- symbol = dlsym(handle, "fred") ;
- if (symbol == NULL) {
- /* try putting a leading underscore */
- symbol = dlsym(handle, "_fred") ;
- if (symbol == NULL) {
- printf ("2\n") ;
- exit(0);
- }
- printf ("3\n") ;
- }
- else
- printf ("4\n") ;
- exit(0);
-}
-EOM
- if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 &&
- ld $lddlflags -o dyna.$dlext dyna.o > /dev/null 2>&1 &&
- $cc $ccflags $ldflags $cccdlflags $ccdlflags fred.c -o fred $libs > /dev/null 2>&1; then
- xxx=`./fred`
- case $xxx in
- 1) echo "Test program failed using dlopen." >&4
- echo "Perhaps you should not use dynamic loading." >&4;;
- 2) echo "Test program failed using dlsym." >&4
- echo "Perhaps you should not use dynamic loading." >&4;;
- 3) echo "dlsym needs a leading underscore" >&4
- val="$define" ;;
- 4) echo "dlsym doesn't need a leading underscore." >&4;;
- esac
- else
- echo "I can't compile and run the test program." >&4
- fi
- ;;
-esac
-
-$rm -f fred fred.? dyna.$dlext dyna.?
-
-set d_dlsymun
-eval $setvar
-
+++ /dev/null
-?X: Deliberately empty file to fool metaconfig. I don't want
-?X: the standard d_group since it's useless. (I wrote it, so I know :-).
-?X:?RCS: $Id: d_group.U,v 3.0.1.1 1994/08/29 16:07:48 ram Exp $
+++ /dev/null
-?X: Deliberately empty file to fool metaconfig. I don't want
-?X: the standard d_passwd since it's useless. (I wrote it, so I know :-).
-?X:?RCS: $Id: d_passwd.U,v 3.0.1.1 1994/08/29 16:09:51 ram Exp $
+++ /dev/null
-This file contains patches to dist 3 (PL 51) that I used to generate
-Configure for perl.
-
-These patches do the following:
-
-Oldconfig.U
- Clean up and extend the $osvers detection for DEC OSF/1 on the Alpha.
- Add MachTen detection (requires adding awk to ?MAKE line).
-archname.U
- Protect against spaces in the output of uname -m.
-Inhdr.U
- Delete tabs that caused /bin/sh to core dump on Mach Ten 2.1.1.
-libc.U
- Pick up Linux nm output with leading __IO.
-sig_name.U
- Look in <linux/signals.h> too.
-usrinc.U
- Ensure that the ./mips file exists. libpth.U calls it.
-
- Andy Dougherty doughera@lafcol.lafayette.edu
- Dept. of Physics
- Lafayette College, Easton, PA 18042 USA
-
-Index: Inhdr.U
-Prereq: 3.0.1.1
-*** mcon/U/Inhdr.U Sat Oct 29 15:28:15 1994
---- /home2/doughera/lib/dist/U/Inhdr.U Wed Mar 8 15:52:13 1995
-***************
-*** 52,61 ****
- var=$2; eval "was=\$$2";
- if $test "$xxx" && $test -r "$xxx";
- then eval $xxf;
-! eval "case \"\$$var\" in $undef) . ./whoa; esac"; eval "$var=\$td";
- cont="";
- else eval $xxnf;
-! eval "case \"\$$var\" in $define) . ./whoa; esac"; eval "$var=\$tu"; fi;
- set $yyy; shift; shift; yyy=$@;
- case $# in 0) cont="";;
- 2) xxf="echo \"but I found <\$1> $instead.\" >&4";
---- 52,65 ----
- var=$2; eval "was=\$$2";
- if $test "$xxx" && $test -r "$xxx";
- then eval $xxf;
-! ?X: This line deliberately shifted left 1 tabstop to avoid /bin/sh core dump
-! ?X: on MachTen 2.1.1. --AD March 8, 1995
-! eval "case \"\$$var\" in $undef) . ./whoa; esac"; eval "$var=\$td";
- cont="";
- else eval $xxnf;
-! ?X: This line deliberately shifted left 1 tabstop to avoid /bin/sh core dump
-! ?X: on MachTen 2.1.1. --AD March 8, 1995
-! eval "case \"\$$var\" in $define) . ./whoa; esac"; eval "$var=\$tu"; fi;
- set $yyy; shift; shift; yyy=$@;
- case $# in 0) cont="";;
- 2) xxf="echo \"but I found <\$1> $instead.\" >&4";
-Index: Oldconfig.U
-Prereq: 3.0.1.7
-*** mcon/U/Oldconfig.U Thu Feb 16 09:52:38 1995
---- /home2/doughera/lib/dist/U/Oldconfig.U Fri Mar 10 09:43:30 1995
-***************
-*** 45,51 ****
- ?X: for the sake of setting defaults.
- ?X:
- ?MAKE:Oldconfig hint myuname osname osvers: Instruct Myread uname \
-! sed test cat rm lns n c contains Loc Options Tr
- ?MAKE: -pick wipe $@ %<
- ?S:myuname:
- ?S: The output of 'uname -a' if available, otherwise the hostname. On Xenix,
---- 45,51 ----
- ?X: for the sake of setting defaults.
- ?X:
- ?MAKE:Oldconfig hint myuname osname osvers: Instruct Myread uname \
-! awk sed test cat rm lns n c contains Loc Options Tr
- ?MAKE: -pick wipe $@ %<
- ?S:myuname:
- ?S: The output of 'uname -a' if available, otherwise the hostname. On Xenix,
-***************
-*** 150,155 ****
---- 150,158 ----
- $test -d /usr/apollo/bin && osname=apollo
- $test -f /etc/saf/_sactab && osname=svr4
- $test -d /usr/include/minix && osname=minix
-+ $test -d /MachTen && osname=machten && \
-+ osvers=`/usr/etc/version | $awk '{print $2}' | \
-+ $sed -e 's/[A-Za-z]$//'`
- ?X: If we have uname, we already computed a suitable uname -a output, correctly
- ?X: formatted for Xenix, and it lies in $myuname.
- if $test -f $uname; then
-***************
-*** 264,275 ****
- osvers="$3"
- ;;
- osf1) case "$5" in
-! alpha) osname=dec_osf
-! case "$3" in
-! [vt]1\.*) osvers=1 ;;
-! [vt]2\.*) osvers=2 ;;
-! [vt]3\.*) osvers=3 ;;
-! esac
- ;;
- hp*) osname=hp_osf1 ;;
- mips) osname=mips_osf1 ;;
---- 267,277 ----
- osvers="$3"
- ;;
- osf1) case "$5" in
-! alpha)
-! ?X: DEC OSF/1 myuname -a output looks like: osf1 xxxx t3.2 123.4 alpha
-! ?X: where the version number can be either vn.n or tn.n.
-! osname=dec_osf
-! osvers=`echo "$3" | sed 's/^[vt]//'`
- ;;
- hp*) osname=hp_osf1 ;;
- mips) osname=mips_osf1 ;;
-Index: archname.U
-Prereq: 3.0.1.1
-*** mcon/U/archname.U Thu Feb 16 09:52:31 1995
---- /home2/doughera/lib/dist/U/archname.U Mon Feb 27 15:24:22 1995
-***************
-*** 12,18 ****
- ?RCS: Revision 3.0.1.1 1995/02/15 14:14:21 ram
- ?RCS: patch51: created
- ?RCS:
-! ?MAKE:archname myarchname: cat Loc Myread Oldconfig osname test rm
- ?MAKE: -pick add $@ %<
- ?S:archname:
- ?S: This variable is a short name to characterize the current
---- 12,18 ----
- ?RCS: Revision 3.0.1.1 1995/02/15 14:14:21 ram
- ?RCS: patch51: created
- ?RCS:
-! ?MAKE:archname myarchname: sed Loc Myread Oldconfig osname test rm
- ?MAKE: -pick add $@ %<
- ?S:archname:
- ?S: This variable is a short name to characterize the current
-***************
-*** 43,49 ****
- tarch=`arch`"-$osname"
- elif xxx=`./loc uname blurfl $pth`; $test -f "$xxx" ; then
- if uname -m > tmparch 2>&1 ; then
-! tarch=`$cat tmparch`"-$osname"
- else
- tarch="$osname"
- fi
---- 43,49 ----
- tarch=`arch`"-$osname"
- elif xxx=`./loc uname blurfl $pth`; $test -f "$xxx" ; then
- if uname -m > tmparch 2>&1 ; then
-! tarch=`$sed -e 's/ /_/g' -e 's/$/'"-$osname/" tmparch`
- else
- tarch="$osname"
- fi
-Index: libc.U
-Prereq: 3.0.1.7
-*** mcon/U/libc.U Sat Oct 29 15:28:06 1994
---- /home2/doughera/lib/dist/U/libc.U Mon Mar 6 10:34:07 1995
-***************
-*** 218,224 ****
- xscan='eval "<libc.ptf $com >libc.list"; $echo $n ".$c" >&4'
- xrun='eval "<libc.tmp $com >libc.list"; echo "done" >&4'
- ?X: BSD-like output, I-type for Linux
-! if com="$sed -n -e 's/^.* [ADTSI] *_[_.]*//p' -e 's/^.* [ADTSI] //p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
---- 218,225 ----
- xscan='eval "<libc.ptf $com >libc.list"; $echo $n ".$c" >&4'
- xrun='eval "<libc.tmp $com >libc.list"; echo "done" >&4'
- ?X: BSD-like output, I-type for Linux
-! ?X: Some versions of Linux include a leading __IO in the symbol name.
-! if com="$sed -n -e 's/__IO//' -e 's/^.* [ADTSI] *_[_.]*//p' -e 's/^.* [ADTSI] //p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-***************
-*** 263,269 ****
- eval $xrun
- else
- nm -p $* 2>/dev/null >libc.tmp
-! com="$sed -n -e 's/^.* [ADTS] *_[_.]*//p' -e 's/^.* [ADTS] //p'";\
- eval "<libc.tmp $com >libc.list"
- if $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- nm_opt='-p'
---- 264,270 ----
- eval $xrun
- else
- nm -p $* 2>/dev/null >libc.tmp
-! com="$sed -n -e 's/^.* [ADTSI] *_[_.]*//p' -e 's/^.* [ADTSI] //p'";\
- eval "<libc.tmp $com >libc.list"
- if $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- nm_opt='-p'
-Index: sig_name.U
-Prereq: 3.0.1.2
-*** mcon/U/sig_name.U Wed Jun 22 01:20:22 1994
---- /home2/doughera/lib/dist/U/sig_name.U Mon Feb 27 14:54:05 1995
-***************
-*** 40,46 ****
- case "$sig_name" in
- '')
- echo "Generating a list of signal names..." >&4
-! xxx=`./findhdr signal.h`" "`./findhdr sys/signal.h`
- set X `cat $xxx 2>&1 | $awk '
- $1 ~ /^#define$/ && $2 ~ /^SIG[A-Z0-9]*$/ && $3 ~ /^[1-9][0-9]*$/ {
- sig[$3] = substr($2,4,20)
---- 40,46 ----
- case "$sig_name" in
- '')
- echo "Generating a list of signal names..." >&4
-! xxx=`./findhdr signal.h`" "`./findhdr sys/signal.h`" "`./findhdr linux/signal.h`
- set X `cat $xxx 2>&1 | $awk '
- $1 ~ /^#define$/ && $2 ~ /^SIG[A-Z0-9]*$/ && $3 ~ /^[1-9][0-9]*$/ {
- sig[$3] = substr($2,4,20)
-Index: usrinc.U
-Prereq: 3.0.1.1
-*** mcon/U/usrinc.U Sun May 8 22:14:36 1994
---- /home2/doughera/lib/dist/U/usrinc.U Tue Feb 21 11:00:10 1995
-***************
-*** 60,71 ****
- fi
- $rm -f usr.c usr.out
- echo "and you're compiling with the $mips_type compiler and libraries."
- else
- echo "Doesn't look like a MIPS system."
- echo "exit 1" >mips
-- chmod +x mips
-- $eunicefix mips
- fi
- echo " "
- case "$usrinc" in
- '') ;;
---- 60,72 ----
- fi
- $rm -f usr.c usr.out
- echo "and you're compiling with the $mips_type compiler and libraries."
-+ echo "exit 0" >mips
- else
- echo "Doesn't look like a MIPS system."
- echo "exit 1" >mips
- fi
-+ chmod +x mips
-+ $eunicefix mips
- echo " "
- case "$usrinc" in
- '') ;;
+++ /dev/null
-?RCS: $Id: dlsrc.U,v$
-?RCS:
-?RCS: You may redistribute only under the terms of the Artistic Licence,
-?RCS: as specified in the README file that comes with the distribution.
-?RCS: You may reuse parts of this distribution only within the terms of
-?RCS: that same Artistic Licence; a copy of which may be found at the root
-?RCS: of the source tree for dist 3.0.
-?RCS:
-?RCS: $Log: dlsrc.U,v $
-?RCS:
-?X: hpux support thanks to Jeff Okamoto <okamoto@hpcc101.corp.hp.com>
-?X:
-?X: To create a shared library, you must compile ALL source files in the
-?X: library with +z (or possibly +Z if the library is whopping huge),
-?X: then link the library with -b. Example:
-?X: cc -c +z module_a.c
-?X: cc -c +z module_b.c
-?X: ld -b module_a.o module_b.o -o module.sl
-?X:
-?MAKE:dlext: \
- Getfile Myread cat usedl so
-?MAKE: -pick add $@ %<
-?S:dlext:
-?S: This variable contains the extension that is to be used for the
-?S: dynamically loaded modules that perl generaties.
-?S:.
-case "$usedl" in
-$define|y|true)
- $cat << EOM
-
-On a few systems, the dynamically loaded modules that perl generates and uses
-will need a different extension then shared libs. The default will probably
-be appropriate.
-
-EOM
- case "$dlext" in
- '') dflt="$so" ;;
- *) dflt="$dlext" ;;
- esac
- rp='What is the extension of dynamically loaded modules'
- . ./myread
- dlext="$ans"
- ;;
-*)
- dlext="none"
- ;;
-esac
-
+++ /dev/null
-?RCS: $Id: dlsrc.U,v$
-?RCS:
-?RCS: You may redistribute only under the terms of the Artistic Licence,
-?RCS: as specified in the README file that comes with the distribution.
-?RCS: You may reuse parts of this distribution only within the terms of
-?RCS: that same Artistic Licence; a copy of which may be found at the root
-?RCS: of the source tree for dist 3.0.
-?RCS:
-?RCS: $Log: dlsrc.U,v $
-?RCS:
-?X: hpux support thanks to Jeff Okamoto <okamoto@hpcc101.corp.hp.com>
-?X:
-?X: To create a shared library, you must compile ALL source files in the
-?X: library with +z (or possibly +Z if the library is whopping huge),
-?X: then link the library with -b. Example:
-?X: cc -c +z module_a.c
-?X: cc -c +z module_b.c
-?X: ld -b module_a.o module_b.o -o module.sl
-?X:
-?MAKE:usedl dlsrc cccdlflags lddlflags ccdlflags d_shrplib shrpdir: \
- Getfile Myread test osname sed i_dld d_dlopen Findhdr Setvar \
- cc ldflags cat archlib
-?MAKE: -pick add $@ %<
-?S:usedl:
-?S: This variable indicates if the the system supports dynamic
-?S: loading of some sort. See also dlsrc and dlobj.
-?S:.
-?S:dlsrc:
-?S: This variable contains the name of the dynamic loading file that
-?S: will be used with the package.
-?S:.
-?S:cccdlflags:
-?S: This variable contains any special flags that might need to be
-?S: passed with cc -c to compile modules to be used to create a shared
-?S: library that will be used for dynamic loading. For hpux, this
-?S: should be +z. It is up to the makefile to use it.
-?S:.
-?S:lddlflags:
-?S: This variable contains any special flags that might need to be
-?S: passed to ld to create a shared library suitable for dynamic
-?S: loading. It is up to the makefile to use it. For hpux, it
-?S: should be -b. For sunos 4.1, it is empty.
-?S:.
-?S:ccdlflags:
-?S: This variable contains any special flags that might need to be
-?S: passed to cc to link with a shared library for dynamic loading.
-?S: It is up to the makefile to use it. For sunos 4.1, it should
-?S: be empty.
-?S:.
-?S:d_shrplib:
-?S: This variable indicates whether libperl should be made as a
-?S: shared library. This must be true for dynamic loading to
-?S: work on (some) System V Release 4 systems.
-?S:.
-?S:shrpdir:
-?S: This variable contains the directory where the libperl shared
-?S: library will be installed. LD_RUN_PATH is set to this when
-?S: linking with libperl (unless it is /usr/lib, the default).
-?S:.
-?C:USE_DYNAMIC_LOADING ~ %<:
-?C: This symbol, if defined, indicates that dynamic loading of
-?C: some sort is available.
-?C:.
-?H:?%<:#$usedl USE_DYNAMIC_LOADING /**/
-?H:.
-?W:%<:dlopen
-?LINT: set d_shrplib shrpdir
-?T:dldir
-: determine which dynamic loading, if any, to compile in
-echo " "
-dldir="ext/DynaLoader"
-case "$usedl" in
-$define|y|true)
- dflt='y'
- usedl="$define"
- ;;
-$undef|n|false)
- dflt='n'
- usedl="$undef"
- ;;
-*)
- dflt='n'
- case "$d_dlopen" in
- $define) dflt='y' ;;
- esac
- case "$i_dld" in
- $define) dflt='y' ;;
- esac
- : Does a dl_xxx.xs file exist for this operating system
- $test -f ../$dldir/dl_${osname}.xs && dflt='y'
- ;;
-esac
-rp="Do you wish to use dynamic loading?"
-. ./myread
-usedl="$ans"
-case "$ans" in
-y*) usedl="$define"
- case "$dlsrc" in
- '')
- if $test -f ../$dldir/dl_${osname}.xs ; then
- dflt="$dldir/dl_${osname}.xs"
- elif $test "$d_dlopen" = "$define" ; then
- dflt="$dldir/dl_dlopen.xs"
- elif $test "$i_dld" = "$define" ; then
- dflt="$dldir/dl_dld.xs"
- else
- dflt=''
- fi
- ;;
- *) dflt="$dldir/$dlsrc"
- ;;
- esac
- echo "The following dynamic loading files are available:"
- : Can not go over to $dldir because getfile has path hard-coded in.
- cd ..; ls -C $dldir/dl*.xs; cd UU
- rp="Source file to use for dynamic loading"
- fn="fne"
- . ./getfile
- usedl="$define"
- : emulate basename
- dlsrc=`echo $ans | $sed -e 's@.*/\([^/]*\)$@\1@'`
- $cat << EOM
-
-Some systems may require passing special flags to $cc -c to
-compile modules that will be used to create a shared library.
-To use no flags, say "none".
-
-EOM
- case "$cccdlflags" in
- ''|' ') case "$cc" in
- *gcc*) dflt='-fpic' ;;
- *) case "$osname" in
- hpux) dflt='+z' ;;
- next) dflt='none' ;;
- solaris) dflt='-K pic' ;;
- sunos) dflt='-pic' ;;
- svr4*|esix*) dflt='-Kpic' ;;
- *) dflt='none' ;;
- esac ;;
- esac ;;
- *) dflt="$cccdlflags" ;;
- esac
- rp="Any special flags to pass to $cc -c to compile shared library modules?"
- . ./myread
- case "$ans" in
- none) cccdlflags='' ;;
- *) cccdlflags="$ans" ;;
- esac
-
- cat << 'EOM'
-
-Some systems may require passing special flags to ld to create a
-library that can be dynamically loaded. If your ld flags include
--L/other/path options to locate libraries outside your loader's normal
-search path, you may need to specify those -L options here as well. To
-use no flags, say "none".
-
-EOM
-?X: I have received one report that NeXT requires -r here.
-?X: On SunOS 4.1.3, that makes the library no longer shared.
-?X: This stuff probably all belongs in hints files anyway.
- case "$lddlflags" in
- ''|' ') case "$osname" in
- hpux) dflt='-b' ;;
- next) dflt='none' ;;
- solaris) dflt='-G' ;;
- sunos) dflt='-assert nodefinitions' ;;
- svr4*|esix*) dflt="-G $ldflags" ;;
- *) dflt='none' ;;
- esac
- ;;
- *) dflt="$lddlflags" ;;
- esac
- rp="Any special flags to pass to ld to create a dynamically loaded library?"
- . ./myread
- case "$ans" in
- none) lddlflags='' ;;
- *) lddlflags="$ans" ;;
- esac
-
- cat <<EOM
-
-Some systems may require passing special flags to $cc to indicate that
-the resulting executable will use dynamic linking. To use no flags,
-say "none".
-
-EOM
- case "$ccdlflags" in
- ''|' ') case "$osname" in
- hpux) dflt='none' ;;
- next) dflt='none' ;;
- sunos) dflt='none' ;;
- *) dflt='none' ;;
- esac ;;
- *) dflt="$ccdlflags" ;;
- esac
- rp="Any special flags to pass to $cc to use dynamic loading?"
- . ./myread
- case "$ans" in
- none) ccdlflags='' ;;
- *) ccdlflags="$ans" ;;
- esac
- ;;
-?X: End of usedl=y section
-*) usedl="$undef"
- dlsrc='dl_none.xs'
- lddlflags=''
- ccdlflags=''
- ;;
-esac
-
-?X: Currently libperl is only created as a shared library if
-?X: using dynamic loading on a SysVR4 system. Feel free to
-?X: add prompts here to allow the user to choose a shared
-?X: libperl in other cases.
-val="$undef"
-case "$osname" in
-esix*|svr4*)
- case "$usedl" in
- $define)
- $cat <<EOM
-
-System V Release 4 systems can support dynamic loading
-only if libperl is created as a shared library.
-
-EOM
- val="$define"
- ;;
- esac ;;
-esac
-set d_shrplib; eval $setvar
-case "$d_shrplib" in
-$define)
- cat <<EOM >&4
-
-Be sure to add the perl source directory to the LD_LIBRARY_PATH
-environment variable before running make:
- LD_LIBRARY_PATH=`cd ..;pwd`; export LD_LIBRARY_PATH
-or
- setenv LD_LIBRARY_PATH `cd ..;pwd`
-
-EOM
-;;
-esac
-case "$d_shrplib" in
-$define)
- case "$shrpdir" in
- "") dflt="$archlib/CORE";;
- *) dflt="$shrpdir";;
- esac
- rp="What directory should we install the shared libperl into?"
- fn="d~"
- . ./getfile
- shrpdir="$ans"
- ;;
-*) shrpdir='none'
- ;;
-esac
-
+++ /dev/null
-?RCS: $Id: i_db.U,v 3.0.1.1 1994/08/29 16:21:50 ram Exp $
-?RCS:
-?RCS: Copyright (c) 1991-1993, Raphael Manfredi
-?RCS:
-?RCS: You may redistribute only under the terms of the Artistic Licence,
-?RCS: as specified in the README file that comes with the distribution.
-?RCS: You may reuse parts of this distribution only within the terms of
-?RCS: that same Artistic Licence; a copy of which may be found at the root
-?RCS: of the source tree for dist 3.0.
-?RCS:
-?RCS: Original Author: Andy Dougherty <doughera@lafcol.lafayette.edu>
-?RCS:
-?RCS: $Log: i_db.U,v $
-?RCS: Revision 3.0.1.1 1994/08/29 16:21:50 ram
-?RCS: patch32: created by ADO
-?RCS:
-?MAKE:i_db db_hashtype db_prefixtype: Inhdr +cc +ccflags rm contains
-?MAKE: -pick add $@ %<
-?S:i_db:
-?S: This variable conditionally defines the I_DB symbol, and indicates
-?S: whether a C program may include Berkeley's DB include file <db.h>.
-?S:.
-?S:db_hashtype:
-?S: This variable contains the type of the hash structure element
-?S: in the <db.h> header file. In older versions of DB, it was
-?S: int, while in newer ones it is u_int32_t.
-?S:.
-?S:db_prefixtype:
-?S: This variable contains the type of the prefix structure element
-?S: in the <db.h> header file. In older versions of DB, it was
-?S: int, while in newer ones it is size_t.
-?S:.
-?C:I_DB:
-?C: This symbol, if defined, indicates to the C program that it should
-?C: include Berkeley's DB include file <db.h>.
-?C:.
-?C:DB_Prefix_t:
-?C: This symbol contains the type of the prefix structure element
-?C: in the <db.h> header file. In older versions of DB, it was
-?C: int, while in newer ones it is u_int32_t.
-?C:.
-?C:DB_Hash_t:
-?C: This symbol contains the type of the prefix structure element
-?C: in the <db.h> header file. In older versions of DB, it was
-?C: int, while in newer ones it is size_t.
-?C:.
-?H:#$i_db I_DB /**/
-?H:#define DB_Hash_t $db_hashtype /**/
-?H:#define DB_Prefix_t $db_prefixtype /**/
-?H:.
-?F:!try.c !try.o
-?LINT:set i_db
-: see if this is a db.h system
-set db.h i_db
-eval $inhdr
-
-@if DB_Hash_t
-case "$i_db" in
-define)
- : Check the return type needed for hash
- echo "Checking return type needed for hash for Berkeley DB ..." >&4
- cat >try.c <<'EOCP'
-#include <sys/types.h>
-#include <db.h>
-u_int32_t
-hash_cb (ptr, size)
-const void * ptr ;
-size_t size ;
-{
-}
-HASHINFO info ;
-main()
-{
- info.hash = hash_cb ;
-}
-EOCP
- if $cc $ccflags -c try.c >try.out 2>&1 ; then
- if $contains warning try.out >>/dev/null 2>&1 ; then
- db_hashtype='int'
- else
- db_hashtype='u_int32_t'
- fi
- else
- echo "I can't seem to compile the test program." >&4
- db_hashtype=int
- fi
- $rm -f try.[co]
- echo "Your version of Berkeley DB uses $db_hashtype for hash."
- ;;
-*) db_hashtype=int
- ;;
-esac
-@end
-
-@if DB_Prefix_t
-case "$i_db" in
-define)
- : Check the return type needed for prefix
- echo "Checking return type needed for prefix for Berkeley DB ..." >&4
- cat >try.c <<'EOCP'
-#include <sys/types.h>
-#include <db.h>
-size_t
-prefix_cb (key1, key2)
-const DBT * key1 ;
-const DBT * key2 ;
-{
-}
-BTREEINFO info ;
-main()
-{
- info.prefix = prefix_cb ;
-}
-EOCP
- if $cc $ccflags -c try.c >try.out 2>&1 ; then
- if $contains warning try.out >>/dev/null 2>&1 ; then
- db_prefixtype='int'
- else
- db_prefixtype='size_t'
- fi
- else
- echo "I can't seem to compile the test program." >&4
- db_prefixtype='int'
- fi
- $rm -f try.[co]
- echo "Your version of Berkeley DB uses $db_prefixtype for prefix."
- ;;
-*) db_prefixtype='int'
- ;;
-esac
-@end
-
+++ /dev/null
-?RCS: $Id: i_dbm.U,v 3.0 1993/08/18 12:08:19 ram Exp $
-?RCS:
-?RCS: Copyright (c) 1991-1993, Raphael Manfredi
-?RCS:
-?RCS: You may redistribute only under the terms of the Artistic Licence,
-?RCS: as specified in the README file that comes with the distribution.
-?RCS: You may reuse parts of this distribution only within the terms of
-?RCS: that same Artistic Licence; a copy of which may be found at the root
-?RCS: of the source tree for dist 3.0.
-?RCS:
-?RCS: $Log: i_dbm.U,v $
-?RCS: Revision 3.0 1993/08/18 12:08:19 ram
-?RCS: Baseline for dist 3.0 netwide release.
-?RCS:
-?MAKE:i_dbm: Inhdr Inlibc Setvar
-?MAKE: -pick add $@ %<
-?S:i_dbm (d_odbm):
-?S: This variable conditionally defines the I_DBM symbol, which
-?S: indicates to the C program that dbm.h exists and should
-?S: be included.
-?S:.
-?C:I_DBM (HAS_ODBM ODBM):
-?C: This symbol, if defined, indicates that dbm.h exists and should
-?C: be included.
-?C:.
-?H:#$i_dbm I_DBM /**/
-?H:.
-?T: t_dbm d_dbmclose
-?LINT:set i_dbm
-: see if dbm.h is available
-?X: t_dbm is a tentative check. We might just have the header, not
-?X: the library. We look for dbmclose() rather than dbminit() because
-?X: some versions of SCO Unix have -ldbm, but are missing dbmclose().
-set dbm.h t_dbm
-eval $inhdr
-case "$t_dbm" in
-$define)
- : see if dbmclose exists
- set dbmclose d_dbmclose
- eval $inlibc
- case "$d_dbmclose" in
- $undef)
- t_dbm="$undef"
- echo "We won't be including <dbm.h>"
- ;;
- esac
- ;;
-esac
-val="$t_dbm"
-set i_dbm
-eval $setvar
-
+++ /dev/null
-?RCS: $Id: i_gdbm.U,v 3.0 1993/08/18 12:08:19 ram Exp $
-?RCS:
-?RCS: Copyright (c) 1991-1993, Raphael Manfredi
-?RCS:
-?RCS: You may redistribute only under the terms of the Artistic Licence,
-?RCS: as specified in the README file that comes with the distribution.
-?RCS: You may reuse parts of this distribution only within the terms of
-?RCS: that same Artistic Licence; a copy of which may be found at the root
-?RCS: of the source tree for dist 3.0.
-?RCS:
-?RCS: $Log: i_gdbm.U,v $
-?RCS: Revision 3.0 1993/08/18 12:08:19 ram
-?RCS: Baseline for dist 3.0 netwide release.
-?RCS:
-?MAKE:i_gdbm: Inhdr Inlibc Setvar
-?MAKE: -pick add $@ %<
-?S:i_gdbm (d_gdbm):
-?S: This variable conditionally defines the I_GDBM symbol, which
-?S: indicates to the C program that gdbm.h exists and should
-?S: be included.
-?S:.
-?C:I_GDBM (HAS_GDBM):
-?C: This symbol, if defined, indicates that gdbm.h exists and should
-?C: be included.
-?C:.
-?H:#$i_gdbm I_GDBM /**/
-?H:.
-?T: t_gdbm d_gdbm_open
-?LINT:set i_gdbm
-: see if gdbm.h is available
-?X: t_gdbm is a tentative check. We might just have the header, not
-?X: the library.
-set gdbm.h t_gdbm
-eval $inhdr
-case "$t_gdbm" in
-$define)
- : see if gdbm_open exists
- set gdbm_open d_gdbm_open
- eval $inlibc
- case "$d_gdbm_open" in
- $undef)
- t_gdbm="$undef"
- echo "We won't be including <gdbm.h>"
- ;;
- esac
- ;;
-esac
-val="$t_gdbm"
-set i_gdbm
-eval $setvar
-
+++ /dev/null
-?RCS: $Id: i_ndbm.U,v 3.0 1993/08/18 12:08:19 ram Exp $
-?RCS:
-?RCS: Copyright (c) 1991-1993, Raphael Manfredi
-?RCS:
-?RCS: You may redistribute only under the terms of the Artistic Licence,
-?RCS: as specified in the README file that comes with the distribution.
-?RCS: You may reuse parts of this distribution only within the terms of
-?RCS: that same Artistic Licence; a copy of which may be found at the root
-?RCS: of the source tree for dist 3.0.
-?RCS:
-?RCS: $Log: i_ndbm.U,v $
-?RCS: Revision 3.0 1993/08/18 12:08:19 ram
-?RCS: Baseline for dist 3.0 netwide release.
-?RCS:
-?MAKE:i_ndbm: Inhdr Inlibc Setvar
-?MAKE: -pick add $@ %<
-?S:i_ndbm (d_ndbm):
-?S: This variable conditionally defines the I_NDBM symbol, which
-?S: indicates to the C program that ndbm.h exists and should
-?S: be included.
-?S:.
-?C:I_NDBM (HAS_NDBM NDBM):
-?C: This symbol, if defined, indicates that ndbm.h exists and should
-?C: be included.
-?C:.
-?H:#$i_ndbm I_NDBM /**/
-?H:.
-?T: t_ndbm d_dbm_open
-?LINT:set i_ndbm
-: see if ndbm.h is available
-?X: t_ndbm is a tentative check. We might just have the header, not
-?X: the library.
-set ndbm.h t_ndbm
-eval $inhdr
-case "$t_ndbm" in
-$define)
- : see if dbm_open exists
- set dbm_open d_dbm_open
- eval $inlibc
- case "$d_dbm_open" in
- $undef)
- t_ndbm="$undef"
- echo "We won't be including <ndbm.h>"
- ;;
- esac
- ;;
-esac
-val="$t_ndbm"
-set i_ndbm
-eval $setvar
-
+++ /dev/null
-?RCS: $Id: i_sysstat.U,v $
-?RCS:
-?RCS: $Log: i_sysstat.U,v $
-?RCS:
-?MAKE:i_sysstat: Inhdr
-?MAKE: -pick add $@ %<
-?S:i_sysstat:
-?S: This variable conditionally defines the I_SYS_STAT symbol,
-?S: and indicates whether a C program should include <sys/stat.h>.
-?S:.
-?C:I_SYS_STAT (I_SYSSTAT):
-?C: This symbol, if defined, indicates to the C program that it should
-?C: include <sys/stat.h>.
-?C:.
-?H:#$i_sysstat I_SYS_STAT /**/
-?H:.
-?LINT:set i_sysstat
-: see if sys/stat.h is available
-set sys/stat.h i_sysstat
-eval $inhdr
-
+++ /dev/null
-?RCS: $Id: mallocsrc.U,v 3.0.1.1 1994/05/06 15:10:46 ram Exp $
-?RCS:
-?RCS: Copyright (c) 1991-1993, Raphael Manfredi
-?RCS:
-?RCS: You may redistribute only under the terms of the Artistic Licence,
-?RCS: as specified in the README file that comes with the distribution.
-?RCS: You may reuse parts of this distribution only within the terms of
-?RCS: that same Artistic Licence; a copy of which may be found at the root
-?RCS: of the source tree for dist 3.0.
-?RCS:
-?RCS: $Log: mallocsrc.U,v $
-?RCS: Revision 3.0.1.1 1994/05/06 15:10:46 ram
-?RCS: patch23: added support for MYMALLOC, mainly for perl5 (ADO)
-?RCS:
-?RCS: Revision 3.0 1993/08/18 12:09:12 ram
-?RCS: Baseline for dist 3.0 netwide release.
-?RCS:
-?MAKE:mallocsrc mallocobj usemymalloc malloctype d_mymalloc \
- freetype: Myread \
- Oldconfig package Guess Setvar rm cat +cc +ccflags Findhdr \
- i_malloc i_stdlib sed libs
-?MAKE: -pick add $@ %<
-?S:usemymalloc:
-?S: This variable contains y if the malloc that comes with this package
-?S: is desired over the system's version of malloc. People often include
-?S: special versions of malloc for effiency, but such versions are often
-?S: less portable. See also mallocsrc and mallocobj.
-?S: If this is 'y', then -lmalloc is removed from $libs.
-?S:.
-?S:mallocsrc:
-?S: This variable contains the name of the malloc.c that comes with
-?S: the package, if that malloc.c is preferred over the system malloc.
-?S: Otherwise the value is null. This variable is intended for generating
-?S: Makefiles.
-?S:.
-?S:d_mymalloc:
-?S: This variable conditionally defines MYMALLOC in case other parts
-?S: of the source want to take special action if MYMALLOC is used.
-?S: This may include different sorts of profiling or error detection.
-?S:.
-?S:mallocobj:
-?S: This variable contains the name of the malloc.o that this package
-?S: generates, if that malloc.o is preferred over the system malloc.
-?S: Otherwise the value is null. This variable is intended for generating
-?S: Makefiles. See mallocsrc.
-?S:.
-?S:freetype:
-?S: This variable contains the return type of free(). It is usually
-?S: void, but occasionally int.
-?S:.
-?S:malloctype:
-?S: This variable contains the kind of ptr returned by malloc and realloc.
-?S:.
-?C:Free_t:
-?C: This variable contains the return type of free(). It is usually
-?C: void, but occasionally int.
-?C:.
-?C:Malloc_t (MALLOCPTRTYPE):
-?C: This symbol is the type of pointer returned by malloc and realloc.
-?C:.
-?H:#define Malloc_t $malloctype /**/
-?H:#define Free_t $freetype /**/
-?H:.
-?C:MYMALLOC:
-?C: This symbol, if defined, indicates that we're using our own malloc.
-?C:.
-?H:#$d_mymalloc MYMALLOC /**/
-?H:.
-?LINT:change libs
-?X: Cannot test for mallocsrc; it is the unit's name and there is a bug in
-?X: the interpreter which defines all the names, even though they are not used.
-@if mallocobj
-: determine which malloc to compile in
-echo " "
-case "$usemymalloc" in
-''|y*|true) dflt='y' ;;
-n*|false) dflt='n' ;;
-*) dflt="$usemymalloc" ;;
-esac
-rp="Do you wish to attempt to use the malloc that comes with $package?"
-. ./myread
-usemymalloc="$ans"
-case "$ans" in
-y*|true)
- usemymalloc='y'
- mallocsrc='malloc.c'
- mallocobj='malloc.o'
- d_mymalloc="$define"
-?X: Maybe libs.U should be dependent on mallocsrc.U, but then
-?X: most packages that use dist probably don't supply their own
-?X: malloc, so this is probably an o.k. comprpomise
- case "$libs" in
- *-lmalloc*)
- : Remove malloc from list of libraries to use
- echo "Removing unneeded -lmalloc from library list" >&4
- set `echo X $libs | $sed -e 's/-lmalloc / /' -e 's/-lmalloc$//'`
- shift
- libs="$*"
- echo "libs = $libs" >&4
- ;;
- esac
- ;;
-*)
- usemymalloc='n'
- mallocsrc=''
- mallocobj=''
- d_mymalloc="$undef"
- ;;
-esac
-
-@end
-@if MALLOCPTRTYPE || Malloc_t || Free_t
-: compute the return types of malloc and free
-echo " "
-$cat >malloc.c <<END
-#$i_malloc I_MALLOC
-#$i_stdlib I_STDLIB
-#include <stdio.h>
-#include <sys/types.h>
-#ifdef I_MALLOC
-#include <malloc.h>
-#endif
-#ifdef I_STDLIB
-#include <stdlib.h>
-#endif
-#ifdef TRY_MALLOC
-void *malloc();
-#endif
-#ifdef TRY_FREE
-void free();
-#endif
-END
-@if MALLOCPTRTYPE || Malloc_t
-case "$malloctype" in
-'')
- if $cc $ccflags -c -DTRY_MALLOC malloc.c >/dev/null 2>&1; then
- malloctype='void *'
- else
- malloctype='char *'
- fi
- ;;
-esac
-echo "Your system wants malloc to return '$malloctype', it would seem." >&4
-@end
-
-@if Free_t
-case "$freetype" in
-'')
- if $cc $ccflags -c -DTRY_FREE malloc.c >/dev/null 2>&1; then
- freetype='void'
- else
- freetype='int'
- fi
- ;;
-esac
-echo "Your system uses $freetype free(), it would seem." >&4
-@end
-$rm -f malloc.[co]
-@end
#define XSRETURN(off) stack_sp = stack_base + ax + ((off) - 1); return
-#define XSRETURNNO ST(0)=sv_mortalcopy(&sv_no); XSRETURN(1)
-#define XSRETURNYES ST(0)=sv_mortalcopy(&sv_yes); XSRETURN(1)
-#define XSRETURNUNDEF ST(0)=sv_mortalcopy(&sv_undef); XSRETURN(1)
+/* Simple macros to put new mortal values onto the stack. */
+/* Typically used to return values from XS functions. */
+#define XST_mIV(i,v) ST(i)=sv_2mortal(newSViv(v));
+#define XST_mNV(i,v) ST(i)=sv_2mortal(newSVnv(v));
+#define XST_mPV(i,v) ST(i)=sv_2mortal(newSVpv(v,0));
+#define XST_mNO(i) ST(i)=sv_mortalcopy(&sv_no);
+#define XST_mYES(i) ST(i)=sv_mortalcopy(&sv_yes);
+#define XST_mUNDEF(i) ST(i)=sv_newmortal();
+
+#define XSRETURN_IV(v) XST_mIV(0,v); XSRETURN(1)
+#define XSRETURN_NV(v) XST_mNV(0,v); XSRETURN(1)
+#define XSRETURN_PV(v) XST_mPV(0,v); XSRETURN(1)
+#define XSRETURN_NO XST_mNO(0); XSRETURN(1)
+#define XSRETURN_YES XST_mYES(0); XSRETURN(1)
+#define XSRETURN_UNDEF XST_mUNDEF(0); XSRETURN(1)
AvALLOC(av) = 0;
SvPVX(av) = 0;
AvMAX(av) = AvFILL(av) = -1;
+ if (AvARYLEN(av)) {
+ SvREFCNT_dec(AvARYLEN(av));
+ AvARYLEN(av) = 0;
+ }
}
void
sub readonly { die "\%Config::Config is read-only\n" }
+sub myconfig {
+ my($output);
+
+ $output = <<'END';
+Summary of my $package (patchlevel $PATCHLEVEL) configuration:
+ Platform:
+ osname=$osname, osver=$osvers, archname=$archname
+ uname='$myuname'
+ hint=$hint
+ Compiler:
+ cc='$cc', optimize='$optimize'
+ cppflags='$cppflags'
+ ccflags ='$ccflags'
+ ldflags ='$ldflags'
+ stdchar='$stdchar', d_stdstdio=$d_stdstdio, usevfork=$usevfork
+ voidflags=$voidflags, castflags=$castflags, d_casti32=$d_casti32, d_castneg=$d_castneg
+ intsize=$intsize, alignbytes=$alignbytes, usemymalloc=$usemymalloc, randbits=$randbits
+ Libraries:
+ so=$so
+ libpth=$libpth
+ libs=$libs
+ libc=$libc
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun
+ cccdlflags='$cccdlflags', ccdlflags='$ccdlflags', lddlflags='$lddlflags'
+
+END
+ $output =~ s/\$(\w+)/$Config{$1}/ge;
+ $output;
+}
+
sub STORE { &readonly }
sub DELETE{ &readonly }
sub CLEAR { &readonly }
I32 old_op_type;
char * old_name;
OP * old_eval_root;
+ SV * cur_text;
};
#define PUSHEVAL(cx,n,fgv) \
cx->blk_eval.old_in_eval = in_eval; \
cx->blk_eval.old_op_type = op->op_type; \
cx->blk_eval.old_name = n; \
- cx->blk_eval.old_eval_root = eval_root;
+ cx->blk_eval.old_eval_root = eval_root; \
+ cx->blk_eval.cur_text = linestr;
#define POPEVAL(cx) \
in_eval = cx->blk_eval.old_in_eval; \
GV * xcv_filegv;
long xcv_depth; /* >= 2 indicates recursive call */
AV * xcv_padlist;
+ CV * xcv_outside;
bool xcv_oldstyle;
};
+
#define Nullcv Null(CV*)
#define CvSTASH(sv) ((XPVCV*)SvANY(sv))->xcv_stash
#define CvSTART(sv) ((XPVCV*)SvANY(sv))->xcv_start
#define CvFILEGV(sv) ((XPVCV*)SvANY(sv))->xcv_filegv
#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
#include <sys/file.h>
#endif
-/* Omit -- it causes too much grief on mixed systems.
-#ifdef I_UNISTD
-#include <unistd.h>
-#endif
-*/
-
bool
do_open(gv,name,len,supplied_fp)
GV *gv;
thatio = GvIO(gv);
if (!thatio) {
#ifdef EINVAL
- errno = EINVAL;
+ SETERRNO(EINVAL,SS$_IVCHAN);
#endif
goto say_false;
}
sv_setpvn(sv,">",1);
sv_catpv(sv,oldname);
- errno = 0; /* in case sprintf set errno */
+ SETERRNO(0,0); /* in case sprintf set errno */
if (!do_open(argvoutgv,SvPVX(sv),SvCUR(sv),Nullfp)) {
warn("Can't do inplace edit on %s: %s",
oldname, Strerror(errno) );
if (!gv)
gv = argvgv;
if (!gv || SvTYPE(gv) != SVt_PVGV) {
- errno = EBADF;
+ SETERRNO(EBADF,SS$_IVCHAN);
return FALSE;
}
io = GvIO(gv);
if (IoTYPE(io) == '|') {
status = my_pclose(IoIFP(io));
retval = (status == 0);
- statusvalue = (unsigned short)status & 0xffff;
+ statusvalue = FIXSTATUS(status);
}
else if (IoTYPE(io) == '-')
retval = TRUE;
phooey:
if (dowarn)
warn("tell() on unopened file");
- errno = EBADF;
+ SETERRNO(EBADF,RMS$_IFI);
return -1L;
}
nuts:
if (dowarn)
warn("seek() on unopened file");
- errno = EBADF;
+ SETERRNO(EBADF,RMS$_IFI);
return FALSE;
}
{
dSP;
IO *io;
+ GV* tmpgv;
if (op->op_flags & OPf_REF) {
EXTEND(sp,1);
- io = GvIO(cGVOP->op_gv);
+ tmpgv = cGVOP->op_gv;
+ do_fstat:
+ io = GvIO(tmpgv);
if (io && IoIFP(io)) {
- statgv = cGVOP->op_gv;
+ statgv = tmpgv;
sv_setpv(statname,"");
laststype = OP_STAT;
return (laststatval = Fstat(fileno(IoIFP(io)), &statcache));
}
else {
- if (cGVOP->op_gv == defgv)
+ if (tmpgv == defgv)
return laststatval;
if (dowarn)
warn("Stat on unopened file <%s>",
- GvENAME(cGVOP->op_gv));
+ GvENAME(tmpgv));
statgv = Nullgv;
sv_setpv(statname,"");
return (laststatval = -1);
}
}
else {
- dPOPss;
+ SV* sv = POPs;
PUTBACK;
+ if (SvTYPE(sv) == SVt_PVGV) {
+ tmpgv = (GV*)sv;
+ goto do_fstat;
+ }
+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+ tmpgv = (GV*)SvRV(sv);
+ goto do_fstat;
+ }
+
statgv = Nullgv;
sv_setpv(statname,SvPV(sv, na));
laststype = OP_STAT;
register char *s;
char flags[10];
+ while (*cmd && isSPACE(*cmd))
+ cmd++;
+
/* save an extra exec if possible */
#ifdef CSH
/* see if there are shell metacharacters in it */
- /*SUPPRESS 530*/
+ if (*cmd == '.' && isSPACE(cmd[1]))
+ goto doshell;
+
+ if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
+ goto doshell;
+
for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
if (*s == '=')
goto doshell;
+
for (s = cmd; *s; s++) {
if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
if (*s == '\n' && !s[1]) {
return FALSE;
}
}
+
New(402,Argv, (s - cmd) / 2 + 2, char*);
Cmd = savepvn(cmd, s-cmd);
a = Argv;
if (tainting) {
while (++mark <= sp) {
- if (SvMAGICAL(*mark) && mg_find(*mark, 't'))
+ MAGIC *mg;
+ if (SvMAGICAL(*mark) && (mg = mg_find(*mark, 't')) && mg->mg_len & 1)
tainted = TRUE;
}
mark = oldmark;
case OP_UTIME:
TAINT_PROPER("utime");
if (sp - mark > 2) {
-#ifdef I_UTIME
+#if defined(I_UTIME) || defined(VMS)
struct utimbuf utbuf;
#else
struct {
key = (key_t)SvNVx(*++mark);
n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
flags = SvIVx(*++mark);
- errno = 0;
+ SETERRNO(0,0);
switch (optype)
{
#ifdef HAS_MSG
I32 i = SvIV(astr);
a = (char *)i; /* ouch */
}
- errno = 0;
+ SETERRNO(0,0);
switch (optype)
{
#ifdef HAS_MSG
mbuf = SvPV(mstr, len);
if ((msize = len - sizeof(long)) < 0)
croak("Arg too short for msgsnd");
- errno = 0;
+ SETERRNO(0,0);
return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
#else
croak("msgsnd not implemented");
SvPV_force(mstr, len);
mbuf = SvGROW(mstr, sizeof(long)+msize+1);
- errno = 0;
+ SETERRNO(0,0);
ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
if (ret >= 0) {
SvCUR_set(mstr, sizeof(long)+ret);
opbuf = SvPV(opstr, opsize);
if (opsize < sizeof(struct sembuf)
|| (opsize % sizeof(struct sembuf)) != 0) {
- errno = EINVAL;
+ SETERRNO(EINVAL,LIB$_INVARG);
return -1;
}
- errno = 0;
+ SETERRNO(0,0);
return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
#else
croak("semop not implemented");
mstr = *++mark;
mpos = SvIVx(*++mark);
msize = SvIVx(*++mark);
- errno = 0;
+ SETERRNO(0,0);
if (shmctl(id, IPC_STAT, &shmds) == -1)
return -1;
if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
- errno = EFAULT; /* can't do as caller requested */
+ SETERRNO(EFAULT,SS$_ACCVIO); /* can't do as caller requested */
return -1;
}
shm = (Shmat_t)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
len++, sarg--;
xlen = strlen(xs);
break;
+ case 'n': case '*':
+ croak("Use of %c in printf format not supported", *t);
+
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
case '.': case '#': case '-': case '+': case ' ':
return;
}
s = SvPV(sv, len);
- if (len && !SvPOKp(sv))
+ if (len && !SvPOK(sv))
s = SvPV_force(sv, len);
if (s && len) {
s += --len;
(void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
}
SvCUR_set(sv, len);
+ *SvEND(sv) = '\0';
(void)SvPOK_only(sv);
#ifdef LIBERAL
if (len >= sizeof(long)*4 &&
if (!hv)
RETURN;
+
+ (void)hv_iterinit(hv); /* always reset iterator regardless */
+
if (GIMME != G_ARRAY) {
dTARGET;
i = HvKEYS(hv);
else {
i = 0;
- (void)hv_iterinit(hv);
/*SUPPRESS 560*/
while (entry = hv_iternext(hv)) {
i++;
/* Guess how much room we need. hv_max may be a few too many. Oh well. */
EXTEND(sp, HvMAX(hv) * (dokeys + dovalues));
- (void)hv_iterinit(hv);
-
PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
while (entry = hv_iternext(hv)) {
SPAGAIN;
else
dump("TARG = %d\n", op->op_targ);
}
-#ifdef NOTDEF
+#ifdef DUMPADDR
dump("ADDR = 0x%lx => 0x%lx\n",op, op->op_next);
#endif
if (op->op_flags) {
#define coeff Perl_coeff
#define compiling Perl_compiling
#define compl_amg Perl_compl_amg
+#define compcv Perl_compcv
#define comppad Perl_comppad
#define comppad_name Perl_comppad_name
#define comppad_name_fill Perl_comppad_name_fill
#define cos_amg Perl_cos_amg
#define cryptseen Perl_cryptseen
#define cryptswitch_add Perl_cryptswitch_add
+#define cryptswitch_fp Perl_cryptswitch_fp
#define cshlen Perl_cshlen
#define cshname Perl_cshname
#define curcop Perl_curcop
#define hv_iterinit Perl_hv_iterinit
#define hv_iterkey Perl_hv_iterkey
#define hv_iternext Perl_hv_iternext
+#define hv_iternextsv Perl_hv_iternextsv
#define hv_iterval Perl_hv_iterval
#define hv_magic Perl_hv_magic
#define hv_store Perl_hv_store
#define defoutgv (curinterp->Idefoutgv)
#define defstash (curinterp->Idefstash)
#define delaymagic (curinterp->Idelaymagic)
+#define diehook (curinterp->Idiehook)
#define dirty (curinterp->Idirty)
#define dlevel (curinterp->Idlevel)
#define dlmax (curinterp->Idlmax)
#define leftgv (curinterp->Ileftgv)
#define lineary (curinterp->Ilineary)
#define localizing (curinterp->Ilocalizing)
+#define main_cv (curinterp->Imain_cv)
#define main_root (curinterp->Imain_root)
#define main_start (curinterp->Imain_start)
#define mainstack (curinterp->Imainstack)
#define orslen (curinterp->Iorslen)
#define pad (curinterp->Ipad)
#define padname (curinterp->Ipadname)
+#define parsehook (curinterp->Iparsehook)
#define patchlevel (curinterp->Ipatchlevel)
#define perldb (curinterp->Iperldb)
+#define perl_destruct_level (curinterp->Iperl_destruct_level)
#define pidstatus (curinterp->Ipidstatus)
#define preambled (curinterp->Ipreambled)
#define preprocess (curinterp->Ipreprocess)
#define top_env (curinterp->Itop_env)
#define toptarget (curinterp->Itoptarget)
#define unsafe (curinterp->Iunsafe)
+#define warnhook (curinterp->Iwarnhook)
#else /* not multiple, so translate interpreter symbols the other way... */
#define Idefoutgv defoutgv
#define Idefstash defstash
#define Idelaymagic delaymagic
+#define Idiehook diehook
#define Idirty dirty
#define Idlevel dlevel
#define Idlmax dlmax
#define Ileftgv leftgv
#define Ilineary lineary
#define Ilocalizing localizing
+#define Imain_cv main_cv
#define Imain_root main_root
#define Imain_start main_start
#define Imainstack mainstack
#define Iorslen orslen
#define Ipad pad
#define Ipadname padname
+#define Iparsehook parsehook
#define Ipatchlevel patchlevel
#define Iperldb perldb
+#define Iperl_destruct_level perl_destruct_level
#define Ipidstatus pidstatus
#define Ipreambled preambled
#define Ipreprocess preprocess
#define Itop_env top_env
#define Itoptarget toptarget
#define Iunsafe unsafe
+#define Iwarnhook warnhook
#endif /* MULTIPLICITY */
#!/bin/sh
+rm -f embed.h
cat <<'END' >embed.h
/* This file is derived from global.sym and interp.sym */
);
sub AUTOLOAD {
- if (@_ > 1) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
local($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
$val = constant($constname, @_ ? $_[0] : 0);
*
* Platform: OpenVMS, VAX or AXP
* Author: Charles Bailey bailey@genetics.upenn.edu
- * Revised: 4-Sep-1994
+ * Revised: 12-Dec-1994
*
* Implementation Note
* This section is added as an aid to users and DynaLoader developers, in
#include <lib$routines.h>
#include <rms.h>
#include <ssdef.h>
+#include <starlet.h>
typedef unsigned long int vmssts;
struct dsc$descriptor_s * msg;
vmssts unused;
{
- if (*(msg->dsc$a_pointer) = '%') { /* first line */
+ if (*(msg->dsc$a_pointer) == '%') { /* first line */
if (LastError)
strncpy((LastError = saferealloc(LastError,msg->dsc$w_length)),
msg->dsc$a_pointer, msg->dsc$w_length);
vmssts sts;
vmssts stv;
{
- vmssts vec[3],pmsts;
+ vmssts vec[3];
vec[0] = stv ? 2 : 1;
vec[1] = sts; vec[2] = stv;
- if (!(pmsts = sys$putmsg(vec,copy_errmsg,0,0)) & 1)
- croak("Fatal $PUTMSG error: %d",pmsts);
+ _ckvmssts(sys$putmsg(vec,copy_errmsg,0,0));
}
static void
BOOT:
(void)dl_private_init();
-SV *
+void
dl_expandspec(filespec)
char * filespec
CODE:
}
else {
/* Now set up a default spec - everything but the name */
- deflen = dlnam.nam$l_type - dlesa;
+ deflen = dlnam.nam$l_name - dlesa;
memcpy(defspec,dlesa,deflen);
memcpy(defspec+deflen,dlnam.nam$l_type,
dlnam.nam$b_type + dlnam.nam$b_ver);
deflen += dlnam.nam$b_type + dlnam.nam$b_ver;
memcpy(vmsspec,dlnam.nam$l_name,dlnam.nam$b_name);
DLDEBUG(2,fprintf(stderr,"\tsplit filespec: name = %.*s, default = %.*s\n",
- dlnam.nam$b_name,vmsspec,defspec,deflen));
+ dlnam.nam$b_name,vmsspec,deflen,defspec));
/* . . . and go back to expand it */
dlnam.nam$b_nop = 0;
dlfab.fab$l_dna = defspec;
}
}
-void *
+void
dl_load_file(filespec)
char * filespec
CODE:
unsigned short int len;
unsigned short int code;
char *string;
- } namlst[2] = {0,FSCN$_NAME,0, 0,0,0};
+ } namlst[2] = {{0,FSCN$_NAME,0},{0,0,0}};
struct libref *dlptr;
vmssts sts, failed = 0;
void *entry;
specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer);
DLDEBUG(2,fprintf(stderr,"\tVMS-ified filespec is %s\n",
specdsc.dsc$a_pointer));
- dlptr = safemalloc(sizeof(struct libref));
+ New(7901,dlptr,1,struct libref);
dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T;
dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S;
sts = sys$filescan(&specdsc,namlst,0);
ST(0) = &sv_undef;
}
else {
- ST(0) = sv_2mortal(newSViv(dlptr));
+ ST(0) = sv_2mortal(newSViv((IV) dlptr));
}
-void *
+void
dl_find_symbol(librefptr,symname)
void * librefptr
SV * symname
dl_set_error(sts,0);
ST(0) = &sv_undef;
}
- else ST(0) = sv_2mortal(newSViv(entry));
+ else ST(0) = sv_2mortal(newSViv((IV) entry));
void
);
sub AUTOLOAD {
- if (@_ > 1) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
local($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
$val = constant($constname, @_ ? $_[0] : 0);
);
sub AUTOLOAD {
- if (@_ > 1) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
local($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
$val = constant($constname, @_ ? $_[0] : 0);
if (RETVAL) {
if (RETVAL < 0 && errno == EPERM)
croak("No write permission to gdbm file");
- warn("gdbm store returned %d, errno %d, key \"%.*s\"",
+ croak("gdbm store returned %d, errno %d, key \"%.*s\"",
RETVAL,errno,key.dsize,key.dptr);
/* gdbm_clearerr(db); */
}
if (RETVAL) {
if (RETVAL < 0 && errno == EPERM)
croak("No write permission to ndbm file");
- warn("ndbm store returned %d, errno %d, key \"%s\"",
+ croak("ndbm store returned %d, errno %d, key \"%s\"",
RETVAL,errno,key.dptr);
dbm_clearerr(db);
}
if (RETVAL) {
if (RETVAL < 0 && errno == EPERM)
croak("No write permission to odbm file");
- warn("odbm store returned %d, errno %d, key \"%s\"",
+ croak("odbm store returned %d, errno %d, key \"%s\"",
RETVAL,errno,key.dptr);
}
require Config;
@ISA = qw(Exporter DynaLoader);
-$H{assert_h} = [qw(assert NDEBUG)];
+%EXPORT_TAGS = (
-$H{ctype_h} = [qw(isalnum isalpha iscntrl isdigit isgraph islower
- isprint ispunct isspace isupper isxdigit tolower toupper)];
+ assert_h => [qw(assert NDEBUG)],
-$H{dirent_h} = [qw()];
+ ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower
+ isprint ispunct isspace isupper isxdigit tolower toupper)],
-$H{errno_h} = [qw(E2BIG EACCES EAGAIN EBADF EBUSY ECHILD EDEADLK EDOM
+ dirent_h => [qw()],
+
+ errno_h => [qw(E2BIG EACCES EAGAIN EBADF EBUSY ECHILD EDEADLK EDOM
EEXIST EFAULT EFBIG EINTR EINVAL EIO EISDIR EMFILE
EMLINK ENAMETOOLONG ENFILE ENODEV ENOENT ENOEXEC ENOLCK
ENOMEM ENOSPC ENOSYS ENOTDIR ENOTEMPTY ENOTTY ENXIO
- EPERM EPIPE ERANGE EROFS ESPIPE ESRCH EXDEV errno)];
+ EPERM EPIPE ERANGE EROFS ESPIPE ESRCH EXDEV errno)],
-$H{fcntl_h} = [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK
+ fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK
F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK
O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK
O_RDONLY O_RDWR O_TRUNC O_WRONLY
SEEK_CUR SEEK_END SEEK_SET
S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID
- S_IWGRP S_IWOTH S_IWUSR)];
+ S_IWGRP S_IWOTH S_IWUSR)],
-$H{float_h} = [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG
+ float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG
DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP
DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP
FLT_DIG FLT_EPSILON FLT_MANT_DIG
FLT_RADIX FLT_ROUNDS
LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG
LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP
- LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)];
+ LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)],
-$H{grp_h} = [qw()];
+ grp_h => [qw()],
-$H{limits_h} = [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX
+ limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX
INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON
MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX
PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN
_POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT
_POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX
_POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX
- _POSIX_STREADM_MAX _POSIX_TZNAME_MAX)];
+ _POSIX_STREADM_MAX _POSIX_TZNAME_MAX)],
-$H{locale_h} = [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC
- LC_TIME NULL localeconv setlocale)];
+ locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC
+ LC_TIME NULL localeconv setlocale)],
-$H{math_h} = [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod
- frexp ldexp log10 modf pow sinh tanh)];
+ math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod
+ frexp ldexp log10 modf pow sinh tanh)],
-$H{pwd_h} = [qw()];
+ pwd_h => [qw()],
-$H{setjmp_h} = [qw(longjmp setjmp siglongjmp sigsetjmp)];
+ setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)],
-$H{signal_h} = [qw(SA_NOCLDSTOP SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE
+ signal_h => [qw(SA_NOCLDSTOP SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE
SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV
SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2
SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK
raise sigaction signal sigpending sigprocmask
- sigsuspend)];
+ sigsuspend)],
-$H{stdarg_h} = [qw()];
+ stdarg_h => [qw()],
-$H{stddef_h} = [qw(NULL offsetof)];
+ stddef_h => [qw(NULL offsetof)],
-$H{stdio_h} = [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid
+ stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid
L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET STREAM_MAX
TMP_MAX stderr stdin stdout _IOFBF _IOLBF _IONBF
clearerr fclose fdopen feof ferror fflush fgetc fgetpos
fscanf fseek fsetpos ftell fwrite getchar gets
perror putc putchar puts remove rewind
scanf setbuf setvbuf sscanf tmpfile tmpnam
- ungetc vfprintf vprintf vsprintf)];
+ ungetc vfprintf vprintf vsprintf)],
-$H{stdlib_h} = [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX
+ stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX
abort atexit atof atoi atol bsearch calloc div
free getenv labs ldiv malloc mblen mbstowcs mbtowc
- qsort realloc strtod strtol stroul wcstombs wctomb)];
+ qsort realloc strtod strtol stroul wcstombs wctomb)],
-$H{string_h} = [qw(NULL memchr memcmp memcpy memmove memset strcat
+ string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat
strchr strcmp strcoll strcpy strcspn strerror strlen
strncat strncmp strncpy strpbrk strrchr strspn strstr
- strtok strxfrm)];
+ strtok strxfrm)],
-$H{sys_stat_h} = [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
+ sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG
S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR
- fstat mkfifo)];
+ fstat mkfifo)],
-$H{sys_times_h} = [qw()];
+ sys_times_h => [qw()],
-$H{sys_types_h} = [qw()];
+ sys_types_h => [qw()],
-$H{sys_utsname_h} = [qw(uname)];
+ sys_utsname_h => [qw(uname)],
-$H{sys_wait_h} = [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
- WNOHANG WSTOPSIG WTERMSIG WUNTRACED)];
+ sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
+ WNOHANG WSTOPSIG WTERMSIG WUNTRACED)],
-$H{termios_h} = [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400
+ termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400
B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL
CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK
ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR
TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART
VSTOP VSUSP VTIME
cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain
- tcflow tcflush tcgetattr tcsendbreak tcsetattr )];
+ tcflow tcflush tcgetattr tcsendbreak tcsetattr )],
-$H{time_h} = [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime
- difftime mktime strftime tzset tzname)];
+ time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime
+ difftime mktime strftime tzset tzname)],
-$H{unistd_h} = [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET
+ unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET
STRERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK
_PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON
_PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX
dup2 dup execl execle execlp execv execve execvp
fpathconf getcwd getegid geteuid getgid getgroups
getpid getuid isatty lseek pathconf pause setgid setpgid
- setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)];
+ setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)],
-$H{utime_h} = [qw()];
+ utime_h => [qw()],
-sub expand {
- local (@mylist);
- foreach $entry (@_) {
- if ($H{$entry}) {
- push(@mylist, @{$H{$entry}});
- }
- else {
- push(@mylist, $entry);
- }
- }
- @mylist;
-}
+);
-@EXPORT = expand qw(assert_h ctype_h dirent_h errno_h fcntl_h float_h
- grp_h limits_h locale_h math_h pwd_h setjmp_h signal_h
- stdarg_h stddef_h stdio_h stdlib_h string_h sys_stat_h
- sys_times_h sys_types_h sys_utsname_h sys_wait_h
- termios_h time_h unistd_h utime_h);
+Exporter::export_tags();
@EXPORT_OK = qw(
closedir opendir readdir rewinddir
utime
);
+# Grandfather old foo_h form to new :foo_h form
sub import {
my $this = shift;
- my @list = expand @_;
+ my @list = map { m/^\w+_h$/ ? ":$_" : $_ } @_;
local $Exporter::ExportLevel = 1;
Exporter::import($this,@list);
}
sub ungensym {
local($x) = shift;
$x =~ s/.*:://;
- delete $::_POSIX{$x};
+ delete $POSIX::{$x};
}
############################
$mode =~ s/a.*/>>/ ||
$mode =~ s/w.*/>/ ||
($mode = '<');
- open($glob, "$mode $filename");
+ open($glob, "$mode $filename") and
bless \$glob;
}
$mode =~ s/a.*/>>/ ||
$mode =~ s/w.*/>/ ||
($mode = '<');
- open($glob, "$mode&=$fd");
+ open($glob, "$mode&=$fd") and
bless \$glob;
}
sub close {
POSIX::usage "close(filehandle)" if @_ != 1;
close($_[0]);
+}
+
+sub DESTROY {
+ close($_[0]);
ungensym($_[0]);
}
RETVAL
OutputStream
-new_tmpfile()
+new_tmpfile(packname = "FileHandle")
+ char * packname
CODE:
RETVAL = tmpfile();
OUTPUT:
char * filename
int flags
Mode_t mode
+ CODE:
+ if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL))
+ TAINT_PROPER("open");
+ RETVAL = open(filename, flags, mode);
+ OUTPUT:
+ RETVAL
+
HV *
localeconv()
STRLEN dstlen;
char *p = SvPV(src,srclen);
srclen++;
- ST(0) = sv_2mortal(newSV(srclen));
+ ST(0) = sv_2mortal(NEWSV(800,srclen));
dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)srclen);
if (dstlen > srclen) {
dstlen++;
mkfifo(filename, mode)
char * filename
Mode_t mode
+ CODE:
+ TAINT_PROPER("mkfifo");
+ RETVAL = mkfifo(filename, mode);
+ OUTPUT:
+ RETVAL
SysRet
tcdrain(fd)
char *
ctime(time)
- Time_t * time
+ Time_t &time
double
difftime(time1, time2)
if (RETVAL) {
if (RETVAL < 0 && errno == EPERM)
croak("No write permission to sdbm file");
- warn("sdbm store returned %d, errno %d, key \"%s\"",
+ croak("sdbm store returned %d, errno %d, key \"%s\"",
RETVAL,errno,key.dptr);
sdbm_clearerr(db);
}
);
sub AUTOLOAD {
- if (@_ > 1) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
local($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
$val = constant($constname, @_ ? $_[0] : 0);
goto &$AUTOLOAD;
}
+
+# pack a sockaddr_in structure for use in bind() calls.
+# (here to hide the 'S n C4 x8' magic from applications)
+sub sockaddr_in{
+ my($af, $port, @quad) = @_;
+ my $pack = 'S n C4 x8'; # lookup $pack from hash using $af?
+ pack($pack, $af, $port, @quad);
+}
+
+
bootstrap Socket;
# Preloaded methods go here. Autoload methods go after __END__, and are
coeff
compiling
compl_amg
+compcv
comppad
comppad_name
comppad_name_fill
cos_amg
cryptseen
cryptswitch_add
+cryptswitch_fp
cshlen
cshname
curcop
hv_iterinit
hv_iterkey
hv_iternext
+hv_iternextsv
hv_iterval
hv_magic
hv_store
GV* gv;
GV** gvp;
HV* lastchance;
+ CV* cv;
if (!stash)
return 0;
if (SvTYPE(topgv) != SVt_PVGV)
gv_init(topgv, stash, name, len, TRUE);
- if (GvCV(topgv)) {
- if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation)
- return topgv;
+ if (cv=GvCV(topgv)) {
+ if (GvCVGEN(topgv) >= sub_generation)
+ return topgv; /* valid cached inheritance */
+ if (!GvCVGEN(topgv)) { /* not an inheritance cache */
+ if (CvROOT(cv) || CvXSUB(cv))
+ return topgv; /* real definition */
+ /* a simple undef -- save the slot for possible re-use */
+ }
+ else {
+ /* stale cached entry, just junk it */
+ GvCV(topgv) = cv = 0;
+ GvCVGEN(topgv) = 0;
+ }
}
+ /* if cv is still set, we have to free it if we find something to cache */
gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
}
gv = gv_fetchmeth(basestash, name, len, level + 1);
if (gv) {
+ if (cv) { /* junk old undef */
+ assert(SvREFCNT(topgv) > 1);
+ SvREFCNT_dec(topgv);
+ SvREFCNT_dec(cv);
+ }
GvCV(topgv) = GvCV(gv); /* cache the CV */
GvCVGEN(topgv) = sub_generation; /* valid for now */
return gv;
if (!level) {
if (lastchance = gv_stashpv("UNIVERSAL", FALSE)) {
if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) {
+ if (cv) { /* junk old undef */
+ assert(SvREFCNT(topgv) > 1);
+ SvREFCNT_dec(topgv);
+ SvREFCNT_dec(cv);
+ }
GvCV(topgv) = GvCV(gv); /* cache the CV */
GvCVGEN(topgv) = sub_generation; /* valid for now */
return gv;
else if (strNE(name, "AUTOLOAD")) {
gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0);
if (gv && (cv = GvCV(gv))) { /* One more chance... */
- SV *tmpstr = sv_newmortal();
- sv_catpv(tmpstr,HvNAME(stash));
+ SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0));
sv_catpvn(tmpstr,"::", 2);
sv_catpvn(tmpstr, name, nend - name);
sv_setsv(GvSV(CvGV(cv)), tmpstr);
stash = defstash;
else if ((COP*)curcop == &compiling) {
stash = curstash;
- if (add && (hints & HINT_STRICT_VARS) && sv_type != SVt_PVCV) {
- if (stash && !hv_fetch(stash,name,len,0))
+ if (add && (hints & HINT_STRICT_VARS) &&
+ sv_type != SVt_PVCV &&
+ sv_type != SVt_PVGV &&
+ sv_type != SVt_PVIO)
+ {
stash = 0;
}
}
case '\\':
case '/':
case '|':
+ case '\001':
case '\004':
+ case '\006':
case '\010':
case '\t':
case '\020':
case '\024':
case '\027':
- case '\006':
if (len > 1)
break;
goto magicalize;
GV *gv;
{
GV* egv = GvEGV(gv);
- HV *hv = GvSTASH(egv);
-
+ HV *hv;
+
+ if (!egv)
+ egv = gv;
+ hv = GvSTASH(egv);
if (!hv)
return;
+
sv_setpv(sv, sv == (SV*)gv ? "*" : "");
sv_catpv(sv,HvNAME(hv));
sv_catpvn(sv,"::", 2);
warn("Attempt to free unreferenced glob pointers");
return;
}
- if (--gp->gp_refcnt > 0)
+ if (--gp->gp_refcnt > 0) {
+ if (gp->gp_egv == gv)
+ gp->gp_egv = 0;
return;
+ }
SvREFCNT_dec(gp->gp_sv);
SvREFCNT_dec(gp->gp_av);
}
if ((cv = gp->gp_cv) && !GvCVGEN(gv))
SvREFCNT_dec(cv);
+ SvREFCNT_dec(gp->gp_form);
+
Safefree(gp);
GvGP(gv) = 0;
}
GV* gv;
CV* cv;
MAGIC* mg=mg_find((SV*)stash,'c');
- AMT *amtp;
+ AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL;
if (mg && (amtp=((AMT*)(mg->mg_ptr)))->was_ok_am == amagic_generation &&
amtp->was_ok_sub == sub_generation)
return HV_AMAGIC(stash)? TRUE: FALSE;
gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE);
+ if (amtp && amtp->table) {
+ int i;
+ for (i=1;i<NofAMmeth*2;i++) {
+ if (amtp->table[i]) {
+ SvREFCNT_dec(amtp->table[i]);
+ }
+ }
+ }
sv_unmagic((SV*)stash, 'c');
DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) );
default:
if (!SvROK(sv)) {
if (!SvOK(sv)) break;
- gv = gv_fetchmethod(curcop->cop_stash, SvPV(sv, na));
+ gv = gv_fetchmethod(stash, SvPV(sv, na));
if (gv) cv = GvCV(gv);
break;
}
}
if (cv) filled=1;
else {
- die("Method for operation %s not found in package %s during blessing\n",
+ die("Method for operation %s not found in package %.200s during blessing\n",
cp,HvNAME(stash));
return FALSE;
}
}
}
- amt.table[i]=cv;
+ amt.table[i]=(CV*)SvREFCNT_inc(cv);
}
sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(amt));
if (filled) {
CV **cvp=NULL, **ocvp=NULL;
AMT *amtp, *oamtp;
int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
- int postpr=0;
+ int postpr=0, inc_dec_ass=0, assignshift=assign?1:0;
HV* stash;
if (!(AMGf_noleft & flags) && SvAMAGIC(left)
&& (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
&& (ocvp = cvp = ((oamtp=amtp=(AMT*)mg->mg_ptr)->table))
- && (assign ?
- ((cv = cvp[off=method+1])
- || ( amtp->fallback > AMGfallNEVER && /* fallback to
- * usual method */
- (fl = 1, cv = cvp[off=method]))):
- (1 && (cv = cvp[off=method])) )) {
+ && ((cv = cvp[off=method+assignshift])
+ || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
+ * usual method */
+ (fl = 1, cv = cvp[off=method])))) {
lr = -1; /* Call method for left argument */
} else {
if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
/* look for substituted methods */
switch (method) {
case inc_amg:
- if ((cv = cvp[off=add_ass_amg])
+ if (((cv = cvp[off=add_ass_amg]) && (inc_dec_ass=1))
|| ((cv = cvp[off=add_amg]) && (postpr=1))) {
right = &sv_yes; lr = -1; assign = 1;
}
break;
case dec_amg:
- if ((cv = cvp[off=subtr_ass_amg])
+ if (((cv = cvp[off=subtr_ass_amg]) && (inc_dec_ass=1))
|| ((cv = cvp[off=subtr_amg]) && (postpr=1))) {
right = &sv_yes; lr = -1; assign = 1;
}
case string_amg:
(void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
break;
+ case copy_amg:
+ {
+ SV* ref=SvRV(left);
+ if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) { /* Just to be
+ * extra
+ * causious,
+ * maybe in some
+ * additional
+ * cases sv_setsv
+ * is safe too */
+ SV* newref = newSVsv(ref);
+ SvOBJECT_on(newref);
+ SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref));
+ return newref;
+ }
+ }
+ break;
case abs_amg:
- if ((cvp[off1=lt_amg] || cvp[off1=lt_amg])
+ if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
&& ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
+ SV* nullsv=sv_2mortal(newSViv(0));
if (off1==lt_amg) {
- SV* lessp = amagic_call(left,
- sv_2mortal(newSViv(0)),
+ SV* lessp = amagic_call(left,nullsv,
lt_amg,AMGf_noright);
logic = SvTRUE(lessp);
} else {
- SV* lessp = amagic_call(left,
- sv_2mortal(newSViv(0)),
+ SV* lessp = amagic_call(left,nullsv,
ncmp_amg,AMGf_noright);
logic = (SvNV(lessp) < 0);
}
if (logic) {
if (off==subtr_amg) {
right = left;
- left = sv_2mortal(newSViv(0));
+ left = nullsv;
lr = 1;
}
} else {
&& (cv = cvp[off=method])) { /* Method for right
* argument found */
lr=1;
- } else if (((ocvp && oamtp->fallback > AMGfallNEVER && (cvp=ocvp))
+ } else if (((ocvp && oamtp->fallback > AMGfallNEVER
+ && (cvp=ocvp) && (lr=-1))
|| (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
&& !(flags & AMGf_unary)) {
/* We look for substitution for
notfound = 1; lr = 1;
} else {
char tmpstr[512];
- sprintf(tmpstr,"Operation `%s': no method found,\n\tleft argument %s%200s,\n\tright argument %s%200s",
+ if (off==-1) off=method;
+ sprintf(tmpstr,"Operation `%s': no method found,\n\tleft argument %s%.200s,\n\tright argument %s%.200s",
((char**)AMG_names)[off],
SvAMAGIC(left)?
"in overloaded package ":
}
}
if (!notfound) {
- DEBUG_o( deb("Operation `%s': method for %s argument found in package %s%s\n",
+ DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.200s%s\n",
((char**)AMG_names)[off],
- (lr? "right": "left"),
+ method+assignshift==off? "" :
+ " (initially `",
+ method+assignshift==off? "" :
+ ((char**)AMG_names)[method+assignshift],
+ method+assignshift==off? "" : "')",
+ flags & AMGf_unary? "" :
+ lr==1 ? " for right argument": " for left argument",
+ flags & AMGf_unary? " for argument" : "",
HvNAME(stash),
fl? ",\n\tassignment variant used": "") );
- /* Since we use shallow copy, we need to dublicate the contents,
- probably we need also to use user-supplied version of coping?
- */
- if (assign || method==inc_amg || method==dec_amg) RvDEEPCP(left);
+ /* Since we use shallow copy during assignment, we need
+ * to dublicate the contents, probably calling user-supplied
+ * version of copy operator
+ */
+ if ((method+assignshift==off
+ && (assign || method==inc_amg || method==dec_amg))
+ || inc_dec_ass) RvDEEPCP(left);
}
{
dSP;
SvSetSV(left,res); return res; break;
}
return ans? &sv_yes: &sv_no;
+ } else if (method==copy_amg) {
+ if (!SvROK(res)) {
+ die("Copy method did not return a reference");
+ }
+ return SvREFCNT_inc(SvRV(res));
} else {
return res;
}
#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))
+#define GvENAME(gv) GvNAME(GvEGV(gv) ? GvEGV(gv) : gv)
#define GvSTASH(gv) (GvXPVGV(gv)->xgv_stash)
-#define GvESTASH(gv) GvSTASH(GvEGV(gv))
+#define GvESTASH(gv) GvSTASH(GvEGV(gv) ? GvEGV(gv) : gv)
#define Nullgv Null(GV*)
END
@isatype{@isatype} = (1) x @isatype;
+$inif = 0;
@ARGV = ('-') unless @ARGV;
}
elsif (s/^if\s+//) {
$new = '';
+ $inif = 1;
do expr();
+ $inif = 0;
print OUT $t,"if ($new) {\n";
$tab += 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
}
elsif (s/^elif\s+//) {
$new = '';
+ $inif = 1;
do expr();
+ $inif = 0;
$tab -= 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
print OUT $t,"}\n${t}elsif ($new) {\n";
}
}
else {
- $new .= ' &' . $id;
+ if ($inif && $new !~ /defined\($/) {
+ $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
+ } else {
+ $new .= ' &' . $id;
+ }
}
next;
};
\@EXPORT = qw(
@const_names
);
-# Other items we are prepared to export if requested
-\@EXPORT_OK = qw(
-);
-
END
print PM <<"END" unless $opt_c;
# XS function. If a constant is not found then control is passed
# to the AUTOLOAD in AutoLoader.
- # NOTE: THIS AUTOLOAD FUNCTION IS FLAWED (but is the best we can do for now).
- # Avoid old-style ``&CONST'' usage. Either remove the ``&'' or add ``()''.
- if (\@_ > 0) {
- \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
local(\$constname);
(\$constname = \$AUTOLOAD) =~ s/.*:://;
\$val = constant(\$constname, \@_ ? \$_[0] : 0);
}
SV *
-hv_delete(hv,key,klen)
+hv_delete(hv,key,klen,flags)
HV *hv;
char *key;
U32 klen;
+I32 flags;
{
register XPVHV* xhv;
register char *s;
*oentry = entry->hent_next;
if (i && !*oentry)
xhv->xhv_fill--;
- sv = sv_mortalcopy(entry->hent_val);
+ if (flags & G_DISCARD)
+ sv = Nullsv;
+ else
+ sv = sv_mortalcopy(entry->hent_val);
if (entry == xhv->xhv_eiter)
entry->hent_klen = -1;
else
}
close CONFIG;
-$ver = sprintf("%5.3f", $] + 0);
+$ver = $];
$release = substr($ver,0,3);
$patchlevel = substr($ver,3,2);
+die "Patchlevel of perl ($patchlevel)",
+ "and patchlevel of config.sh ($PATCHLEVEL) don't match\n"
+ if $patchlevel != $PATCHLEVEL;
# Do some quick sanity checks.
}
# HP-UX (at least) needs to maintain execute permissions
# on dynamically-loaded libraries.
- &chmod(0644, "$installlib/$name")
- unless (/\.$so$/ || /\.$dlext$/);
+ if ($name =~ /\.(so|$dlext)$/o) {
+ &chmod(0555, "$installlib/$name");
+ }
+ else {
+ &chmod(0444, "$installlib/$name");
+ }
}
} elsif (-d $_) {
&makedir("$installlib/$name");
defoutgv
defstash
delaymagic
+diehook
dirty
dlevel
dlmax
leftgv
lineary
localizing
+main_cv
main_root
main_start
mainstack
orslen
pad
padname
+parsehook
patchlevel
perldb
+perl_destruct_level
pidstatus
preambled
preprocess
top_env
toptarget
unsafe
+warnhook
if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){
eval {require $name};
}
+ elsif ($AUTOLOAD =~ /::DESTROY$/) {
+ eval "sub $AUTOLOAD {}";
+ }
if ($@){
$@ =~ s/ at .*\n//;
croak $@;
# This package implements handy routines for modules that wish to throw
# exceptions outside of the current package.
+$CarpLevel = 0; # How many extra package levels to skip on carp.
+
require Exporter;
@ISA = Exporter;
@EXPORT = qw(confess croak carp);
sub longmess {
my $error = shift;
my $mess = "";
- my $i = 2;
+ my $i = 1 + $CarpLevel;
my ($pack,$file,$line,$sub);
while (($pack,$file,$line,$sub) = caller($i++)) {
$mess .= "\t$sub " if $error eq "called";
$mess || $error;
}
-sub shortmess {
- my $error = shift;
+sub shortmess { # Short-circuit &longmess if called via multiple packages
+ my $error = $_[0]; # Instead of "shift"
my ($curpack) = caller(1);
+ my $extra = $CarpLevel;
my $i = 2;
my ($pack,$file,$line,$sub);
while (($pack,$file,$line,$sub) = caller($i++)) {
- return "$error at $file line $line\n" if $pack ne $curpack;
+ if ($pack ne $curpack) {
+ if ($extra-- > 0) {
+ $curpack = $pack;
+ }
+ else {
+ return "$error at $file line $line\n";
+ }
+ }
}
- longmess $error;
+ goto &longmess;
}
sub confess { die longmess @_; }
sub croak { die shortmess @_; }
sub carp { warn shortmess @_; }
+1;
package Cwd;
require 5.000;
require Exporter;
+use Config;
@ISA = qw(Exporter);
@EXPORT = qw(getcwd fastcwd);
@EXPORT_OK = qw(chdir);
+# VMS: $ENV{'DEFAULT'} points to default directory at all times
+# 08-Dec-1994 Charles Bailey bailey@genetics.upenn.edu
+# Note: Use of Cwd::getcwd() or Cwd::chdir() (but not Cwd::fastcwd())
+# causes the logical name PWD to be defined in the process
+# logical name table as the default device and directory
+# seen by Perl. This may not be the same as the default device
+# and directory seen by DCL after Perl exits, since the effects
+# the CRTL chdir() function persist only until Perl exits.
+
# By Brandon S. Allbery
#
# Usage: $cwd = getcwd();
sub getcwd
{
+ if($Config{'osname'} eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
+
my($dotdots, $cwd, @pst, @cst, $dir, @tst);
unless (@cst = stat('.'))
# you might chdir out of a directory that you can't chdir back into.
sub fastcwd {
+ if($Config{'osname'} eq 'VMS') { return $ENV{'DEFAULT'} }
+
my($odev, $oino, $cdev, $cino, $tdev, $tino);
my(@path, $path);
local(*DIR);
sub chdir {
my($newdir) = shift;
+ $newdir =~ s|/{2,}|/|g;
chdir_init() unless $chdir_init;
return 0 unless (CORE::chdir $newdir);
+ if ($Config{'osname'} eq 'VMS') { return $ENV{PWD} = $ENV{DEFAULT} }
+
if ($newdir =~ m#^/#) {
$ENV{'PWD'} = $newdir;
}else{
require Exporter;
@ISA = (Exporter);
-local($^W) = 0;
+local $^W = 0;
+
+# Grandfather $NAME import
+sub import {
+ my $this = shift;
+ my @list = @_;
+ local $Exporter::ExportLevel = 1;
+ Exporter::import($this,grep {s/^\$/*/} @list);
+}
@EXPORT = qw(
*ARG
- $MATCH
- $PREMATCH
- $POSTMATCH
- $LAST_PAREN_MATCH
- $INPUT_LINE_NUMBER
- $NR
- $INPUT_RECORD_SEPARATOR
- $RS
- $OUTPUT_AUTOFLUSH
- $OUTPUT_FIELD_SEPARATOR
- $OFS
- $OUTPUT_RECORD_SEPARATOR
- $ORS
- $LIST_SEPARATOR
- $SUBSCRIPT_SEPARATOR
- $SUBSEP
- $FORMAT_PAGE_NUMBER
- $FORMAT_LINES_PER_PAGE
- $FORMAT_LINES_LEFT
- $FORMAT_NAME
- $FORMAT_TOP_NAME
- $FORMAT_LINE_BREAK_CHARACTERS
- $FORMAT_FORMFEED
- $CHILD_ERROR
- $OS_ERROR
- $ERRNO
- $EVAL_ERROR
- $PROCESS_ID
- $PID
- $REAL_USER_ID
- $UID
- $EFFECTIVE_USER_ID
- $EUID
- $REAL_GROUP_ID
- $GID
- $EFFECTIVE_GROUP_ID
- $EGID
- $PROGRAM_NAME
- $PERL_VERSION
- $DEBUGGING
- $SYSTEM_FD_MAX
- $INPLACE_EDIT
- $PERLDB
- $BASETIME
- $WARNING
- $EXECUTABLE_NAME
- $ARRAY_BASE
- $OFMT
- $MULTILINE_MATCHING
+ *MATCH
+ *PREMATCH
+ *POSTMATCH
+ *LAST_PAREN_MATCH
+ *INPUT_LINE_NUMBER
+ *NR
+ *INPUT_RECORD_SEPARATOR
+ *RS
+ *OUTPUT_AUTOFLUSH
+ *OUTPUT_FIELD_SEPARATOR
+ *OFS
+ *OUTPUT_RECORD_SEPARATOR
+ *ORS
+ *LIST_SEPARATOR
+ *SUBSCRIPT_SEPARATOR
+ *SUBSEP
+ *FORMAT_PAGE_NUMBER
+ *FORMAT_LINES_PER_PAGE
+ *FORMAT_LINES_LEFT
+ *FORMAT_NAME
+ *FORMAT_TOP_NAME
+ *FORMAT_LINE_BREAK_CHARACTERS
+ *FORMAT_FORMFEED
+ *CHILD_ERROR
+ *OS_ERROR
+ *ERRNO
+ *EVAL_ERROR
+ *PROCESS_ID
+ *PID
+ *REAL_USER_ID
+ *UID
+ *EFFECTIVE_USER_ID
+ *EUID
+ *REAL_GROUP_ID
+ *GID
+ *EFFECTIVE_GROUP_ID
+ *EGID
+ *PROGRAM_NAME
+ *PERL_VERSION
+ *ACCUMULATOR
+ *DEBUGGING
+ *SYSTEM_FD_MAX
+ *INPLACE_EDIT
+ *PERLDB
+ *BASETIME
+ *WARNING
+ *EXECUTABLE_NAME
);
# The ground of all being.
# Matching.
- *MATCH = \$& ;
- *PREMATCH = \$` ;
- *POSTMATCH = \$' ;
- *LAST_PAREN_MATCH = \$+ ;
+ *MATCH = *& ;
+ *PREMATCH = *` ;
+ *POSTMATCH = *' ;
+ *LAST_PAREN_MATCH = *+ ;
# Input.
- *INPUT_LINE_NUMBER = \$. ;
- *NR = \$. ;
- *INPUT_RECORD_SEPARATOR = \$/ ;
- *RS = \$/ ;
+ *INPUT_LINE_NUMBER = *. ;
+ *NR = *. ;
+ *INPUT_RECORD_SEPARATOR = */ ;
+ *RS = */ ;
# Output.
- *OUTPUT_AUTOFLUSH = \$| ;
- *OUTPUT_FIELD_SEPARATOR = \$, ;
- *OFS = \$, ;
- *OUTPUT_RECORD_SEPARATOR = \$\ ;
- *ORS = \$\ ;
+ *OUTPUT_AUTOFLUSH = *| ;
+ *OUTPUT_FIELD_SEPARATOR = *, ;
+ *OFS = *, ;
+ *OUTPUT_RECORD_SEPARATOR = *\ ;
+ *ORS = *\ ;
# Interpolation "constants".
- *LIST_SEPARATOR = \$" ;
- *SUBSCRIPT_SEPARATOR = \$; ;
- *SUBSEP = \$; ;
+ *LIST_SEPARATOR = *" ;
+ *SUBSCRIPT_SEPARATOR = *; ;
+ *SUBSEP = *; ;
# Formats
- *FORMAT_PAGE_NUMBER = \$% ;
- *FORMAT_LINES_PER_PAGE = \$= ;
- *FORMAT_LINES_LEFT = \$- ;
- *FORMAT_NAME = \$~ ;
- *FORMAT_TOP_NAME = \$^ ;
- *FORMAT_LINE_BREAK_CHARACTERS = \$: ;
- *FORMAT_FORMFEED = \$^L ;
+ *FORMAT_PAGE_NUMBER = *% ;
+ *FORMAT_LINES_PER_PAGE = *= ;
+ *FORMAT_LINES_LEFT = *- ;
+ *FORMAT_NAME = *~ ;
+ *FORMAT_TOP_NAME = *^ ;
+ *FORMAT_LINE_BREAK_CHARACTERS = *: ;
+ *FORMAT_FORMFEED = *^L ;
# Error status.
- *CHILD_ERROR = \$? ;
- *OS_ERROR = \$! ;
- *ERRNO = \$! ;
- *EVAL_ERROR = \$@ ;
+ *CHILD_ERROR = *? ;
+ *OS_ERROR = *! ;
+ *ERRNO = *! ;
+ *EVAL_ERROR = *@ ;
# Process info.
- *PROCESS_ID = \$$ ;
- *PID = \$$ ;
- *REAL_USER_ID = \$< ;
- *UID = \$< ;
- *EFFECTIVE_USER_ID = \$> ;
- *EUID = \$> ;
- *REAL_GROUP_ID = \$( ;
- *GID = \$( ;
- *EFFECTIVE_GROUP_ID = \$) ;
- *EGID = \$) ;
- *PROGRAM_NAME = \$0 ;
+ *PROCESS_ID = *$ ;
+ *PID = *$ ;
+ *REAL_USER_ID = *< ;
+ *UID = *< ;
+ *EFFECTIVE_USER_ID = *> ;
+ *EUID = *> ;
+ *REAL_GROUP_ID = *( ;
+ *GID = *( ;
+ *EFFECTIVE_GROUP_ID = *) ;
+ *EGID = *) ;
+ *PROGRAM_NAME = *0 ;
# Internals.
- *PERL_VERSION = \$] ;
- *ACCUMULATOR = \$^A ;
- *DEBUGGING = \$^D ;
- *SYSTEM_FD_MAX = \$^F ;
- *INPLACE_EDIT = \$^I ;
- *PERLDB = \$^P ;
- *BASETIME = \$^T ;
- *WARNING = \$^W ;
- *EXECUTABLE_NAME = \$^X ;
+ *PERL_VERSION = *] ;
+ *ACCUMULATOR = *^A ;
+ *DEBUGGING = *^D ;
+ *SYSTEM_FD_MAX = *^F ;
+ *INPLACE_EDIT = *^I ;
+ *PERLDB = *^P ;
+ *BASETIME = *^T ;
+ *WARNING = *^W ;
+ *EXECUTABLE_NAME = *^X ;
# Deprecated.
-# *ARRAY_BASE = \$[ ;
-# *OFMT = \$# ;
-# *MULTILINE_MATCHING = \$* ;
+# *ARRAY_BASE = *[ ;
+# *OFMT = *# ;
+# *MULTILINE_MATCHING = ** ;
1;
package Exporter;
-require 5.000;
+=head1 Comments
+
+If the first entry in an import list begins with /, ! or : then
+treat the list as a series of specifications which either add to
+or delete from the list of names to import. They are processed
+left to right. Specifications are in the form:
+
+ [!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
+ [!]name This name only
+ [!]:tag All names in $EXPORT_TAGS{":tag"}
+ [!]:DEFAULT All names in @EXPORT
+
+e.g., Foo.pm defines:
+
+ @EXPORT = qw(A1 A2 A3 A4 A5);
+ @EXPORT_OK = qw(B1 B2 B3 B4 B5);
+ %EXPORT_TAGS = (':T1' => [qw(A1 A2 B1 B2)], ':T2' => [qw(A1 A2 B3 B4)]);
+
+ Note that you cannot use tags in @EXPORT or @EXPORT_OK.
+ Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
+
+Application says:
+
+ use Module qw(:T2 !B3 A3);
+ use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
+ use POSIX qw(/^S_/ acos asin atan /^E/ !/^EXIT/);
+
+=cut
+
+require 5.001;
$ExportLevel = 0;
+$Verbose = 0;
+
+require Carp;
sub export {
- my $pack = shift;
- my $callpack = shift;
+
+ # First make import warnings look like they're coming from the "use".
+ local $SIG{__WARN__} = sub {
+ my $text = shift;
+ $text =~ s/ at \S*Exporter.pm line \d+.\n//;
+ local $Carp::CarpLevel = 1; # ignore package calling us too.
+ Carp::carp($text);
+ };
+
+ my $pkg = shift;
+ my $callpkg = shift;
my @imports = @_;
- *exports = \@{"${pack}::EXPORT"};
+ my($type, $sym);
+ *exports = \@{"${pkg}::EXPORT"};
if (@imports) {
my $oops;
- my $type;
- *exports = \%{"${pack}::EXPORT"};
+ *exports = \%{"${pkg}::EXPORT"};
if (!%exports) {
grep(s/^&//, @exports);
@exports{@exports} = (1) x @exports;
- foreach $extra (@{"${pack}::EXPORT_OK"}) {
+ foreach $extra (@{"${pkg}::EXPORT_OK"}) {
$exports{$extra} = 1;
}
}
+
+ if ($imports[0] =~ m#^[/!:]#){
+ my(@allexports) = keys %exports;
+ my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
+ my $tagdata;
+ my %imports;
+ # negated first item implies starting with default set:
+ unshift(@imports, ':DEFAULT') if $imports[0] =~ m/^!/;
+ foreach (@imports){
+ my(@names);
+ my($mode,$spec) = m/^(!)?(.*)/;
+ $mode = '+' unless defined $mode;
+
+ @names = ($spec); # default, maybe overridden below
+
+ if ($spec =~ m:^/(.*)/$:){
+ my $patn = $1;
+ @names = grep(/$patn/, @allexports); # XXX anchor by default?
+ }
+ elsif ($spec =~ m#^:(.*)# and $tagsref){
+ if ($1 eq 'DEFAULT'){
+ @names = @exports;
+ }
+ elsif ($tagsref and $tagdata = $tagsref->{$1}) {
+ @names = @$tagdata;
+ }
+ }
+
+ warn "Import Mode $mode, Spec $spec, Names @names\n" if $Verbose;
+ if ($mode eq '!') {
+ map {delete $imports{$_}} @names; # delete @imports{@names} would be handy :-)
+ }
+ else {
+ @imports{@names} = (1) x @names;
+ }
+ }
+ @imports = keys %imports;
+ }
+
foreach $sym (@imports) {
if (!$exports{$sym}) {
if ($sym !~ s/^&// || !$exports{$sym}) {
- warn qq["$sym" is not exported by the $pack module ],
+ warn qq["$sym" is not exported by the $pkg module ],
"at $callfile line $callline\n";
$oops++;
next;
else {
@imports = @exports;
}
+ warn "Importing from $pkg into $callpkg: ",
+ join(", ",@imports),"\n" if ($Verbose && @imports);
foreach $sym (@imports) {
$type = '&';
$type = $1 if $sym =~ s/^(\W)//;
- *{"${callpack}::$sym"} =
- $type eq '&' ? \&{"${pack}::$sym"} :
- $type eq '$' ? \${"${pack}::$sym"} :
- $type eq '@' ? \@{"${pack}::$sym"} :
- $type eq '%' ? \%{"${pack}::$sym"} :
- $type eq '*' ? *{"${pack}::$sym"} :
+ *{"${callpkg}::$sym"} =
+ $type eq '&' ? \&{"${pkg}::$sym"} :
+ $type eq '$' ? \${"${pkg}::$sym"} :
+ $type eq '@' ? \@{"${pkg}::$sym"} :
+ $type eq '%' ? \%{"${pkg}::$sym"} :
+ $type eq '*' ? *{"${pkg}::$sym"} :
warn "Can't export symbol: $type$sym\n";
}
};
sub import {
- local ($callpack, $callfile, $callline) = caller($ExportLevel);
- my $pack = shift;
- export $pack, $callpack, @_;
+ local ($callpkg, $callfile, $callline) = caller($ExportLevel);
+ my $pkg = shift;
+ export $pkg, $callpkg, @_;
+}
+
+sub export_tags {
+ my ($pkg) = caller;
+ *tags = \%{"${pkg}::EXPORT_TAGS"};
+ push(@{"${pkg}::EXPORT"},
+ map {$tags{$_} ? @{$tags{$_}} : $_} @_ ? @_ : keys %tags);
}
1;
$hint=(reverse sort @goodhints)[0];
# execute the hintsfile:
- eval `cat hints/$hint.pl`;
+ open HINTS, "hints/$hint.pl";
+ @goodhints = <HINTS>;
+ close HINTS;
+ eval join('',@goodhints);
}
# Setup dummy package:
@Other_Att_Keys{qw(EXTRALIBS BSLOADLIBS LDLOADLIBS)} = (1) x 3;
if ($Is_VMS = $Config{'osname'} eq 'VMS') {
- require File::VMSspec;
- import File::VMSspec 'vmsify';
+ require VMS::Filespec;
+ import VMS::Filespec 'vmsify';
}
}
$att{INST_EXE} = "./blib" unless $att{INST_EXE};
$att{MAP_TARGET} = "perl" unless $att{MAP_TARGET};
- $att{LIBPERL_A} = 'libperl.a' unless $att{LIBPERL_A};
+ $att{LIBPERL_A} = $Is_VMS ? 'libperl.olb' : 'libperl.a'
+ unless $att{LIBPERL_A};
}
# make a few simple checks
foreach $dir (@$dirs){
next unless defined $dir; # $att{PERL_SRC} may be undefined
foreach $name (@$names){
- print "checking $dir/$name" if ($trace >= 2);
+ print "Checking $dir/$name " if ($trace >= 2);
if ($Is_VMS) {
$name .= ".exe" unless -x "$dir/$name";
}
if (@fullname=<${thispth}/lib${thislib}.${so}.[0-9]*>){
$fullname=$fullname[-1]; #ATTN: 10 looses against 9!
} elsif (-f ($fullname="$thispth/lib$thislib.$so")
- && (($Config{'dlsrc'} ne "dl_dld") || ($thislib eq "m"))){
+ && (($Config{'dlsrc'} ne "dl_dld.xs") || ($thislib eq "m"))){
} elsif (-f ($fullname="$thispth/lib${thislib}_s.a")
&& ($thislib .= "_s") ){ # we must explicitly ask for _s version
} elsif (-f ($fullname="$thispth/lib$thislib.a")){
}
@ARGV == 1 or die $usage;
chop($pwd = `pwd`);
+# Check for error message from VMS
+if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)#
or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)#
or ($dir, $filename) = ('.', $ARGV[0]);
foreach $typemap (@tm) {
die "Can't find $typemap in $pwd\n" unless -r $typemap;
}
-unshift @tm, qw(../../../typemap ../../typemap ../typemap typemap);
+unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
+ ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
+ ../typemap typemap);
foreach $typemap (@tm) {
open(TYPEMAP, $typemap) || next;
$mode = Typemap;
$_ = shift(@line);
last if /^\s*NOT_IMPLEMENTED_YET/;
last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
- # Catch common error. Much more error checking required here.
- blurt("Error: no tab in $pname argument declaration '$_'\n")
- unless (m/\S+\s*\t\s*\S+/);
($var_type, $var_name, $var_init) =
/\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
+ # Catch common errors. More error checking required here.
+ blurt("Error: no tab in $pname argument declaration '$_'\n")
+ unless (m/\S+\s*\t\s*\S+/);
+ # catch C style argument declaration (this could be made alowable syntax)
+ warn("Warning: ignored semicolon in $pname argument declaration '$_'\n")
+ if ($var_name =~ s/;//g); # eg SV *<tab>name;
+ # catch many errors similar to: SV<tab>* name
+ blurt("Error: invalid $pname argument name '$var_name' (type '$var_type')\n")
+ unless ($var_name =~ m/^&?\w+$/);
if ($var_name =~ /^&/) {
$var_name =~ s/^&//;
$var_addr{$var_name} = 1;
local($ntype);
local($tk);
- blurt("$type not in typemap"), return unless defined($type_kind{$type});
+ blurt("'$type' not in typemap"), return unless defined($type_kind{$type});
($ntype = $type) =~ s/\s*\*/Ptr/g;
$subtype = $ntype;
$subtype =~ s/Ptr$//;
if ($type =~ /^array\(([^,]*),(.*)\)/) {
print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
} else {
- blurt("$type not in typemap"), return
+ blurt("'$type' not in typemap"), return
unless defined($type_kind{$type});
($ntype = $type) =~ s/\s*\*/Ptr/g;
$ntype =~ s/\(\)//g;
}
}
-exit $errors;
+# If this is VMS, the exit status has meaning to the shell, so we
+# use a predictable value (SS$_Abort) rather than an arbitrary
+# number.
+exit $Is_VMS ? 44 : $errors;
use Config;
require Exporter;
@ISA = qw(Exporter);
-@EXPORT = qw(fileparse set_fileparse_fstype basename dirname);
+@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
# fileparse_set_fstype() - specify OS-based rules used in future
# calls to routines in this package
# Any other name uses Unix-style rules
sub fileparse_set_fstype {
- $Fileparse_fstype = $_[0];
+ my($old) = $Fileparse_fstype;
+ $Fileparse_fstype = $_[0] if $_[0];
+ $old;
}
# fileparse() - parse file specification
# ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
# '\.book\d+');
# would yield $base == 'draft',
-# $path == '/virgil/aeneid', and
+# $path == '/virgil/aeneid/' (note trailing slash)
# $tail == '.book7'.
# Similarly, on a system running VMS,
# ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh','\..*');
if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation
else {
($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/);
- $dirpath = $ENV{'PATH'} unless $dirpath;
+ $dirpath = $ENV{'DEFAULT'} unless $dirpath;
}
}
if ($fstype =~ /^MSDOS/i) {
elsif ($fstype =~ /^MAC/i) {
($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/);
}
- else { # default to Unix
+ elsif ($fstype !~ /^VMS/i) { # default to Unix
($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#);
$dirpath = '.' unless $dirpath;
}
}
}
- ($basename,$dirpath,$tail);
+ wantarray ? ($basename,$dirpath,$tail) : $basename;
}
# basename() - returns first element of list returned by fileparse()
sub basename {
- (fileparse(@_))[0];
+ my($name) = shift;
+ (fileparse($name, map("\Q$_\E",@_)))[0];
}
# dirname() - returns device and directory portion of file specification
# Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS
-# filespecs. This differs from the second element of the list returned
+# filespecs except for names ending with a separator, e.g., "/xx/yy/".
+# This differs from the second element of the list returned
# by fileparse() in that the trailing '/' (Unix) or '\' (MSDOS) (and
# the last directory name if the filespec ends in a '/' or '\'), is lost.
my($fstype) = $Fileparse_fstype;
if ($fstype =~ /VMS/i) {
- if (m#/#) { $fstype = '' }
+ if ($_[0] =~ m#/#) { $fstype = '' }
else { return $dirname }
}
if ($fstype =~ /MacOS/i) { return $dirname }
elsif ($fstype =~ /MSDOS/i) {
if ( $dirname =~ /:\\$/) { return $dirname }
chop $dirname;
- $dirname =~ s:[^/]+$:: unless $basename;
+ $dirname =~ s:[^\\]+$:: unless $basename;
$dirname = '.' unless $dirname;
}
else {
$mess =~ s/ does not / should not / ||
$mess =~ s/ not / /;
}
- print stderr $mess,"\n";
+ print STDERR $mess,"\n";
}
else {
$this =~ s/\$file/'$file'/g;
- print stderr "Can't do $this.\n";
+ print STDERR "Can't do $this.\n";
}
if ($disposition eq 'die') { exit 1; }
++$warnings;
package File::Find;
require 5.000;
require Exporter;
+use Config;
+use Cwd;
+use File::Basename;
@ISA = qw(Exporter);
-@EXPORT = qw(find finddepth);
+@EXPORT = qw(find finddepth $name $dir);
# Usage:
# use File::Find;
sub find {
my $wanted = shift;
- chop($cwd = `pwd`);
+ my $cwd = fastcwd();
foreach $topdir (@_) {
(($topdev,$topino,$topmode,$topnlink) = stat($topdir))
|| (warn("Can't stat $topdir: $!\n"), next);
$name = $topdir;
&$wanted;
($fixtopdir = $topdir) =~ s,/$,, ;
+ $fixtopdir =~ s/\.dir$// if $Is_VMS; ;
&finddir($wanted,$fixtopdir,$topnlink);
}
else {
}
}
else {
- unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+ unless (($dir,$_) = fileparse($topdir)) {
($dir,$_) = ('.', $topdir);
}
$name = $topdir;
# Get link count and check for directoriness.
- ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+ ($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_))
+ unless ($nlink || $dont_use_nlink);
if (-d _) {
# It really is a directory, so do it recursively.
if (!$prune && chdir $_) {
+ $name =~ s/\.dir$// if $Is_VMS;
&finddir($wanted,$name,$nlink);
chdir '..';
}
sub finddepth {
my $wanted = shift;
- chop($cwd = `pwd`);
+ $cwd = fastcwd();;
foreach $topdir (@_) {
(($topdev,$topino,$topmode,$topnlink) = stat($topdir))
|| (warn("Can't stat $topdir: $!\n"), next);
if (-d _) {
if (chdir($topdir)) {
($fixtopdir = $topdir) =~ s,/$,, ;
+ $fixtopdir =~ s/\.dir$// if $Is_VMS;
&finddepthdir($wanted,$fixtopdir,$topnlink);
($dir,$_) = ($fixtopdir,'.');
$name = $fixtopdir;
}
}
else {
- unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+ unless (($dir,$_) = fileparse($topdir)) {
($dir,$_) = ('.', $topdir);
}
chdir $dir && &$wanted;
my(@filenames) = readdir(DIR);
closedir(DIR);
- if ($nlink == 2) { # This dir has no subdirectories.
+ if ($nlink == 2 && !$dont_use_nlink) { # This dir has no subdirectories.
for (@filenames) {
next if $_ eq '.';
next if $_ eq '..';
next if $_ eq '..';
$nlink = $prune = 0;
$name = "$dir/$_";
- if ($subcount > 0) { # Seen all the subdirs?
+ if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs?
# Get link count and check for directoriness.
- ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+ ($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_));
if (-d _) {
# It really is a directory, so do it recursively.
if (!$prune && chdir $_) {
+ $name =~ s/\.dir$// if $Is_VMS;
&finddepthdir($wanted,$name,$nlink);
chdir '..';
}
}
}
+if ($Config{'osname'} eq 'VMS') {
+ $Is_VMS = 1;
+ $dont_use_nlink = 1;
+}
+
1;
=item *
a boolean value, which if TRUE will cause C<rmtree> to
-print a message each time it tries to delete a file,
-giving the name of the file, and indicating whether
-it's using C<rmdir> or C<unlink> to remove it.
+print a message each time it examines a file, giving the
+name of the file, and indicating whether it's using C<rmdir>
+or C<unlink> to remove it, or that it's skipping it.
(defaults to FALSE)
=item *
a boolean value, which if TRUE will cause C<rmtree> to
-skip any files to which you do not have write access.
-This will change in the future when a criterion for
-'delete permission' is settled. (defaults to FALSE)
+skip any files to which you do not have delete access
+(if running under VMS) or write access (if running
+under another OS). This will change in the future when
+a criterion for 'delete permission' under OSs other
+than VMS is settled. (defaults to FALSE)
=back
=head1 REVISION
-This document was last revised 29-Jan-1995, for perl 5.001
+This document was last revised 08-Mar-1995, for perl 5.001
=cut
@ISA = qw( Exporter );
@EXPORT = qw( mkpath rmtree );
+$Is_VMS = $Config{'osname'} eq 'VMS';
+
sub mkpath{
my($paths, $verbose, $mode) = @_;
# $paths -- either a path string or ref to list of paths
$paths = [$paths] unless ref $paths;
my(@created);
foreach $path (@$paths){
- next if -d $path;
+ next if -d $path;
my(@p);
foreach(split(/\//, $path)){
push(@p, $_);
$root =~ s#/$##;
if (-d $root) {
opendir(D,$root);
+ $root =~ s#\.dir$## if $Is_VMS;
@files = map("$root/$_", grep $_!~/^\.{1,2}$/, readdir(D));
closedir(D);
$count += rmtree(\@files,$verbose,$safe);
- next if ($safe && !(-w $root));
+ if ($safe &&
+ ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
+ print "skipped $root\n" if $verbose;
+ next;
+ }
print "rmdir $root\n" if $verbose;
(rmdir $root && ++$count) or carp "Can't remove directory $root: $!";
}
else {
- next if ($safe && !(-w $root));
+ if ($safe &&
+ ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
+ print "skipped $root\n" if $verbose;
+ next;
+ }
print "unlink $root\n" if $verbose;
(unlink($root) && ++$count) or carp "Can't unlink file $root: $!";
}
%OVERLOAD = (
# Anonymous subroutines:
-'+' => sub {new BigInt &badd},
-'-' => sub {new BigInt
+'+' => sub {new Math::BigInt &badd},
+'-' => sub {new Math::BigInt
$_[2]? bsub($_[1],${$_[0]}) : bsub(${$_[0]},$_[1])},
-'<=>' => sub {new BigInt
+'<=>' => sub {new Math::BigInt
$_[2]? bcmp($_[1],${$_[0]}) : bcmp(${$_[0]},$_[1])},
-'cmp' => sub {new BigInt
+'cmp' => sub {new Math::BigInt
$_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])},
-'*' => sub {new BigInt &bmul},
-'/' => sub {new BigInt
+'*' => sub {new Math::BigInt &bmul},
+'/' => sub {new Math::BigInt
$_[2]? scalar bdiv($_[1],${$_[0]}) :
scalar bdiv(${$_[0]},$_[1])},
-'%' => sub {new BigInt
+'%' => sub {new Math::BigInt
$_[2]? bmod($_[1],${$_[0]}) : bmod(${$_[0]},$_[1])},
-'**' => sub {new BigInt
+'**' => sub {new Math::BigInt
$_[2]? bpow($_[1],${$_[0]}) : bpow(${$_[0]},$_[1])},
-'neg' => sub {new BigInt &bneg},
-'abs' => sub {new BigInt &babs},
+'neg' => sub {new Math::BigInt &bneg},
+'abs' => sub {new Math::BigInt &babs},
qw(
"" stringify
0+ numify) # Order of arguments unsignificant
);
+$NaNOK=1;
+
sub new {
my $foo = bnorm($_[1]);
- die "Not a number initialized to BigInt" if $foo eq "NaN";
+ die "Not a number initialized to Math::BigInt" if !$NaNOK && $foo eq "NaN";
bless \$foo;
}
sub stringify { "${$_[0]}" }
--- /dev/null
+package SubstrHash;
+use Carp;
+
+sub TIEHASH {
+ my $pack = shift;
+ my ($klen, $vlen, $tsize) = @_;
+ my $rlen = 1 + $klen + $vlen;
+ $tsize = findprime($tsize * 1.1); # Allow 10% empty.
+ $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
+ $$self[0] x= $rlen * $tsize;
+ $self;
+}
+
+sub FETCH {
+ local($self,$key) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ return undef;
+ }
+ elsif (ord($record) == 1) {
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ return substr($record, 1+$klen, $vlen);
+ }
+ &rehash;
+ }
+}
+
+sub STORE {
+ local($self,$key,$val) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ croak("Table is full") if $self[5] == $tsize;
+ croak(qq/Value "$val" is not $vlen characters long./)
+ if length($val) != $vlen;
+ my $writeoffset;
+
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ $record = "\2". $key . $val;
+ die "panic" unless length($record) == $rlen;
+ $writeoffset = $offset unless defined $writeoffset;
+ substr($$self[0], $writeoffset, $rlen) = $record;
+ ++$$self[5];
+ return;
+ }
+ elsif (ord($record) == 1) {
+ $writeoffset = $offset unless defined $writeoffset;
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ $record = "\2". $key . $val;
+ die "panic" unless length($record) == $rlen;
+ substr($$self[0], $offset, $rlen) = $record;
+ return;
+ }
+ &rehash;
+ }
+}
+
+sub DELETE {
+ local($self,$key) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ return undef;
+ }
+ elsif (ord($record) == 1) {
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ substr($$self[0], $offset, 1) = "\1";
+ return substr($record, 1+$klen, $vlen);
+ --$$self[5];
+ }
+ &rehash;
+ }
+}
+
+sub FIRSTKEY {
+ local($self) = @_;
+ $$self[6] = -1;
+ &NEXTKEY;
+}
+
+sub NEXTKEY {
+ local($self) = @_;
+ local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
+ for (++$iterix; $iterix < $tsize; ++$iterix) {
+ next unless substr($$self[0], $iterix * $rlen, 1) eq "\2";
+ $$self[6] = $iterix;
+ return substr($$self[0], $iterix * $rlen + 1, $klen);
+ }
+ $$self[6] = -1;
+ undef;
+}
+
+sub hashkey {
+ croak(qq/Key "$key" is not $klen characters long.\n/)
+ if length($key) != $klen;
+ $hash = 2;
+ for (unpack('C*', $key)) {
+ $hash = $hash * 33 + $_;
+ }
+ $hash = $hash - int($hash / $tsize) * $tsize
+ if $hash >= $tsize;
+ $hash = 1 unless $hash;
+ $hashbase = $hash;
+}
+
+sub rehash {
+ $hash += $hashbase;
+ $hash -= $tsize if $hash >= $tsize;
+}
+
+sub findprime {
+ use integer;
+
+ my $num = shift;
+ $num++ unless $num % 2;
+
+ $max = int sqrt $num;
+
+ NUM:
+ for (;; $num += 2) {
+ for ($i = 3; $i <= $max; $i += 2) {
+ next NUM unless $num % $i;
+ }
+ return $num;
+ }
+}
+
+1;
local($name) = @_;
$name =~ y/a-z/A-Z/;
$name = "LOG_$name" unless $name =~ /^LOG_/;
- $name = "syslog'$name";
+ $name = "Sys::Syslog::$name";
eval(&$name) || -1;
}
+# Term::Cap.pm -- Termcap interface routines
package Term::Cap;
-require 5.000;
-require Exporter;
-use Carp;
-@ISA = qw(Exporter);
-@EXPORT = qw(&Tgetent &Tputs &Tgoto $ispeed $ospeed %TC);
-
-# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $
+# Converted to package on 25 Feb 1994 <sanders@bsdi.com>
#
# Usage:
# require 'ioctl.pl';
-# ioctl(TTY,$TIOCGETP,$foo);
-# ($ispeed,$ospeed) = unpack('cc',$foo);
-# use Termcap;
-# &Tgetent('vt100'); # sets $TC{'cm'}, etc.
-# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
-# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
+# ioctl(TTY,$TIOCGETP,$sgtty);
+# ($ispeed,$ospeed) = unpack('cc',$sgtty);
+#
+# require Term::Cap;
+#
+# $term = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
+# sets $term->{'_cm'}, etc.
+# $this->Trequire(qw/ce ku kd/);
+# die unless entries are defined for the terminal
+# $term->Tgoto('cm', $col, $row, $FH);
+# $term->Tputs('dl', $cnt = 1, $FH);
+# $this->Tpad($string, $cnt = 1, $FH);
+# processes a termcap string and adds padding if needed
+# if $FH is undefined these just return the string
+#
+# CHANGES:
+# Converted to package
+# Allows :tc=...: in $ENV{'TERMCAP'} (flows to default termcap file)
+# Now die's properly if it can't open $TERMCAP or if the eval $loop fails
+# Tputs() results are cached (use Tgoto or Tpad to avoid)
+# Tgoto() will do output if $FH is passed (like Tputs without caching)
+# Supports POSIX termios speeds and old style speeds
+# Searches termcaps properly (TERMPATH, etc)
+# The output routines are optimized for cached Tputs().
+# $this->{_xx} is the raw termcap data and $this->{xx} is a
+# cached and padded string for count == 1.
#
-sub Tgetent {
- local($TERM) = @_;
- local($TERMCAP,$_,$entry,$loop,$field);
- warn "Tgetent: no ospeed set" unless $ospeed;
- foreach $key (keys(%TC)) {
- delete $TC{$key};
+# internal routines
+sub getenv { defined $ENV{$_[0]} ? $ENV{$_[0]} : ''; }
+sub termcap_path {
+ local @termcap_path = ('/etc/termcap', '/usr/share/misc/termcap');
+ local $v;
+ if ($v = getenv(TERMPATH)) {
+ # user specified path
+ @termcap_path = split(':', $v);
+ } else {
+ # default path
+ @termcap_path = ('/etc/termcap', '/usr/share/misc/termcap');
+ $v = getenv(HOME);
+ unshift(@termcap_path, $v . '/.termcap') if $v;
}
- $TERM = $ENV{'TERM'} unless $TERM;
- $TERM =~ s/(\W)/\\$1/g;
- $TERMCAP = $ENV{'TERMCAP'};
- $TERMCAP = '/etc/termcap' unless $TERMCAP;
- if ($TERMCAP !~ m:^/:) {
- if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) {
- $TERMCAP = '/etc/termcap';
- }
- }
- if ($TERMCAP =~ m:^/:) {
- $entry = '';
+ # we always search TERMCAP first
+ $v = getenv(TERMCAP);
+ unshift(@termcap_path, $v) if $v =~ /^\//;
+ grep(-f, @termcap_path);
+}
+
+sub Tgetent {
+ local($type) = shift;
+ local($this) = @_;
+ local($TERM,$TERMCAP,$term,$entry,$cap,$loop,$field,$entry,$_);
+
+ warn "Tgetent: no ospeed set\n" unless $this->{OSPEED} > 0;
+ $this->{DECR} = 10000 / $this->{OSPEED} if $this->{OSPEED} > 50;
+ $term = $TERM = $this->{TERM} =
+ $this->{TERM} || getenv(TERM) || die "Tgetent: TERM not set\n";
+
+ $TERMCAP = getenv(TERMCAP);
+ $TERMCAP = '' if $TERMCAP =~ m:^/: || $TERMCAP !~ /(^|\|)$TERM[:\|]/;
+ local @termcap_path = &termcap_path;
+ die "Tgetent: Can't find a valid termcap file\n"
+ unless @termcap_path || $TERMCAP;
+
+ # handle environment TERMCAP, setup for continuation if needed
+ $entry = $TERMCAP;
+ $entry =~ s/:tc=([^:]+):/:/ && ($TERM = $1);
+ if ($TERMCAP eq '' || $1) { # the search goes on
+ local $first = $TERMCAP eq '' ? 1 : 0; # make it pretty
+ local $max = 32; # max :tc=...:'s
+ local $state = 1; # 0 == finished
+ # 1 == next file
+ # 2 == search again
do {
+ if ($state == 1) {
+ $TERMCAP = shift @termcap_path
+ || die "Tgetent: failed lookup on $TERM\n";
+ } else {
+ $max-- || die "Tgetent: termcap loop at $TERM\n";
+ $state = 1; # back to default state
+ }
+
+ open(TERMCAP,"< $TERMCAP\0") || die "Tgetent: $TERMCAP: $!\n";
+ # print STDERR "Trying... $TERMCAP\n";
$loop = "
- open(TERMCAP,'<$TERMCAP') || croak \"Can't open $TERMCAP\";
- while (<TERMCAP>) {
- next if /^#/;
- next if /^\t/;
- if (/(^|\\|)${TERM}[:\\|]/) {
- chop;
- while (chop eq '\\\\') {
- \$_ .= <TERMCAP>;
+ while (<TERMCAP>) {
+ next if /^\t/;
+ next if /^#/;
+ if (/(^|\\|)${TERM}[:\\|]/) {
chop;
+ s/^[^:]*:// unless \$first++;
+ \$state = 0;
+ while (chop eq '\\\\') {
+ \$_ .= <TERMCAP>;
+ chop;
+ }
+ \$_ .= ':';
+ last;
}
- \$_ .= ':';
- last;
}
- }
- close TERMCAP;
- \$entry .= \$_;
+ \$entry .= \$_;
";
eval $loop;
- } while s/:tc=([^:]+):/:/ && ($TERM = $1);
- $TERMCAP = $entry;
+ die $@ if $@;
+ #print STDERR "$TERM: $_\n--------\n"; # DEBUG
+ close TERMCAP;
+ # If :tc=...: found then search this file again
+ $entry =~ s/:tc=([^:]+):/:/ && ($TERM = $1, $state = 2);
+ } while $state != 0;
}
+ die "Tgetent: Can't find $term\n" unless $entry ne '';
+ $entry =~ s/:\s+:/:/g;
+ $this->{TERMCAP} = $entry;
+ #print STDERR $entry, "\n"; # DEBUG
- foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
+ # Precompile $entry into the object
+ foreach $field (split(/:[\s:\\]*/,$entry)) {
if ($field =~ /^\w\w$/) {
- $TC{$field} = 1;
+ $this->{'_' . $field} = 1 unless defined $this->{'_' . $1};
+ }
+ elsif ($field =~ /^(\w\w)\@/) {
+ $this->{'_' . $1} = "";
}
elsif ($field =~ /^(\w\w)#(.*)/) {
- $TC{$1} = $2 unless defined $TC{$1};
+ $this->{'_' . $1} = $2 unless defined $this->{'_' . $1};
}
elsif ($field =~ /^(\w\w)=(.*)/) {
- $entry = $1;
+ next if defined $this->{'_' . ($cap = $1)};
$_ = $2;
s/\\E/\033/g;
s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
s/\^(.)/pack('c',ord($1) & 31)/eg;
s/\\(.)/$1/g;
s/\377/^/g;
- $TC{$entry} = $_ unless defined $TC{$entry};
+ $this->{'_' . $cap} = $_;
}
+ # else { warn "Tgetent: junk in $term: $field\n"; }
}
- $TC{'pc'} = "\0" unless defined $TC{'pc'};
- $TC{'bc'} = "\b" unless defined $TC{'bc'};
+ $this->{'_pc'} = "\0" unless defined $this->{'_pc'};
+ $this->{'_bc'} = "\b" unless defined $this->{'_bc'};
+ $this;
}
-@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
+# delays for old style speeds
+@Tpad = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
+
+# $term->Tpad($string, $cnt, $FH);
+sub Tpad {
+ local($this, $string, $cnt, $FH) = @_;
+ local($decr, $ms);
-sub Tputs {
- local($string,$affcnt,$FH) = @_;
- local($ms);
if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
$ms = $1;
- $ms *= $affcnt if $2;
+ $ms *= $cnt if $2;
$string = $3;
- $decr = $Tputs[$ospeed];
+ $decr = $this->{OSPEED} < 50 ? $Tpad[$this->{OSPEED}] : $this->{DECR};
if ($decr > .1) {
$ms += $decr / 2;
- $string .= $TC{'pc'} x ($ms / $decr);
+ $string .= $this->{'_pc'} x ($ms / $decr);
}
}
print $FH $string if $FH;
$string;
}
+# $term->Tputs($cap, $cnt, $FH);
+sub Tputs {
+ local($this, $cap, $cnt, $FH) = @_;
+ local $string;
+
+ if ($cnt > 1) {
+ $string = Tpad($this, $this->{'_' . $cap}, $cnt);
+ } else {
+ $string = defined $this->{$cap} ? $this->{$cap} :
+ ($this->{$cap} = Tpad($this, $this->{'_' . $cap}, 1));
+ }
+ print $FH $string if $FH;
+ $string;
+}
+
+# %% output `%'
+# %d output value as in printf %d
+# %2 output value as in printf %2d
+# %3 output value as in printf %3d
+# %. output value as in printf %c
+# %+x add x to value, then do %.
+#
+# %>xy if value > x then add y, no output
+# %r reverse order of two parameters, no output
+# %i increment by one, no output
+# %B BCD (16*(value/10)) + (value%10), no output
+#
+# %n exclusive-or all parameters with 0140 (Datamedia 2500)
+# %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
+#
+# $term->Tgoto($cap, $col, $row, $FH);
sub Tgoto {
- local($string) = shift(@_);
- local($result) = '';
- local($after) = '';
- local($code,$tmp) = @_;
- local(@tmp);
- @tmp = ($tmp,$code);
- local($online) = 0;
+ local($this, $cap, $code, $tmp, $FH) = @_;
+ local $string = $this->{'_' . $cap};
+ local $result = '';
+ local $after = '';
+ local $online = 0;
+ local @tmp = ($tmp,$code);
+ local $cnt = $code;
+
while ($string =~ /^([^%]*)%(.)(.*)/) {
$result .= $1;
$code = $2;
$tmp = shift(@tmp);
if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
if ($online) {
- ++$tmp, $after .= $TC{'up'} if $TC{'up'};
+ ++$tmp, $after .= $this->{'_up'} if $this->{'_up'};
}
else {
- ++$tmp, $after .= $TC{'bc'};
+ ++$tmp, $after .= $this->{'_bc'};
}
}
$result .= sprintf("%c",$tmp);
return "OOPS";
}
}
- $result . $string . $after;
+ $string = Tpad($this, $result . $string . $after, $cnt);
+ print $FH $string if $FH;
+ $string;
+}
+
+# $this->Trequire($cap1, $cap2, ...);
+sub Trequire {
+ local $this = shift;
+ local $_;
+ foreach (@_) {
+ die "Trequire: Terminal does not support: $_\n"
+ unless defined $this->{'_' . $_} && $this->{'_' . $_};
+ }
}
1;
}
}
+# The TieHash::Std package implements standard perl hash behaviour.
+# It exists to act as a base class for classes which only wish to
+# alter some parts of their behaviour.
+
+package TieHash::Std;
+@ISA = qw(TieHash);
+
+sub TIEHASH { bless {}, $_[0] }
+sub STORE { $_[0]->{$_[1]} = $_[2] }
+sub FETCH { $_[0]->{$_[1]} }
+sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
+sub NEXTKEY { each %{$_[0]} }
+sub EXISTS { exists $_[0]->{$_[1]} }
+sub DELETE { delete $_[0]->{$_[1]} }
+sub CLEAR { %{$_[0]} = () }
+
1;
}
sub panic {
+ package DB;
+
select(STDERR);
print "\npanic: @_\n";
# stack traceback gratefully borrowed from perl debugger
- local($i,$_);
- local($p,$f,$l,$s,$h,$a,@a,@sub);
+ local $_;
+ my $i;
+ my ($p,$f,$l,$s,$h,$a,@a,@frames);
for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
- @a = @DB'args;
+ @a = @args;
for (@a) {
if (/^StB\000/ && length($_) == length($_main{'_main'})) {
$_ = sprintf("%s",$_);
}
$w = $w ? '@ = ' : '$ = ';
$a = $h ? '(' . join(', ', @a) . ')' : '';
- push(@sub, "$w&$s$a from file $f line $l\n");
+ push(@frames, "$w&$s$a from file $f line $l\n");
}
- for ($i=0; $i <= $#sub; $i++) {
- print $sub[$i];
+ for ($i=0; $i <= $#frames; $i++) {
+ print $frames[$i];
}
exit 1;
}
'NaN';
} else {
local($gcd) = &'bgcd($num,$dom);
+ $gcd =~ s/^-/+/;
if ($gcd ne '+1') {
$num = &'bdiv($num,$gcd);
$dom = &'bdiv($dom,$gcd);
".\n");
print OUT "\nEnter h for help.\n\n";
+@ARGS;
+
sub DB {
&save;
- ($package, $filename, $line) = caller;
+ ($pkg, $filename, $line) = caller;
$usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
- "package $package;"; # this won't let them modify, alas
+ "package $pkg;"; # this won't let them modify, alas
local(*dbline) = "::_<$filename";
$max = $#dbline;
if (($stop,$action) = split(/\0/,$dbline{$line})) {
if ($emacs) {
print OUT "\032\032$filename:$line:0\n";
} else {
- $prefix = $sub =~ /'|::/ ? "" : "${package}::";
+ $prefix = $sub =~ /'|::/ ? "" : "${pkg}::";
$prefix .= "$sub($filename:";
if (length($prefix) > 30) {
print OUT "$prefix$line):\n$line:\t",$dbline[$line];
print OUT $subname,"\n";
}
next CMD; };
- $cmd =~ s/^X\b/V $package/;
+ $cmd =~ s/^X\b/V $pkg/;
$cmd =~ /^V$/ && do {
- $cmd = "V $package"; };
+ $cmd = "V $pkg"; };
$cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
local ($savout) = select(OUT);
$packname = $1;
$cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
$subname = $1;
$cond = $2 || '1';
- $subname = "${package}::" . $subname
+ $subname = "${pkg}::" . $subname
unless $subname =~ /'|::/;
$subname = "main" . $subname if substr($subname,0,1) eq "'";
$subname = "main" . $subname if substr($subname,0,2) eq "::";
$evalarg = $post; &eval;
}
}
- ($@, $!, $,, $/, $\) = @saved;
+ ($@, $!, $,, $/, $\, $^W) = @saved;
+ ();
}
sub save {
sub main'chdir {
local($newdir) = shift;
+ $newdir =~ s|/{2,}|/|g;
if (chdir $newdir) {
if ($newdir =~ m#^/#) {
$ENV{'PWD'} = $newdir;
SV* sv;
{
MAGIC* mg;
- char *s;
+ char *junk;
STRLEN len;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
}
}
- s = SvPV(sv, len);
+ junk = SvPV(sv, len);
return len;
}
register I32 paren;
register char *s;
register I32 i;
+ char *t;
switch (*mg->mg_ptr) {
case '1': case '2': case '3': case '4':
getparen:
if (curpm->op_pmregexp &&
paren <= curpm->op_pmregexp->nparens &&
- (s = curpm->op_pmregexp->startp[paren]) ) {
- i = curpm->op_pmregexp->endp[paren] - s;
+ (s = curpm->op_pmregexp->startp[paren]) &&
+ (t = curpm->op_pmregexp->endp[paren]) ) {
+ i = t - s;
if (i >= 0)
return i;
- else
- return 0;
}
- else
- return 0;
}
+ return 0;
break;
case '+':
if (curpm) {
return 0;
goto getparen;
}
+ return 0;
break;
case '`':
if (curpm) {
i = curpm->op_pmregexp->startp[0] - s;
if (i >= 0)
return i;
- else
- return 0;
}
- else
- return 0;
}
- break;
+ return 0;
case '\'':
if (curpm) {
if (curpm->op_pmregexp &&
(s = curpm->op_pmregexp->endp[0]) ) {
return (STRLEN) (curpm->op_pmregexp->subend - s);
}
- else
- return 0;
}
- break;
+ return 0;
case ',':
return (STRLEN)ofslen;
case '\\':
register I32 paren;
register char *s;
register I32 i;
+ char *t;
switch (*mg->mg_ptr) {
+ case '\001': /* ^A */
+ sv_setsv(sv, bodytarget);
+ break;
case '\004': /* ^D */
sv_setiv(sv,(I32)(debug & 32767));
break;
if (curpm->op_pmregexp &&
paren <= curpm->op_pmregexp->nparens &&
(s = curpm->op_pmregexp->startp[paren]) &&
- curpm->op_pmregexp->endp[paren] ) {
- i = curpm->op_pmregexp->endp[paren] - s;
- if (i >= 0)
+ (t = curpm->op_pmregexp->endp[paren]) ) {
+ i = t - s;
+ if (i >= 0) {
+ MAGIC *tmg;
sv_setpvn(sv,s,i);
- else
- sv_setsv(sv,&sv_undef);
+ if (tainting && (tmg = mg_find(sv,'t')))
+ tmg->mg_len = 0; /* guarantee $1 untainted */
+ break;
+ }
}
- else
- sv_setsv(sv,&sv_undef);
}
+ sv_setsv(sv,&sv_undef);
break;
case '+':
if (curpm) {
paren = curpm->op_pmregexp->lastparen;
if (paren)
goto getparen;
- else
- sv_setsv(sv,&sv_undef);
}
+ sv_setsv(sv,&sv_undef);
break;
case '`':
if (curpm) {
if (curpm->op_pmregexp &&
(s = curpm->op_pmregexp->subbeg) ) {
i = curpm->op_pmregexp->startp[0] - s;
- if (i >= 0)
+ if (i >= 0) {
sv_setpvn(sv,s,i);
- else
- sv_setpvn(sv,"",0);
+ break;
+ }
}
- else
- sv_setpvn(sv,"",0);
}
+ sv_setsv(sv,&sv_undef);
break;
case '\'':
if (curpm) {
if (curpm->op_pmregexp &&
(s = curpm->op_pmregexp->endp[0]) ) {
sv_setpvn(sv,s, curpm->op_pmregexp->subend - s);
+ break;
}
- else
- sv_setpvn(sv,"",0);
}
+ sv_setsv(sv,&sv_undef);
break;
case '.':
#ifndef lint
{
register char *s;
I32 i;
+ SV** svp;
- i = whichsig(mg->mg_ptr); /* ...no, a brick */
- if (!i && (dowarn || strEQ(mg->mg_ptr,"ALARM")))
- warn("No such signal: SIG%s", mg->mg_ptr);
+ s = mg->mg_ptr;
+ if (*s == '_') {
+ if (strEQ(s,"__DIE__"))
+ svp = &diehook;
+ else if (strEQ(s,"__WARN__"))
+ svp = &warnhook;
+ else if (strEQ(s,"__PARSE__"))
+ svp = &parsehook;
+ else
+ croak("No such hook: %s", s);
+ i = 0;
+ }
+ else {
+ i = whichsig(s); /* ...no, a brick */
+ if (!i) {
+ if (dowarn || strEQ(s,"ALARM"))
+ warn("No such signal: SIG%s", s);
+ return 0;
+ }
+ }
if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
- (void)signal(i,sighandler);
+ if (i)
+ (void)signal(i,sighandler);
+ else
+ *svp = SvREFCNT_inc(sv);
return 0;
}
s = SvPV_force(sv,na);
- if (strEQ(s,"IGNORE"))
-#ifndef lint
- (void)signal(i,SIG_IGN);
-#else
- ;
-#endif
- else if (strEQ(s,"DEFAULT") || !*s)
- (void)signal(i,SIG_DFL);
+ if (strEQ(s,"IGNORE")) {
+ if (i)
+ (void)signal(i,SIG_IGN);
+ else
+ *svp = 0;
+ }
+ else if (strEQ(s,"DEFAULT") || !*s) {
+ if (i)
+ (void)signal(i,SIG_DFL);
+ else
+ *svp = 0;
+ }
else {
- (void)signal(i,sighandler);
if (!strchr(s,':') && !strchr(s,'\'')) {
sprintf(tokenbuf, "main::%s",s);
sv_setpv(sv,tokenbuf);
}
+ if (i)
+ (void)signal(i,sighandler);
+ else
+ *svp = SvREFCNT_inc(sv);
}
return 0;
}
SV* sv;
MAGIC* mg;
{
- tainted = TRUE;
+ if (mg->mg_len & 1)
+ tainted = TRUE;
+ else if (mg->mg_len & 2 && mg->mg_obj == sv) /* kludge */
+ tainted = TRUE;
return 0;
}
SV* sv;
MAGIC* mg;
{
- if (!tainted) {
- if (!SvMAGICAL(sv))
- SvMAGICAL_on(sv);
- sv_unmagic(sv, 't');
+ if (localizing) {
+ if (localizing == 1)
+ mg->mg_len <<= 1;
+ else
+ mg->mg_len >>= 1;
}
+ else if (tainted)
+ mg->mg_len |= 1;
+ else
+ mg->mg_len &= ~1;
return 0;
}
I32 i;
STRLEN len;
switch (*mg->mg_ptr) {
+ case '\001': /* ^A */
+ sv_setsv(bodytarget, sv);
+ break;
case '\004': /* ^D */
debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
DEBUG_x(dump_all());
dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
break;
case '.':
- if (localizing)
- save_sptr((SV**)&last_in_gv);
+ if (localizing) {
+ if (localizing == 1)
+ save_sptr((SV**)&last_in_gv);
+ }
else if (SvOK(sv))
IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
break;
compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
break;
case '?':
- statusvalue = U_S(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ statusvalue = FIXSTATUS(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
break;
case '!':
- errno = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); /* will anyone ever use this? */
+ SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),SS$_ABORT); /* will anyone ever use this? */
break;
case '<':
uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
#else
#ifdef HAS_SETREUID
(void)setreuid((Uid_t)uid, (Uid_t)-1);
+#else
#ifdef HAS_SETRESUID
(void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1);
#else
#endif
#endif
#endif
- uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ uid = (I32)getuid();
tainting |= (euid != uid || egid != gid);
break;
case '>':
#else
if (gid == egid) /* special case $( = $) */
(void)setgid(gid);
- else
+ else {
+ gid = (I32)getgid();
croak("setrgid() not implemented");
+ }
#endif
#endif
#endif
#else
if (egid == gid) /* special case $) = $( */
(void)setgid(egid);
- else
+ else {
+ egid = (I32)getegid();
croak("setegid() not implemented");
+ }
#endif
#endif
#endif
#define MGf_TAINTEDDIR 1
#define MGf_REFCOUNTED 2
#define MGf_GSKIP 4
+
+#define MGf_MINMATCH 1
+
#define MgTAINTEDDIR(mg) (mg->mg_flags & MGf_TAINTEDDIR)
#define MgTAINTEDDIR_on(mg) (mg->mg_flags |= MGf_TAINTEDDIR)
static void xs_init _((void));
static PerlInterpreter *my_perl;
-/* This value may be raised by extensions for testing purposes */
-int perl_destruct_level = 0; /* 0=none, 1=full, 2=full with checks */
-
int
main(argc, argv, env)
int argc;
exitstatus = perl_run( my_perl );
- perl_destruct( my_perl, perl_destruct_level );
+ perl_destruct( my_perl );
perl_free( my_perl );
exit( exitstatus );
static OP *too_few_arguments _((OP *op));
static OP *too_many_arguments _((OP *op));
static void null _((OP* op));
+static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, I32 seq,
+ CV* startcv, I32 cx_ix));
static OP *
no_fh_allowed(op)
{
int type = op->op_type;
if (type != OP_AELEM && type != OP_HELEM) {
- sprintf(tokenbuf, "Can't use %s as left arg of implicit ->",
+ sprintf(tokenbuf, "Can't use subscript on %s",
op_name[type]);
yyerror(tokenbuf);
if (type == OP_RV2HV || type == OP_ENTERSUB)
- warn("(Did you mean $ instead of %c?)\n",
+ warn("(Did you mean $ or @ instead of %c?)\n",
type == OP_RV2HV ? '%' : '&');
}
}
sv_upgrade(sv, SVt_PVNV);
sv_setpv(sv, name);
av_store(comppad_name, off, sv);
- SvNVX(sv) = (double)cop_seqmax;
+ SvNVX(sv) = (double)999999999;
SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
if (!min_intro_pending)
min_intro_pending = off;
return off;
}
-PADOFFSET
-pad_findmy(name)
+static PADOFFSET
+pad_findlex(name, newoff, seq, startcv, cx_ix)
char *name;
+PADOFFSET newoff;
+I32 seq;
+CV* startcv;
+I32 cx_ix;
{
+ CV *cv;
I32 off;
SV *sv;
- SV **svp = AvARRAY(comppad_name);
register I32 i;
register CONTEXT *cx;
int saweval;
- AV *curlist;
- AV *curname;
- CV *cv;
- I32 seq = cop_seqmax;
- /* The one we're looking for is probably just before comppad_name_fill. */
- for (off = comppad_name_fill; off > 0; off--) {
- if ((sv = svp[off]) &&
- sv != &sv_undef &&
- seq <= SvIVX(sv) &&
- seq > (I32)SvNVX(sv) &&
- strEQ(SvPVX(sv), name))
- {
- return (PADOFFSET)off;
+ for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
+ AV* curlist = CvPADLIST(cv);
+ SV** svp = av_fetch(curlist, 0, FALSE);
+ AV *curname;
+ if (!svp || *svp == &sv_undef)
+ break;
+ curname = (AV*)*svp;
+ svp = AvARRAY(curname);
+ for (off = AvFILL(curname); off > 0; off--) {
+ if ((sv = svp[off]) &&
+ sv != &sv_undef &&
+ seq <= SvIVX(sv) &&
+ seq > (I32)SvNVX(sv) &&
+ strEQ(SvPVX(sv), name))
+ {
+ I32 depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1;
+ AV *oldpad = (AV*)*av_fetch(curlist, depth, FALSE);
+ SV *oldsv = *av_fetch(oldpad, off, TRUE);
+ if (!newoff) { /* Not a mere clone operation. */
+ SV *sv = NEWSV(1103,0);
+ newoff = pad_alloc(OP_PADSV, SVs_PADMY);
+ sv_upgrade(sv, SVt_PVNV);
+ sv_setpv(sv, name);
+ av_store(comppad_name, newoff, sv);
+ SvNVX(sv) = (double)curcop->cop_seq;
+ SvIVX(sv) = 999999999; /* A ref, intro immediately */
+ SvFLAGS(sv) |= SVf_FAKE;
+ }
+ av_store(comppad, newoff, SvREFCNT_inc(oldsv));
+ SvFLAGS(compcv) |= SVpcv_CLONE;
+ return newoff;
+ }
}
}
*/
saweval = 0;
- for (i = cxstack_ix; i >= 0; i--) {
+ for (i = cx_ix; i >= 0; i--) {
cx = &cxstack[i];
switch (cx->cx_type) {
default:
+ if (i == 0 && saweval) {
+ seq = cxstack[saweval].blk_oldcop->cop_seq;
+ return pad_findlex(name, newoff, seq, main_cv, 0);
+ }
break;
case CXt_EVAL:
+ if (cx->blk_eval.old_op_type != OP_ENTEREVAL)
+ return 0; /* require must have its own scope */
saweval = i;
break;
case CXt_SUB:
if (!saweval)
return 0;
cv = cx->blk_sub.cv;
- if (debstash && CvSTASH(cv) == debstash) /* ignore DB'* scope */
+ if (debstash && CvSTASH(cv) == debstash) { /* ignore DB'* scope */
+ saweval = i; /* so we know where we were called from */
continue;
- seq = cxstack[saweval].blk_oldcop->cop_seq;
- curlist = CvPADLIST(cv);
- curname = (AV*)*av_fetch(curlist, 0, FALSE);
- svp = AvARRAY(curname);
- for (off = AvFILL(curname); off > 0; off--) {
- if ((sv = svp[off]) &&
- sv != &sv_undef &&
- seq <= SvIVX(sv) &&
- seq > (I32)SvNVX(sv) &&
- strEQ(SvPVX(sv), name))
- {
- PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
- AV *oldpad = (AV*)*av_fetch(curlist, CvDEPTH(cv), FALSE);
- SV *oldsv = *av_fetch(oldpad, off, TRUE);
- SV *sv = NEWSV(1103,0);
- sv_upgrade(sv, SVt_PVNV);
- sv_setpv(sv, name);
- av_store(comppad_name, newoff, sv);
- SvNVX(sv) = (double)curcop->cop_seq;
- SvIVX(sv) = 999999999; /* A ref, intro immediately */
- av_store(comppad, newoff, SvREFCNT_inc(oldsv));
- return newoff;
- }
}
- return 0;
+ seq = cxstack[saweval].blk_oldcop->cop_seq;
+ return pad_findlex(name, newoff, seq, cv, i-1);
}
}
- if (!saweval)
- return 0;
+ return 0;
+}
- /* It's stupid to dup this code. main should be stored in a CV. */
- seq = cxstack[saweval].blk_oldcop->cop_seq;
- svp = AvARRAY(padname);
- for (off = AvFILL(padname); off > 0; off--) {
+PADOFFSET
+pad_findmy(name)
+char *name;
+{
+ I32 off;
+ SV *sv;
+ SV **svp = AvARRAY(comppad_name);
+ I32 seq = cop_seqmax;
+
+ /* The one we're looking for is probably just before comppad_name_fill. */
+ for (off = comppad_name_fill; off > 0; off--) {
if ((sv = svp[off]) &&
sv != &sv_undef &&
seq <= SvIVX(sv) &&
seq > (I32)SvNVX(sv) &&
strEQ(SvPVX(sv), name))
{
- PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
- SV *oldsv = *av_fetch(pad, off, TRUE);
- SV *sv = NEWSV(1103,0);
- sv_upgrade(sv, SVt_PVNV);
- sv_setpv(sv, name);
- av_store(comppad_name, newoff, sv);
- SvNVX(sv) = (double)curcop->cop_seq;
- SvIVX(sv) = 999999999; /* A ref, intro immediately */
- av_store(comppad, newoff, SvREFCNT_inc(oldsv));
- return newoff;
+ return (PADOFFSET)off;
}
}
+
+ /* See if it's in a nested scope */
+ off = pad_findlex(name, 0, seq, CvOUTSIDE(compcv), cxstack_ix);
+ if (off)
+ return off;
+
return 0;
}
}
/* "Deintroduce" my variables that are leaving with this scope. */
for (off = AvFILL(comppad_name); off > fill; off--) {
- if ((sv = svp[off]) && sv != &sv_undef)
+ if ((sv = svp[off]) && sv != &sv_undef && SvIVX(sv) == 999999999)
SvIVX(sv) = cop_seqmax;
}
}
if (AvARRAY(comppad) != curpad)
croak("panic: pad_reset curpad");
DEBUG_X(fprintf(stderr, "Pad reset\n"));
- for (po = AvMAX(comppad); po > padix_floor; po--) {
- if (curpad[po] && curpad[po] != &sv_undef)
- SvPADTMP_off(curpad[po]);
+ if (!tainting) { /* Can't mix tainted and non-tainted temporaries. */
+ for (po = AvMAX(comppad); po > padix_floor; po--) {
+ if (curpad[po] && curpad[po] != &sv_undef)
+ SvPADTMP_off(curpad[po]);
+ }
+ padix = padix_floor;
}
- padix = padix_floor;
pad_reset_pending = FALSE;
}
}
}
-
switch (op->op_type) {
case OP_NULL:
op->op_targ = 0; /* Was holding old type, if any. */
case OP_CONST:
SvREFCNT_dec(cSVOP->op_sv);
break;
+ case OP_GOTO:
+ case OP_NEXT:
+ case OP_LAST:
+ case OP_REDO:
+ if (op->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
+ break;
+ /* FALL THROUGH */
case OP_TRANS:
Safefree(cPVOP->op_pv);
break;
case OP_SUBST:
op_free(cPMOP->op_pmreplroot);
/* FALL THROUGH */
+ case OP_PUSHRE:
case OP_MATCH:
regfree(cPMOP->op_pmregexp);
+ SvREFCNT_dec(cPMOP->op_pmshort);
break;
default:
break;
scalar(kid);
}
break;
- case OP_SCOPE:
case OP_LEAVE:
case OP_LEAVETRY:
+ scalar(cLISTOP->op_first);
+ /* FALL THROUGH */
+ case OP_SCOPE:
case OP_LINESEQ:
case OP_LIST:
for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) {
case OP_NEXTSTATE:
case OP_DBSTATE:
- curcop = ((COP*)op); /* for warning above */
+ curcop = ((COP*)op); /* for warning below */
break;
case OP_CONST:
scalarvoid(kid);
break;
case OP_NULL:
+ if (op->op_targ == OP_NEXTSTATE || op->op_targ == OP_DBSTATE)
+ curcop = ((COP*)op); /* for warning below */
if (op->op_flags & OPf_STACKED)
break;
case OP_ENTERTRY:
deprecate("implicit split to @_");
}
break;
+ case OP_DELETE:
+ op->op_private |= OPpLEAVE_VOID;
+ break;
}
if (useless && dowarn)
warn("Useless use of %s in void context", useless);
case OP_LIST:
listkids(op);
break;
- case OP_SCOPE:
case OP_LEAVE:
case OP_LEAVETRY:
+ list(cLISTOP->op_first);
+ /* FALL THROUGH */
+ case OP_SCOPE:
case OP_LINESEQ:
for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) {
if (kid->op_sibling)
switch (op->op_type) {
case OP_CONST:
- if (!(op->op_flags & (OPf_SPECIAL|OPf_MOD)))
+ if (!(op->op_private & (OPpCONST_ARYBASE)))
goto nomod;
if (eval_start && eval_start->op_type == OP_CONST) {
compiling.cop_arybase = (I32)SvIV(((SVOP*)eval_start)->op_sv);
}
else if (!type) {
SAVEI32(compiling.cop_arybase);
+ compiling.cop_arybase = 0;
}
else if (type == OP_REFGEN)
goto nomod;
case OP_RV2AV:
case OP_RV2HV:
+ if (type == OP_REFGEN && op->op_flags & OPf_PARENS) {
+ modcount = 10000;
+ return op; /* Treat \(@foo) like ordinary list. */
+ }
+ /* FALL THROUGH */
case OP_RV2GV:
ref(cUNOP->op_first, op->op_type);
/* FALL THROUGH */
- case OP_PADAV:
- case OP_PADHV:
case OP_AASSIGN:
case OP_ASLICE:
case OP_HSLICE:
case OP_RV2SV:
ref(cUNOP->op_first, op->op_type);
/* FALL THROUGH */
- case OP_PADSV:
case OP_UNDEF:
case OP_GV:
case OP_AV2ARYLEN:
modcount++;
break;
- case OP_PUSHMARK:
+ case OP_PADAV:
+ case OP_PADHV:
+ modcount = 10000;
+ /* FALL THROUGH */
+ case OP_PADSV:
+ modcount++;
+ if (!type)
+ croak("Can't localize lexical variable %s",
+ SvPV(*av_fetch(comppad_name, op->op_targ, 4), na));
break;
+ case OP_PUSHMARK:
+ break;
case OP_POS:
mtype = '.';
o->op_type = OP_SCOPE;
o->op_ppaddr = ppaddr[OP_SCOPE];
kid = ((LISTOP*)o)->op_first;
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE){
+ SvREFCNT_dec(((COP*)kid)->cop_filegv);
null(kid);
+ }
}
else
- o = newUNOP(OP_SCOPE, 0, o);
+ o = newLISTOP(OP_SCOPE, 0, o, Nullop);
}
}
return o;
main_start = LINKLIST(main_root);
main_root->op_next = 0;
peep(main_start);
+ main_cv = compcv;
+ compcv = 0;
}
}
{
register OP *curop;
I32 type = o->op_type;
+ SV *sv;
if (opargs[type] & OA_RETSCALAR)
scalar(o);
o->op_next = 0;
op = curop;
run();
- if (o->op_targ && *stack_sp == PAD_SV(o->op_targ)) /* grab pad temp? */
+ sv = *(stack_sp--);
+ if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
pad_swipe(o->op_targ);
- else if (SvTEMP(*stack_sp)) { /* grab mortal temp? */
- (void)SvREFCNT_inc(*stack_sp);
- SvTEMP_off(*stack_sp);
+ else if (SvTEMP(sv)) { /* grab mortal temp? */
+ (void)SvREFCNT_inc(sv);
+ SvTEMP_off(sv);
}
op_free(o);
if (type == OP_RV2GV)
- return newGVOP(OP_GV, 0, *(stack_sp--));
- else
- return newSVOP(OP_CONST, 0, *(stack_sp--));
+ return newGVOP(OP_GV, 0, sv);
+ else {
+ if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK) {
+ IV iv = SvIV(sv);
+ if ((double)iv == SvNV(sv)) { /* can we smush double to int */
+ SvREFCNT_dec(sv);
+ sv = newSViv(iv);
+ }
+ }
+ return newSVOP(OP_CONST, 0, sv);
+ }
nope:
if (!(opargs[type] & OA_OTHERINT))
if (!op || op->op_type != OP_LIST)
op = newLISTOP(OP_LIST, 0, op, Nullop);
+ else
+ op->op_flags &= ~(OPf_KNOW|OPf_LIST);
if (!(opargs[type] & OA_MARK))
null(cLISTOP->op_first);
register char *r = SvPV(rstr, rlen);
register I32 i;
register I32 j;
- I32 squash;
I32 delete;
I32 complement;
register short *tbl;
tbl = (short*)cPVOP->op_pv;
complement = op->op_private & OPpTRANS_COMPLEMENT;
delete = op->op_private & OPpTRANS_DELETE;
- squash = op->op_private & OPpTRANS_SQUASH;
+ /* squash = op->op_private & OPpTRANS_SQUASH; */
if (complement) {
Zero(tbl, 256, short);
p = SvPV(pat, plen);
pm->op_pmflags |= PMf_SKIPWHITE;
}
-#ifdef NOTDEF
- scan_prefix(pm, p, plen);
- if (pm->op_pmshort && (pm->op_pmflags & PMf_SCANFIRST))
- fbm_compile(pm->op_pmshort, pm->op_pmflags & PMf_FOLD);
-#endif
pm->op_pmregexp = regcomp(p, p + plen, pm);
if (strEQ("\\s+", pm->op_pmregexp->precomp))
pm->op_pmflags |= PMf_WHITE;
}
if (repl) {
- if (repl->op_type == OP_CONST) {
- pm->op_pmflags |= PMf_CONST;
- prepend_elem(op->op_type, scalar(repl), op);
- }
+ OP *curop;
+ if (pm->op_pmflags & PMf_EVAL)
+ curop = 0;
+ else if (repl->op_type == OP_CONST)
+ curop = repl;
else {
- OP *curop;
OP *lastop = 0;
for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
if (opargs[curop->op_type] & OA_DANGEROUS) {
if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
break;
}
+ else if (curop->op_type == OP_PADSV ||
+ curop->op_type == OP_PADAV ||
+ curop->op_type == OP_PADHV ||
+ curop->op_type == OP_PADANY) {
+ /* is okay */
+ }
else
break;
}
lastop = curop;
}
- if (curop == repl) {
- pm->op_pmflags |= PMf_CONST; /* const for long enough */
- prepend_elem(op->op_type, scalar(repl), op);
- }
- else {
- Newz(1101, rcop, 1, LOGOP);
- rcop->op_type = OP_SUBSTCONT;
- rcop->op_ppaddr = ppaddr[OP_SUBSTCONT];
- rcop->op_first = scalar(repl);
- rcop->op_flags |= OPf_KIDS;
- rcop->op_private = 1;
- rcop->op_other = op;
-
- /* establish postfix order */
- rcop->op_next = LINKLIST(repl);
- repl->op_next = (OP*)rcop;
-
- pm->op_pmreplroot = scalar((OP*)rcop);
- pm->op_pmreplstart = LINKLIST(rcop);
- rcop->op_next = 0;
- }
+ }
+ if (curop == repl) {
+ pm->op_pmflags |= PMf_CONST; /* const for long enough */
+ prepend_elem(op->op_type, scalar(repl), op);
+ }
+ else {
+ Newz(1101, rcop, 1, LOGOP);
+ rcop->op_type = OP_SUBSTCONT;
+ rcop->op_ppaddr = ppaddr[OP_SUBSTCONT];
+ rcop->op_first = scalar(repl);
+ rcop->op_flags |= OPf_KIDS;
+ rcop->op_private = 1;
+ rcop->op_other = op;
+
+ /* establish postfix order */
+ rcop->op_next = LINKLIST(repl);
+ repl->op_next = (OP*)rcop;
+
+ pm->op_pmreplroot = scalar((OP*)rcop);
+ pm->op_pmreplstart = LINKLIST(rcop);
+ rcop->op_next = 0;
}
}
if (list_assignment(left)) {
modcount = 0;
- eval_start = right; /* Grandfathering $[ assignment here. Bletch. */
+ eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
left = mod(left, OP_AASSIGN);
- if (!eval_start) {
+ if (eval_start)
+ eval_start = 0;
+ else {
op_free(left);
op_free(right);
return Nullop;
list(force_list(left)) );
op->op_private = 0;
if (!(left->op_private & OPpLVAL_INTRO)) {
- static int generation = 0;
+ static int generation = 100;
OP *curop;
OP *lastop = op;
generation++;
break;
SvCUR(gv) = generation;
}
+ else if (curop->op_type == OP_PADSV ||
+ curop->op_type == OP_PADAV ||
+ curop->op_type == OP_PADHV ||
+ curop->op_type == OP_PADANY) {
+ SV **svp = AvARRAY(comppad_name);
+ SV *sv = svp[curop->op_targ];;
+ if (SvCUR(sv) == generation)
+ break;
+ SvCUR(sv) = generation; /* (SvCUR not used any more) */
+ }
else if (curop->op_type == OP_RV2CV)
break;
else if (curop->op_type == OP_RV2SV ||
return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
}
else {
- eval_start = right; /* Grandfathering $[ assignment here. Bletch. */
+ eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
op = newBINOP(OP_SASSIGN, flags,
scalar(right), mod(scalar(left), OP_SASSIGN) );
- if (!eval_start) {
+ if (eval_start)
+ eval_start = 0;
+ else {
op_free(op);
return Nullop;
}
for (i = min_intro_pending; i <= max_intro_pending; i++) {
if ((sv = svp[i]) && sv != &sv_undef)
SvIVX(sv) = 999999999; /* Don't know scope end yet. */
+ SvNVX(sv) = (double)cop_seqmax;
}
min_intro_pending = 0;
comppad_name_fill = max_intro_pending; /* Needn't search higher */
if (once && op != listop)
op->op_next = ((LOGOP*)cUNOP->op_first)->op_other;
+ if (op == listop)
+ op = newUNOP(OP_NULL, 0, op); /* or do {} while 1 loses outer block */
+
op->op_flags |= flags;
op = scope(op);
- op->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration */
+ op->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
return op;
}
OP *op;
OP *condop;
- if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB))
- expr = newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr);
+ if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB)) {
+ expr = newUNOP(OP_DEFINED, 0,
+ newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) );
+ }
if (!block)
block = newOP(OP_NULL, 0);
copline = forline;
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
- OP *op = sv;
- sv = cUNOP->op_first;
- sv->op_next = sv;
- cUNOP->op_first = Nullop;
- op_free(op);
+ sv->op_type = OP_RV2GV;
+ sv->op_ppaddr = ppaddr[OP_RV2GV];
}
else if (sv->op_type == OP_PADSV) { /* private variable */
padoff = sv->op_targ;
SAVESPTR(curpad);
curpad = 0;
- op_free(CvROOT(cv));
+ if (!SvFLAGS(cv) & SVpcv_CLONED)
+ op_free(CvROOT(cv));
CvROOT(cv) = Nullop;
if (CvPADLIST(cv)) {
I32 i = AvFILL(CvPADLIST(cv));
SvREFCNT_dec(*svp);
}
SvREFCNT_dec((SV*)CvPADLIST(cv));
+ CvPADLIST(cv) = Nullav;
}
SvREFCNT_dec(CvGV(cv));
+ CvGV(cv) = Nullgv;
LEAVE;
}
}
CV *
+cv_clone(proto)
+CV* proto;
+{
+ AV* av;
+ I32 ix;
+ AV* protopadlist = CvPADLIST(proto);
+ AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
+ AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
+ SV** svp = AvARRAY(protopad);
+ AV* comppadlist;
+ CV* cv;
+
+ ENTER;
+ SAVESPTR(curpad);
+ SAVESPTR(comppad);
+ SAVESPTR(compcv);
+
+ cv = compcv = (CV*)NEWSV(1104,0);
+ sv_upgrade((SV *)cv, SVt_PVCV);
+ SvFLAGS(cv) |= SVpcv_CLONED;
+
+ CvFILEGV(cv) = CvFILEGV(proto);
+ CvGV(cv) = SvREFCNT_inc(CvGV(proto));
+ CvSTASH(cv) = CvSTASH(proto);
+ CvROOT(cv) = CvROOT(proto);
+ CvSTART(cv) = CvSTART(proto);
+ CvOUTSIDE(cv) = CvOUTSIDE(proto);
+
+ comppad = newAV();
+
+ comppadlist = newAV();
+ AvREAL_off(comppadlist);
+ av_store(comppadlist, 0, SvREFCNT_inc((SV*)protopad_name));
+ av_store(comppadlist, 1, SvREFCNT_inc((SV*)comppad));
+ CvPADLIST(cv) = comppadlist;
+ av_extend(comppad, AvFILL(protopad));
+ curpad = AvARRAY(comppad);
+
+ av = newAV(); /* will be @_ */
+ av_extend(av, 0);
+ av_store(comppad, 0, (SV*)av);
+ AvFLAGS(av) = AVf_REIFY;
+
+ svp = AvARRAY(protopad_name);
+ for ( ix = AvFILL(protopad); ix > 0; ix--) {
+ SV *sv;
+ if (svp[ix] != &sv_undef) {
+ char *name = SvPVX(svp[ix]); /* XXX */
+ if (SvFLAGS(svp[ix]) & SVf_FAKE) { /* lexical from outside? */
+ I32 off = pad_findlex(name,ix,curcop->cop_seq, CvOUTSIDE(proto), cxstack_ix);
+ if (off != ix)
+ croak("panic: cv_clone: %s", name);
+ }
+ else { /* our own lexical */
+ if (*name == '@')
+ av_store(comppad, ix, sv = (SV*)newAV());
+ else if (*name == '%')
+ av_store(comppad, ix, sv = (SV*)newHV());
+ else
+ av_store(comppad, ix, sv = NEWSV(0,0));
+ SvPADMY_on(sv);
+ }
+ }
+ else {
+ av_store(comppad, ix, sv = NEWSV(0,0));
+ SvPADTMP_on(sv);
+ }
+ }
+
+ LEAVE;
+ return cv;
+}
+
+CV *
newSUB(floor,op,block)
I32 floor;
OP *op;
if (cv = GvCV(gv)) {
if (GvCVGEN(gv))
cv = 0; /* just a cached method */
- else if (CvROOT(cv)) { /* already defined? */
- if (dowarn) {
+ else if (CvROOT(cv) || CvXSUB(cv) || GvFLAGS(gv) & GVf_IMPORTED) {
+ if (dowarn) { /* already defined (or promised)? */
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
}
}
if (cv) { /* must reuse cv if autoloaded */
- assert(SvREFCNT(CvGV(cv)) > 1);
- SvREFCNT_dec(CvGV(cv));
+ if (CvGV(cv)) {
+ assert(SvREFCNT(CvGV(cv)) > 1);
+ SvREFCNT_dec(CvGV(cv));
+ }
+ CvOUTSIDE(cv) = CvOUTSIDE(compcv);
+ CvPADLIST(cv) = CvPADLIST(compcv);
+ SvREFCNT_dec(compcv);
}
else {
- cv = (CV*)NEWSV(1104,0);
- sv_upgrade((SV *)cv, SVt_PVCV);
+ cv = compcv;
}
GvCV(gv) = cv;
GvCVGEN(gv) = 0;
SvPADTMP_on(curpad[ix]);
}
- av = newAV();
- AvREAL_off(av);
if (AvFILL(comppad_name) < AvFILL(comppad))
av_store(comppad_name, AvFILL(comppad), Nullsv);
- av_store(av, 0, SvREFCNT_inc((SV*)comppad_name));
- av_store(av, 1, SvREFCNT_inc((SV*)comppad));
- AvFILL(av) = 1;
- CvPADLIST(cv) = av;
CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
CvSTART(cv) = LINKLIST(CvROOT(cv));
op_free(op);
copline = NOLINE;
LEAVE_SCOPE(floor);
- if (!op)
+ if (!op) {
GvCV(gv) = 0; /* Will remember in SVOP instead. */
+ SvFLAGS(cv) |= SVpcv_ANON;
+ }
return cv;
}
if (cv = GvCV(gv)) {
if (GvCVGEN(gv))
cv = 0; /* just a cached method */
- else if (CvROOT(cv)) { /* already defined? */
+ else if (CvROOT(cv) || CvXSUB(cv)) { /* already defined? */
if (dowarn) {
line_t oldline = curcop->cop_line;
av_unshift(endav, 1);
av_store(endav, 0, SvREFCNT_inc(gv));
}
- if (!name)
+ if (!name) {
GvCV(gv) = 0; /* Will remember elsewhere instead. */
+ SvFLAGS(cv) |= SVpcv_ANON;
+ }
return cv;
}
}
SvREFCNT_dec(cv);
}
- cv = (CV*)NEWSV(1106,0);
- sv_upgrade((SV *)cv, SVt_PVFM);
+ cv = compcv;
GvFORM(gv) = cv;
CvGV(cv) = SvREFCNT_inc(gv);
CvFILEGV(cv) = curcop->cop_filegv;
{
if (type == OP_MAPSTART)
return newUNOP(OP_NULL, 0, o);
- return newUNOP(OP_RV2GV, 0, o);
+ return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
}
OP *
register OP *op;
{
SVOP *kid = (SVOP*)cUNOP->op_first;
- int iscv = (op->op_type==OP_RV2CV)*2;
op->op_private = (hints & HINT_STRICT_REFS);
if (kid->op_type == OP_CONST) {
+ int iscv = (op->op_type==OP_RV2CV)*2;
GV *gv = 0;
kid->op_type = OP_GV;
for (gv = 0; !gv; iscv++) {
+ /*
+ * This is a little tricky. We only want to add the symbol if we
+ * didn't add it in the lexer. Otherwise we get duplicate strict
+ * warnings. But if we didn't add it in the lexer, we must at
+ * least pretend like we wanted to add it even if it existed before,
+ * or we get possible typo warnings. OPpCONST_ENTERED says
+ * whether the lexer already added THIS instance of this symbol.
+ */
gv = gv_fetchpv(SvPVx(kid->op_sv, na),
- iscv,
+ iscv | !(kid->op_private & OPpCONST_ENTERED),
iscv
? SVt_PVCV
: op->op_type == OP_RV2SV
else if (kid && !kid->op_sibling) { /* print HANDLE; */
if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
op->op_flags |= OPf_STACKED; /* make it a filehandle */
- kid = newUNOP(OP_RV2GV, 0, scalar(kid));
+ kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
cLISTOP->op_first->op_sibling = kid;
cLISTOP->op_last = kid;
kid = kid->op_sibling;
kid->op_next = 0;
}
else if (kid->op_type == OP_LEAVE) {
- null(kid); /* wipe out leave */
- kid->op_next = kid;
+ if (op->op_type == OP_SORT) {
+ null(kid); /* wipe out leave */
+ kid->op_next = kid;
- for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
- if (k->op_next == kid)
- k->op_next = 0;
+ for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
+ if (k->op_next == kid)
+ k->op_next = 0;
+ }
}
+ else
+ kid->op_next = 0; /* just disconnect the leave */
k = kLISTOP->op_first;
}
peep(k);
case OP_NEXTSTATE:
case OP_DBSTATE:
curcop = ((COP*)o); /* for warnings */
+ o->op_seq = ++op_seqmax;
break;
case OP_CONCAT:
o->op_seq = ++op_seqmax;
break; /* Scalar stub must produce undef. List stub is noop */
}
- /* FALL THROUGH */
+ goto nothin;
case OP_NULL:
+ if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
+ curcop = ((COP*)op);
+ goto nothin;
case OP_SCALAR:
case OP_LINESEQ:
case OP_SCOPE:
+ nothin:
if (oldop && o->op_next) {
oldop->op_next = o->op_next;
continue;
<= 255 &&
i >= 0)
{
+ SvREFCNT_dec(((SVOP*)pop)->op_sv);
null(o->op_next);
null(pop->op_next);
null(pop);
#define OPpDEREF_HV 64 /* Want ref to HV. */
/* Private for OP_CONST */
+#define OPpCONST_ENTERED 16 /* Has been entered as symbol. */
+#define OPpCONST_ARYBASE 32 /* Was a $[ translated to constant. */
#define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */
/* Private for OP_FLIP/FLOP */
+#define pp_i_preinc pp_preinc
+#define pp_i_predec pp_predec
+#define pp_i_postinc pp_postinc
+#define pp_i_postdec pp_postdec
+
typedef enum {
OP_NULL, /* 0 */
OP_STUB, /* 1 */
ck_null, /* iter */
ck_null, /* enterloop */
ck_null, /* leaveloop */
- ck_fun, /* return */
+ ck_null, /* return */
ck_null, /* last */
ck_null, /* next */
ck_null, /* redo */
0x00000004, /* const */
0x00000044, /* gvsv */
0x00000044, /* gv */
- 0x00000004, /* padsv */
- 0x00000000, /* padav */
- 0x00000000, /* padhv */
- 0x00000000, /* padany */
+ 0x00000044, /* padsv */
+ 0x00000040, /* padav */
+ 0x00000040, /* padhv */
+ 0x00000040, /* padany */
0x00000000, /* pushre */
0x00000044, /* rv2gv */
0x0000001c, /* sv2len */
# Emit defines.
$i = 0;
-print "typedef enum {\n";
+print <<"END";
+#define pp_i_preinc pp_preinc
+#define pp_i_predec pp_predec
+#define pp_i_postinc pp_postinc
+#define pp_i_postdec pp_postdec
+
+typedef enum {
+END
for (@ops) {
print "\t", &tab(3,"OP_\U$_,"), "/* ", $i++, " */\n";
}
gvsv scalar variable ck_null ds
gv glob value ck_null ds
-padsv private variable ck_null s
-padav private array ck_null 0
-padhv private hash ck_null 0
-padany private something ck_null 0
+padsv private variable ck_null ds
+padav private array ck_null d
+padhv private hash ck_null d
+padany private something ck_null d
pushre push regexp ck_null 0
iter foreach loop iterator ck_null 0
enterloop loop entry ck_null d
leaveloop loop exit ck_null 0
-return return ck_fun dm L
+return return ck_null dm L
last last ck_null ds
next next ck_null ds
redo redo ck_null ds
-#define PATCHLEVEL 0
+#define PATCHLEVEL 1
static void find_beginning _((void));
static void incpush _((char *));
+static void init_ids _((void));
static void init_debugger _((void));
static void init_lexer _((void));
static void init_main_stash _((void));
perl_construct( sv_interp )
register PerlInterpreter *sv_interp;
{
- char* s;
-
if (!(curinterp = sv_interp))
return;
tmps_floor = -1;
#endif
- uid = (int)getuid();
- euid = (int)geteuid();
- gid = (int)getgid();
- egid = (int)getegid();
-#ifdef VMS
- uid |= gid << 16;
- euid |= egid << 16;
-#endif
- tainting = (euid != uid || egid != gid);
+ init_ids();
sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0));
fdpid = newAV(); /* for remembering popen pids by fd */
}
void
-perl_destruct(sv_interp, destruct_level)
+perl_destruct(sv_interp)
register PerlInterpreter *sv_interp;
-int destruct_level; /* 0=none, 1=full, 2=full with checks */
{
+ int destruct_level; /* 0=none, 1=full, 2=full with checks */
I32 last_sv_count;
HV *hv;
if (!(curinterp = sv_interp))
return;
+
+ destruct_level = perl_destruct_level;
LEAVE;
FREETMPS;
char *scriptname;
VOL bool dosearch = FALSE;
char *validarg = "";
+ AV* comppadlist;
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
origfilename = savepv(argv[0]);
do_undump = FALSE;
cxstack_ix = -1; /* start label stack again */
+ init_ids();
init_postdump_symbols(argc,argv,env);
return 0;
}
switch (setjmp(top_env)) {
case 1:
+#ifdef VMS
statusvalue = 255;
+#else
+ statusvalue = 1;
+#endif
case 2:
curstash = defstash;
if (endav)
if (doextract)
find_beginning();
+ compcv = (CV*)NEWSV(1104,0);
+ sv_upgrade((SV *)compcv, SVt_PVCV);
+
pad = newAV();
comppad = pad;
av_push(comppad, Nullsv);
min_intro_pending = 0;
padix = 0;
+ comppadlist = newAV();
+ AvREAL_off(comppadlist);
+ av_store(comppadlist, 0, SvREFCNT_inc((SV*)comppad_name));
+ av_store(comppadlist, 1, SvREFCNT_inc((SV*)comppad));
+ CvPADLIST(compcv) = comppadlist;
+
if (xsinit)
(*xsinit)(); /* in case linked C routines want magical variables */
+#ifdef VMS
+ init_os_extras();
+#endif
init_predump_symbols();
if (!do_undump)
void
my_exit(status)
-I32 status;
+U32 status;
{
register CONTEXT *cx;
I32 gimme;
SV **newsp;
- statusvalue = (unsigned short)(status & 0xffff);
+ statusvalue = FIXSTATUS(status);
if (cxstack_ix >= 0) {
if (cxstack_ix > 0)
dounwind(0);
case 0:
break;
case 1:
+#ifdef VMS
statusvalue = 255; /* XXX I don't think we use 1 anymore. */
+#else
+ statusvalue = 1;
+#endif
/* FALL THROUGH */
case 2:
/* my_exit() was called */
sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
}
-#ifdef DOSISH
-#define PERLLIB_SEP ';'
+#if defined(DOSISH)
+# define PERLLIB_SEP ';'
+#elif defined(VMS)
+# define PERLLIB_SEP '|'
#else
-#define PERLLIB_SEP ':'
+# define PERLLIB_SEP ':'
#endif
static void
case 'I':
taint_not("-I");
if (*++s) {
- av_push(GvAVn(incgv),newSVpv(s,0));
+ char *e;
+ for (e = s; *e && !isSPACE(*e); e++) ;
+ av_push(GvAVn(incgv),newSVpv(s,e-s));
+ if (*e)
+ return e;
}
else
croak("No space allowed after -I");
if (geteuid() != uid)
croak("Can't do seteuid!\n");
}
- uid = (int)getuid();
- euid = (int)geteuid();
- gid = (int)getgid();
- egid = (int)getegid();
- tainting |= (euid != uid || egid != gid);
+ init_ids();
if (!cando(S_IXUSR,TRUE,&statbuf))
croak("Permission denied\n"); /* they can't do this */
}
}
static void
-init_debugger()
+init_ids()
{
- GV* tmpgv;
+ uid = (int)getuid();
+ euid = (int)geteuid();
+ gid = (int)getgid();
+ egid = (int)getegid();
+#ifdef VMS
+ uid |= gid << 16;
+ euid |= egid << 16;
+#endif
+ tainting |= (euid != uid || egid != gid);
+}
+static void
+init_debugger()
+{
curstash = debstash;
- dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
+ dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
AvREAL_off(dbargs);
DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
- DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
- DBsingle = GvSV((tmpgv = gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
- DBtrace = GvSV((tmpgv = gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
- DBsignal = GvSV((tmpgv = gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
+ DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
+ DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
+ DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
+ DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
curstash = defstash;
}
toptarget = NEWSV(0,0);
sv_upgrade(toptarget, SVt_PVFM);
sv_setpvn(toptarget, "", 0);
- tmpgv = gv_fetchpv("\001",TRUE, SVt_PV);
- bodytarget = GvSV(tmpgv);
+ bodytarget = NEWSV(0,0);
sv_upgrade(bodytarget, SVt_PVFM);
sv_setpvn(bodytarget, "", 0);
formtarget = bodytarget;
AV* list;
{
jmp_buf oldtop;
- char *mess;
STRLEN len;
line_t oldline = curcop->cop_line;
SAVEFREESV(cv);
switch (setjmp(top_env)) {
- case 0:
- PUSHMARK(stack_sp);
- perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
- mess = SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), len);
- if (len) {
- Copy(oldtop, top_env, 1, jmp_buf);
- curcop = &compiling;
- curcop->cop_line = oldline;
- if (list == beginav)
- croak("%sBEGIN failed--compilation aborted", mess);
- else
- croak("%sEND failed--cleanup aborted", mess);
+ case 0: {
+ SV* atsv = GvSV(gv_fetchpv("@",TRUE, SVt_PV));
+ 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);
+ curcop = &compiling;
+ curcop->cop_line = oldline;
+ if (list == beginav)
+ sv_catpv(atsv, "BEGIN failed--compilation aborted");
+ else
+ sv_catpv(atsv, "END failed--cleanup aborted");
+ croak("%s", SvPVX(atsv));
+ }
}
break;
case 1:
+#ifdef VMS
statusvalue = 255; /* XXX I don't think we use 1 anymore. */
+#else
+ statusvalue = 1;
+#endif
/* FALL THROUGH */
case 2:
/* my_exit() was called */
# include <net/errno.h>
# endif
#endif
+#ifndef VMS
+# define FIXSTATUS(sts) (U_L((sts) & 0xffff))
+# define SHIFTSTATUS(sts) ((sts) >> 8)
+# define SETERRNO(errcode,vmserrcode) errno = (errcode)
+#else
+# define FIXSTATUS(sts) (U_L(sts))
+# define SHIFTSTATUS(sts) (sts)
+# define SETERRNO(errcode,vmserrcode) {set_errno(errcode); set_vaxc_errno(vmserrcode);}
+#endif
#ifndef MSDOS
# ifndef errno
# define HAS_QUAD
#endif
+#ifdef UV
+#undef UV
+#endif
+
#ifdef HAS_QUAD
# ifdef cray
# define Quad_t int
# define Quad_t long
# endif
# endif
-#endif
-
-#ifdef DOSISH
-# include "dosish.h"
+ typedef Quad_t IV;
+ typedef unsigned Quad_t UV;
#else
-# if defined(VMS)
-# include "vmsish.h"
-# else
-# include "unixish.h"
-# endif
-#endif
-
-#ifndef HAS_PAUSE
-#define pause() sleep((32767<<16)+32767)
-#endif
-
-#ifndef IOCPARM_LEN
-# ifdef IOCPARM_MASK
- /* on BSDish systes we're safe */
-# define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK)
-# else
- /* otherwise guess at what's safe */
-# define IOCPARM_LEN(x) 256
-# endif
+ typedef long IV;
+ typedef unsigned long UV;
#endif
typedef MEM_SIZE STRLEN;
typedef struct mgvtbl MGVTBL;
typedef union any ANY;
-typedef FILE * (*cryptswitch_t) _((FILE *rfp));
+typedef int (*cryptswitch_t) _((void));
#include "handy.h"
-#ifdef HAS_QUAD
-typedef Quad_t IV;
+#ifdef DOSISH
+# include "dosish.h"
#else
-typedef long IV;
+# if defined(VMS)
+# include "vmsish.h"
+# else
+# include "unixish.h"
+# endif
+#endif
+
+#ifndef HAS_PAUSE
+#define pause() sleep((32767<<16)+32767)
+#endif
+
+#ifndef IOCPARM_LEN
+# ifdef IOCPARM_MASK
+ /* on BSDish systes we're safe */
+# define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK)
+# else
+ /* otherwise guess at what's safe */
+# define IOCPARM_LEN(x) 256
+# endif
#endif
union any {
#define TMPPATH "plXXXXXX"
#else
#ifdef VMS
-#define TMPPATH "/sys$scratch/perl-eXXXXXX"
+#define TMPPATH "sys$scratch:perl-eXXXXXX"
#else
#define TMPPATH "/tmp/perl-eXXXXXX"
#endif
EXT char no_wrongref[]
INIT("Can't use %s ref as %s ref");
EXT char no_symref[]
- INIT("Can't use a string as %s ref while \"strict refs\" in use");
+ INIT("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use");
EXT char no_usym[]
INIT("Can't use an undefined value as %s reference");
EXT char no_aelem[]
INIT("Unsupported directory function \"%s\" called");
EXT char no_func[]
INIT("The %s function is unimplemented");
+EXT char no_myglob[]
+ INIT("\"my\" variable %s can't be in a package");
EXT SV sv_undef;
EXT SV sv_no;
EXT char * bufend;
EXT expectation expect INIT(XSTATE); /* how to interpret ambiguous tokens */
EXT char * autoboot_preamble INIT(Nullch);
+EXT cryptswitch_t cryptswitch_fp;
EXT I32 multi_start; /* 1st line of multi-line string */
EXT I32 multi_end; /* last line of multi-line string */
EXT I32 subline; /* line this subroutine began on */
EXT SV * subname; /* name of current subroutine */
+EXT CV * compcv; /* currently compiling subroutine */
EXT AV * comppad; /* storage for lexically scoped temporaries */
EXT AV * comppad_name; /* variable names for "my" variables */
EXT I32 comppad_name_fill;/* last "introduced" variable offset */
EXT I32 max_intro_pending;/* end of vars to introduce */
EXT I32 padix; /* max used index in current "register" pad */
EXT I32 padix_floor; /* how low may inner block reset padix */
-EXT bool pad_reset_pending; /* reset pad on next attempted alloc */
+EXT I32 pad_reset_pending; /* reset pad on next attempted alloc */
EXT COP compiling;
EXT I32 thisexpr; /* name id for nothing_in_common() */
IEXT GV * Isiggv;
IEXT GV * Iincgv;
IEXT char * Iorigfilename;
+IEXT SV * Idiehook;
+IEXT SV * Iwarnhook;
+IEXT SV * Iparsehook;
/* switches */
IEXT char * Icddir;
IEXT FILE * Ie_fp;
IEXT VOL U32 Idebug;
IEXT U32 Iperldb;
+ /* This value may be raised by extensions for testing purposes */
+IEXT int Iperl_destruct_level; /* 0=none, 1=full, 2=full with checks */
/* magical thingies */
IEXT Time_t Ibasetime; /* $^T */
IEXT char * Iofmt; /* $# */
IEXT I32 Imaxsysfd IINIT(MAXSYSFD); /* top fd to pass to subprocesses */
IEXT int Imultiline; /* $*--do strings hold >1 line? */
-IEXT U16 Istatusvalue; /* $? */
+IEXT U32 Istatusvalue; /* $? */
IEXT struct stat Istatcache; /* _ */
IEXT GV * Istatgv;
IEXT OP * Irestartop; /* Are we propagating an error from croak? */
IEXT int Idelaymagic; /* ($<,$>) = ... */
IEXT bool Idirty; /* In the middle of tearing things down? */
-IEXT bool Ilocalizing; /* are we processing a local() list? */
+IEXT U8 Ilocalizing; /* are we processing a local() list? */
IEXT bool Itainted; /* using variables controlled by $< */
IEXT bool Itainting; /* doing taint checks */
IEXT char * Idebdelim;
/* current interpreter roots */
+IEXT CV * Imain_cv;
IEXT OP * Imain_root;
IEXT OP * Imain_start;
IEXT OP * Ieval_root;
#ifdef OVERLOAD
MGVTBL vtbl_amagic = {0, magic_setamagic,
- 0, 0, 0};
+ 0, 0, magic_setamagic};
MGVTBL vtbl_amagicelem = {0, magic_setamagic,
- 0, 0, 0};
+ 0, 0, magic_setamagic};
#endif /* OVERLOAD */
#else
#ifdef OVERLOAD
EXT long amagic_generation;
-#define NofAMmeth 27
+#define NofAMmeth 29
#ifdef DOINIT
EXT char * AMG_names[NofAMmeth][2] = {
{"fallback","abs"},
{"**", "**="},
{"<<", "<<="},
{">>", ">>="},
+ {"&", "&="},
+ {"|", "|="},
+ {"^", "^="},
{"<", "<="},
{">", ">="},
{"==", "!="},
{"lt", "le"},
{"gt", "ge"},
{"eq", "ne"},
- {"&", "^"},
- {"|", "neg"},
{"!", "~"},
{"++", "--"},
{"atan2", "cos"},
{"sin", "exp"},
{"log", "sqrt"},
{"x","x="},
- {".",".="}
+ {".",".="},
+ {"=","neg"}
};
#else
EXT char * AMG_names[NofAMmeth][2];
pow_amg, pow_ass_amg,
lshift_amg, lshift_ass_amg,
rshift_amg, rshift_ass_amg,
+ band_amg, band_ass_amg,
+ bor_amg, bor_ass_amg,
+ bxor_amg, bxor_ass_amg,
lt_amg, le_amg,
gt_amg, ge_amg,
eq_amg, ne_amg,
slt_amg, sle_amg,
sgt_amg, sge_amg,
seq_amg, sne_amg,
- band_amg, bxor_amg,
- bor_amg, neg_amg,
not_amg, compl_amg,
inc_amg, dec_amg,
atan2_amg, cos_amg,
sin_amg, exp_amg,
log_amg, sqrt_amg,
repeat_amg, repeat_ass_amg,
- concat_amg, concat_ass_amg
+ concat_amg, concat_ass_amg,
+ copy_amg, neg_amg
};
#endif /* OVERLOAD */
static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91";
#endif
#define YYBYACC 1
-#line 17 "perly.y"
+#line 16 "perly.y"
#include "EXTERN.h"
#include "perl.h"
int yychar;
YYSTYPE yyval;
YYSTYPE yylval;
-#line 546 "perly.y"
+#line 545 "perly.y"
/* PROGRAM */
#line 1347 "y.tab.c"
#define YYABORT goto yyabort
switch (yyn)
{
case 1:
-#line 84 "perly.y"
+#line 83 "perly.y"
{
#if defined(YYDEBUG) && defined(DEBUGGING)
yydebug = (debug & 1);
}
break;
case 2:
-#line 91 "perly.y"
+#line 90 "perly.y"
{ newPROG(yyvsp[0].opval); }
break;
case 3:
-#line 95 "perly.y"
+#line 94 "perly.y"
{ yyval.opval = block_end(yyvsp[-3].ival,yyvsp[-2].ival,yyvsp[-1].opval); }
break;
case 4:
-#line 99 "perly.y"
+#line 98 "perly.y"
{ yyval.ival = block_start(); }
break;
case 5:
-#line 103 "perly.y"
+#line 102 "perly.y"
{ yyval.opval = Nullop; }
break;
case 6:
-#line 105 "perly.y"
+#line 104 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 7:
-#line 107 "perly.y"
+#line 106 "perly.y"
{ yyval.opval = append_list(OP_LINESEQ,
(LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval);
pad_reset_pending = TRUE;
if (yyvsp[-1].opval && yyvsp[0].opval) hints |= HINT_BLOCK_SCOPE; }
break;
case 8:
-#line 114 "perly.y"
+#line 113 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); }
break;
case 10:
-#line 117 "perly.y"
+#line 116 "perly.y"
{ if (yyvsp[-1].pval != Nullch) {
yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0));
}
expect = XSTATE; }
break;
case 11:
-#line 126 "perly.y"
+#line 125 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval);
expect = XSTATE; }
break;
case 12:
-#line 131 "perly.y"
+#line 130 "perly.y"
{ yyval.opval = Nullop; }
break;
case 13:
-#line 133 "perly.y"
+#line 132 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 14:
-#line 135 "perly.y"
+#line 134 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 15:
-#line 137 "perly.y"
+#line 136 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 16:
-#line 139 "perly.y"
+#line 138 "perly.y"
{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); }
break;
case 17:
-#line 141 "perly.y"
+#line 140 "perly.y"
{ yyval.opval = newLOOPOP(OPf_PARENS, 1, invert(scalar(yyvsp[0].opval)), yyvsp[-2].opval);}
break;
case 18:
-#line 145 "perly.y"
+#line 144 "perly.y"
{ yyval.opval = Nullop; }
break;
case 19:
-#line 147 "perly.y"
+#line 146 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 20:
-#line 149 "perly.y"
+#line 148 "perly.y"
{ copline = yyvsp[-5].ival;
yyval.opval = newSTATEOP(0, 0,
newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); }
break;
case 21:
-#line 155 "perly.y"
+#line 154 "perly.y"
{ copline = yyvsp[-5].ival;
yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval); }
break;
case 22:
-#line 158 "perly.y"
+#line 157 "perly.y"
{ copline = yyvsp[-5].ival;
yyval.opval = newCONDOP(0,
invert(scalar(yyvsp[-3].opval)), scope(yyvsp[-1].opval), yyvsp[0].opval); }
break;
case 23:
-#line 162 "perly.y"
+#line 161 "perly.y"
{ copline = yyvsp[-3].ival;
deprecate("if BLOCK BLOCK");
yyval.opval = newCONDOP(0, scope(yyvsp[-2].opval), scope(yyvsp[-1].opval), yyvsp[0].opval); }
break;
case 24:
-#line 166 "perly.y"
+#line 165 "perly.y"
{ copline = yyvsp[-3].ival;
deprecate("unless BLOCK BLOCK");
yyval.opval = newCONDOP(0, invert(scalar(scope(yyvsp[-2].opval))),
scope(yyvsp[-1].opval), yyvsp[0].opval); }
break;
case 25:
-#line 173 "perly.y"
+#line 172 "perly.y"
{ yyval.opval = Nullop; }
break;
case 26:
-#line 175 "perly.y"
+#line 174 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 27:
-#line 179 "perly.y"
+#line 178 "perly.y"
{ copline = yyvsp[-5].ival;
yyval.opval = newSTATEOP(0, yyvsp[-6].pval,
newWHILEOP(0, 1, (LOOP*)Nullop,
yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval) ); }
break;
case 28:
-#line 184 "perly.y"
+#line 183 "perly.y"
{ copline = yyvsp[-5].ival;
yyval.opval = newSTATEOP(0, yyvsp[-6].pval,
newWHILEOP(0, 1, (LOOP*)Nullop,
invert(scalar(yyvsp[-3].opval)), yyvsp[-1].opval, yyvsp[0].opval) ); }
break;
case 29:
-#line 189 "perly.y"
+#line 188 "perly.y"
{ copline = yyvsp[-3].ival;
yyval.opval = newSTATEOP(0, yyvsp[-4].pval,
newWHILEOP(0, 1, (LOOP*)Nullop,
scope(yyvsp[-2].opval), yyvsp[-1].opval, yyvsp[0].opval) ); }
break;
case 30:
-#line 194 "perly.y"
+#line 193 "perly.y"
{ copline = yyvsp[-3].ival;
yyval.opval = newSTATEOP(0, yyvsp[-4].pval,
newWHILEOP(0, 1, (LOOP*)Nullop,
invert(scalar(scope(yyvsp[-2].opval))), yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 31:
-#line 199 "perly.y"
+#line 198 "perly.y"
{ yyval.opval = newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, mod(yyvsp[-5].opval, OP_ENTERLOOP),
yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 32:
-#line 202 "perly.y"
+#line 201 "perly.y"
{ yyval.opval = newFOROP(0, yyvsp[-6].pval, yyvsp[-5].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 33:
-#line 205 "perly.y"
+#line 204 "perly.y"
{ copline = yyvsp[-8].ival;
yyval.opval = append_elem(OP_LINESEQ,
newSTATEOP(0, yyvsp[-9].pval, scalar(yyvsp[-6].opval)),
scalar(yyvsp[-4].opval), yyvsp[0].opval, scalar(yyvsp[-2].opval)) )); }
break;
case 34:
-#line 212 "perly.y"
+#line 211 "perly.y"
{ yyval.opval = newSTATEOP(0,
yyvsp[-2].pval, newWHILEOP(0, 1, (LOOP*)Nullop,
Nullop, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 35:
-#line 218 "perly.y"
+#line 217 "perly.y"
{ yyval.opval = Nullop; }
break;
case 37:
-#line 223 "perly.y"
+#line 222 "perly.y"
{ (void)scan_num("1"); yyval.opval = yylval.opval; }
break;
case 39:
-#line 228 "perly.y"
+#line 227 "perly.y"
{ yyval.pval = Nullch; }
break;
case 41:
-#line 233 "perly.y"
+#line 232 "perly.y"
{ yyval.ival = 0; }
break;
case 42:
-#line 235 "perly.y"
+#line 234 "perly.y"
{ yyval.ival = 0; }
break;
case 43:
-#line 237 "perly.y"
+#line 236 "perly.y"
{ yyval.ival = 0; }
break;
case 44:
-#line 239 "perly.y"
+#line 238 "perly.y"
{ yyval.ival = 0; }
break;
case 45:
-#line 243 "perly.y"
+#line 242 "perly.y"
{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 46:
-#line 245 "perly.y"
+#line 244 "perly.y"
{ newFORM(yyvsp[-1].ival, Nullop, yyvsp[0].opval); }
break;
case 47:
-#line 249 "perly.y"
+#line 248 "perly.y"
{ newSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 48:
-#line 251 "perly.y"
+#line 250 "perly.y"
{ newSUB(yyvsp[-2].ival, yyvsp[-1].opval, Nullop); expect = XSTATE; }
break;
case 49:
-#line 255 "perly.y"
+#line 254 "perly.y"
{ yyval.ival = start_subparse(); }
break;
case 50:
-#line 259 "perly.y"
+#line 258 "perly.y"
{ package(yyvsp[-1].opval); }
break;
case 51:
-#line 261 "perly.y"
+#line 260 "perly.y"
{ package(Nullop); }
break;
case 52:
-#line 265 "perly.y"
+#line 264 "perly.y"
{ utilize(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval); }
break;
case 53:
-#line 269 "perly.y"
+#line 268 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 54:
-#line 271 "perly.y"
+#line 270 "perly.y"
{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 55:
-#line 273 "perly.y"
+#line 272 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
case 57:
-#line 278 "perly.y"
+#line 277 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 58:
-#line 280 "perly.y"
+#line 279 "perly.y"
{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 60:
-#line 285 "perly.y"
+#line 284 "perly.y"
{ yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); }
break;
case 61:
-#line 288 "perly.y"
+#line 287 "perly.y"
{ yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); }
break;
case 62:
-#line 291 "perly.y"
+#line 290 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-5].opval, list(yyvsp[-1].opval)),
newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); }
break;
case 63:
-#line 296 "perly.y"
+#line 295 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-1].opval, list(yyvsp[0].opval)),
newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); }
break;
case 64:
-#line 301 "perly.y"
+#line 300 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-3].opval, list(yyvsp[-1].opval)),
newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); }
break;
case 65:
-#line 306 "perly.y"
+#line 305 "perly.y"
{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 66:
-#line 308 "perly.y"
+#line 307 "perly.y"
{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
case 69:
-#line 316 "perly.y"
+#line 315 "perly.y"
{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); }
break;
case 70:
-#line 318 "perly.y"
+#line 317 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 71:
-#line 320 "perly.y"
+#line 319 "perly.y"
{ if (yyvsp[-1].ival != OP_REPEAT)
scalar(yyvsp[-2].opval);
yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); }
break;
case 72:
-#line 324 "perly.y"
+#line 323 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 73:
-#line 326 "perly.y"
+#line 325 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 74:
-#line 328 "perly.y"
+#line 327 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 75:
-#line 330 "perly.y"
+#line 329 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 76:
-#line 332 "perly.y"
+#line 331 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 77:
-#line 334 "perly.y"
+#line 333 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 78:
-#line 336 "perly.y"
+#line 335 "perly.y"
{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));}
break;
case 79:
-#line 338 "perly.y"
+#line 337 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 80:
-#line 340 "perly.y"
+#line 339 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 81:
-#line 342 "perly.y"
+#line 341 "perly.y"
{ yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 82:
-#line 344 "perly.y"
+#line 343 "perly.y"
{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 83:
-#line 347 "perly.y"
+#line 346 "perly.y"
{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); }
break;
case 84:
-#line 349 "perly.y"
+#line 348 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 85:
-#line 351 "perly.y"
+#line 350 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
case 86:
-#line 353 "perly.y"
+#line 352 "perly.y"
{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));}
break;
case 87:
-#line 355 "perly.y"
+#line 354 "perly.y"
{ yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); }
break;
case 88:
-#line 357 "perly.y"
+#line 356 "perly.y"
{ yyval.opval = newUNOP(OP_POSTINC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTINC)); }
break;
case 89:
-#line 360 "perly.y"
+#line 359 "perly.y"
{ yyval.opval = newUNOP(OP_POSTDEC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); }
break;
case 90:
-#line 363 "perly.y"
+#line 362 "perly.y"
{ yyval.opval = newUNOP(OP_PREINC, 0,
mod(scalar(yyvsp[0].opval), OP_PREINC)); }
break;
case 91:
-#line 366 "perly.y"
+#line 365 "perly.y"
{ yyval.opval = newUNOP(OP_PREDEC, 0,
mod(scalar(yyvsp[0].opval), OP_PREDEC)); }
break;
case 92:
-#line 369 "perly.y"
+#line 368 "perly.y"
{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
break;
case 93:
-#line 371 "perly.y"
+#line 370 "perly.y"
{ yyval.opval = sawparens(yyvsp[-1].opval); }
break;
case 94:
-#line 373 "perly.y"
+#line 372 "perly.y"
{ yyval.opval = sawparens(newNULLLIST()); }
break;
case 95:
-#line 375 "perly.y"
+#line 374 "perly.y"
{ yyval.opval = newANONLIST(yyvsp[-1].opval); }
break;
case 96:
-#line 377 "perly.y"
+#line 376 "perly.y"
{ yyval.opval = newANONLIST(Nullop); }
break;
case 97:
-#line 379 "perly.y"
+#line 378 "perly.y"
{ yyval.opval = newANONHASH(yyvsp[-2].opval); }
break;
case 98:
-#line 381 "perly.y"
+#line 380 "perly.y"
{ yyval.opval = newANONHASH(Nullop); }
break;
case 99:
-#line 383 "perly.y"
+#line 382 "perly.y"
{ yyval.opval = newANONSUB(yyvsp[-1].ival, yyvsp[0].opval); }
break;
case 100:
-#line 385 "perly.y"
+#line 384 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 101:
-#line 387 "perly.y"
+#line 386 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 102:
-#line 389 "perly.y"
+#line 388 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); }
break;
case 103:
-#line 391 "perly.y"
+#line 390 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-4].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 104:
-#line 395 "perly.y"
+#line 394 "perly.y"
{ assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-3].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 105:
-#line 399 "perly.y"
+#line 398 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 106:
-#line 401 "perly.y"
+#line 400 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 107:
-#line 403 "perly.y"
+#line 402 "perly.y"
{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));}
break;
case 108:
-#line 405 "perly.y"
+#line 404 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
case 109:
-#line 408 "perly.y"
+#line 407 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-5].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
case 110:
-#line 413 "perly.y"
+#line 412 "perly.y"
{ assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-4].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
case 111:
-#line 418 "perly.y"
+#line 417 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); }
break;
case 112:
-#line 420 "perly.y"
+#line 419 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); }
break;
case 113:
-#line 422 "perly.y"
+#line 421 "perly.y"
{ yyval.opval = prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_ASLICE, 0,
ref(yyvsp[-3].opval, OP_ASLICE))); }
break;
case 114:
-#line 428 "perly.y"
+#line 427 "perly.y"
{ yyval.opval = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
expect = XOPERATOR; }
break;
case 115:
-#line 435 "perly.y"
+#line 434 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 116:
-#line 437 "perly.y"
+#line 436 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, 0,
scalar(yyvsp[0].opval)); }
break;
case 117:
-#line 440 "perly.y"
+#line 439 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); }
break;
case 118:
-#line 442 "perly.y"
+#line 441 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
list(append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval)))); }
break;
case 119:
-#line 445 "perly.y"
+#line 444 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
list(append_elem(OP_LIST,
yyvsp[0].opval, newCVREF(scalar(yyvsp[-1].opval))))); }
break;
case 120:
-#line 449 "perly.y"
+#line 448 "perly.y"
{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); }
break;
case 121:
-#line 451 "perly.y"
+#line 450 "perly.y"
{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); }
break;
case 122:
-#line 453 "perly.y"
+#line 452 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
list(prepend_elem(OP_LIST,
scalar(newCVREF(scalar(yyvsp[-2].opval))), Nullop))); dep();}
break;
case 123:
-#line 457 "perly.y"
+#line 456 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
list(append_elem(OP_LIST,
yyvsp[-1].opval,
scalar(newCVREF(scalar(yyvsp[-3].opval)))))); dep();}
break;
case 124:
-#line 462 "perly.y"
+#line 461 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
list(prepend_elem(OP_LIST,
scalar(newCVREF(scalar(yyvsp[-2].opval))), Nullop))); dep();}
break;
case 125:
-#line 466 "perly.y"
+#line 465 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
list(prepend_elem(OP_LIST,
yyvsp[-1].opval,
scalar(newCVREF(scalar(yyvsp[-3].opval)))))); dep();}
break;
case 126:
-#line 471 "perly.y"
+#line 470 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL);
hints |= HINT_BLOCK_SCOPE; }
break;
case 127:
-#line 474 "perly.y"
+#line 473 "perly.y"
{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); }
break;
case 128:
-#line 476 "perly.y"
+#line 475 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
case 129:
-#line 478 "perly.y"
+#line 477 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 130:
-#line 480 "perly.y"
+#line 479 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 131:
-#line 482 "perly.y"
+#line 481 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
case 132:
-#line 484 "perly.y"
+#line 483 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, 0); }
break;
case 133:
-#line 486 "perly.y"
+#line 485 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); }
break;
case 134:
-#line 488 "perly.y"
+#line 487 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
case 135:
-#line 490 "perly.y"
+#line 489 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); }
break;
case 136:
-#line 492 "perly.y"
+#line 491 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); }
break;
case 139:
-#line 498 "perly.y"
+#line 497 "perly.y"
{ yyval.opval = Nullop; }
break;
case 140:
-#line 500 "perly.y"
+#line 499 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 141:
-#line 504 "perly.y"
+#line 503 "perly.y"
{ yyval.opval = Nullop; }
break;
case 142:
-#line 506 "perly.y"
+#line 505 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 143:
-#line 508 "perly.y"
+#line 507 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 144:
-#line 512 "perly.y"
+#line 511 "perly.y"
{ yyval.opval = newCVREF(yyvsp[0].opval); }
break;
case 145:
-#line 516 "perly.y"
+#line 515 "perly.y"
{ yyval.opval = newSVREF(yyvsp[0].opval); }
break;
case 146:
-#line 520 "perly.y"
+#line 519 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
case 147:
-#line 524 "perly.y"
+#line 523 "perly.y"
{ yyval.opval = newHVREF(yyvsp[0].opval); }
break;
case 148:
-#line 528 "perly.y"
+#line 527 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
case 149:
-#line 532 "perly.y"
+#line 531 "perly.y"
{ yyval.opval = newGVREF(0,yyvsp[0].opval); }
break;
case 150:
-#line 536 "perly.y"
+#line 535 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
case 151:
-#line 538 "perly.y"
+#line 537 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
case 152:
-#line 540 "perly.y"
+#line 539 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 153:
-#line 543 "perly.y"
+#line 542 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
#line 2157 "y.tab.c"
-*** perly.c.orig Thu Sep 15 11:18:35 1994
---- perly.c Thu Sep 15 11:19:31 1994
+*** perly.c.orig Thu Feb 9 17:56:15 1995
+--- perly.c Thu Feb 9 17:56:17 1995
***************
*** 12,79 ****
deprecate("\"do\" to call subroutines");
}
-- #line 30 "perly.y"
+- #line 29 "perly.y"
- typedef union {
- I32 ival;
- char *pval;
- short yyss[YYSTACKSIZE];
- YYSTYPE yyvs[YYSTACKSIZE];
- #define yystacksize YYSTACKSIZE
- #line 544 "perly.y"
+ #line 545 "perly.y"
/* PROGRAM */
#line 1347 "y.tab.c"
--- 1272,1279 ----
#endif
yym = yylen[yyn];
***************
-*** 2161,2168 ****
+*** 2163,2170 ****
{
#if YYDEBUG
if (yydebug)
#endif
yystate = YYFINAL;
*++yyssp = YYFINAL;
---- 2178,2186 ----
+--- 2180,2188 ----
{
#if YYDEBUG
if (yydebug)
yystate = YYFINAL;
*++yyssp = YYFINAL;
***************
-*** 2176,2182 ****
+*** 2178,2184 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
YYFINAL, yychar, yys);
}
#endif
---- 2194,2200 ----
+--- 2196,2202 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
}
#endif
***************
-*** 2191,2210 ****
+*** 2193,2212 ****
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
yyaccept:
! return (0);
}
---- 2209,2243 ----
+--- 2211,2245 ----
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
@export = ();
print "$oldpack => $newpack\n" if $verbose;
+ s/\bstd(in|out|err)\b/\U$&/g;
s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;
if (/sub\s+main'/) {
@export = m/sub\s+main'(\w+)/g;
=head1 DESCRIPTION
-This module is a "pure virtual base class"--it has nothing of us its own.
+This module is a "pure virtual base class"--it has nothing of its own.
It's just there to inherit from one of the various DBM packages. It
prefers ndbm for compatibility reasons with Perl 4, then Berkeley DB (See
-L<DB_File>), GDBM, SDBM (which is always there -- it comes with Perl), and
-finally ODBM. This way old programs that used to use NDBM via dbmopen() can still
-do so, but new ones can reorder @ISA:
+L<DB_File>), GDBM, SDBM (which is always there--it comes with Perl), and
+finally ODBM. This way old programs that used to use NDBM via dbmopen()
+can still do so, but new ones can reorder @ISA:
@AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File);
-This makes it trivial to copy database formats:
+Note, however, that an explicit use overrides the specified order:
+
+ use GDBM_File;
+ @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File);
+
+will only find GDBM_File.
+
+Having multiple DBM implementations makes it trivial to copy database formats:
use POSIX; use NDBM_File; use DB_File;
tie %newhash, DB_File, $new_filename, O_CREAT|O_RDWR;
=head1 DESCRIPTION
These routines allow you to parse file specifications into useful
-pieces according using the syntax of different operating systems.
+pieces using the syntax of different operating systems.
=over 4
timeit - run a chunk of code and see how long it goes
-=head1 SYNOPSYS
+=head1 SYNOPSIS
timethis ($count, "code");
=head1 SYNOPSIS
require Cwd;
- $dir = Cwd::getcwd()'
+ $dir = Cwd::getcwd();
use Cwd;
- $dir = getcwd()'
+ $dir = getcwd();
use Cwd 'chdir';
chdir "/tmp";
$dl_library_path[0], [1], ... etc
@dl_library_path is initialised to hold the list of 'normal' directories
-(F</usr/lib>, etc) determined by B<Configure> (C<$Config{'libpth'}.). This should
+(F</usr/lib>, etc) determined by B<Configure> (C<$Config{'libpth'}>). This should
ensure portability across a wide range of platforms.
@dl_library_path should also be initialised with any other directories
To support these systems a dl_expandspec() function can be implemented
either in the F<dl_*.xs> file or code can be added to the autoloadable
-dl_expandspec(0 function in F<DynaLoader.pm). See F<DynaLoader.pm> for more
+dl_expandspec(0 function in F<DynaLoader.pm>). See F<DynaLoader.pm> for more
information.
=item dl_load_file()
import - import functions into callers namespace
-=head1 SYNOPSYS
+=head1 SYNOPSIS
package WhatEver;
require Exporter;
@EXPORT = qw(func1, $foo, %tabs);
@EXPORT_OK = qw(sin cos);
...
- use Whatever;
+ use WhatEver;
use WhatEver 'sin';
=head1 DESCRIPTION
The WhatEver module above has placed in its export list
the function C<func1()>, the scalar C<$foo>, and the
hash C<%tabs>. When someone decides to
-C<use WhatEver>, they get those identifier grafted
+C<use WhatEver>, they get those identifiers grafted
onto their own namespace. That means the user of
package whatever can use the function func1() instead
of fully qualifying it as WhatEver::func1().
find - traverse a file tree
-=head1 SYNOPSYS
+=head1 SYNOPSIS
use File::Find;
find(\&wanted, '/foo','/bar');
=head1 DESCRIPTION
-The wanted() function does whatever verificationsyou want. $dir contains
+The wanted() function does whatever verifications you want. $dir contains
the current directory name, and $_ the current filename within that
directory. $name contains C<"$dir/$_">. You are chdir()'d to $dir when
the function is called. The function may set $prune to prune the tree.
finddepth - traverse a directory structure depth-first
-=head1 SYNOPSYS
+=head1 SYNOPSIS
use File::Finddepth;
finddepth(\&wanted, '/foo','/bar');
=head2 DESCRIPTION
-This is just like C<File::Find>, except that it does a depthfirst
-search uses finddepth() rather than find(), and performs a
-depth-first search.
-
+This is just like C<File::Find>, except that it does a depth-first
+search and uses finddepth() rather than find().
use Getopt::Std;
getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
- getopts('oif:'); # likewise, but all of them
+ getopts('oif:'); # -o & -i are boolean flags, -f takes an argument
+ # Sets opt_* as a side effect.
use Getopt::Long;
$result = GetOptions (...option-descriptions...);
This utility is designed to write a Makefile for an extension module from
a Makefile.PL. It splits the task of generating the Makefile into several
-subroutines that can be individually overridden. Each subroutines returns
+subroutines that can be individually overridden. Each subroutine returns
the text it wishes to have written to the Makefile.
The best way to learn to use this is to look at how some of the
it and reading from it. This is presumably safe because you "know"
that commands like B<bc> will read a line at a time and output a line at
a time. Programs like B<sort> that read their entire input stream first,
-however, are quite apt to cause deadlock. See L<open3> for an alternative.
+however, are quite apt to cause deadlock.
+
+The big problem with this approach is that if you don't have control
+over source code being run in the the child process, you can't control what it does
+with pipe buffering. Thus you can't just open a pipe to "cat -v" and continually
+read and write a line from it.
+
+=head1 SEE ALSO
+
+See L<open3> for an alternative that handles STDERR as well.
+
=head1 EXAMPLES
- printf "EENTR is %d\n", EINTR;
+ printf "EINTR is %d\n", EINTR;
POSIX::setsid(0);
A few functions are not implemented because they are C specific. If you
attempt to call these, they will print a message telling you that they
-aren't implemented because they're, supplying the Perl equivalent if one
-exists. For example, trying to access the setjmp() call will elicit the
+aren't implemented, and suggest using the Perl equivalent should one
+exist. For example, trying to access the setjmp() call will elicit the
message "setjmp() is C-specific: use eval {} instead".
Furthermore, some evil vendors will claim 1003.1 compliance, but in fact
This module contains routines to test for the reachability of remote hosts.
Currently the only routine implemented is pingecho().
-pingecho() uses a TCP echo (I<NOT> an ICMP one) to determine if the
+pingecho() uses a TCP echo (I<not> an ICMP one) to determine if the
remote host is reachable. This is usually adequate to tell that a remote
host is available to rsh(1), ftp(1), or telnet(1) onto.
=head1 DESCRIPTION
Currently unimplemented, this may someday be a compiler directive
-to make certain trade-off, such as perhaps
+to make certain trade-offs, such as perhaps
use less 'memory';
use less 'CPU';
=head1 DESCRIPTION
If no import list is supplied, all possible restrictions are assumed.
-(This the safest mode to operate in, but is sometimes too strict for
-casual programming.) Currently, there are three possible things to be
-strict about: "subs", "vars", or "refs".
+(This is the safest mode to operate in, but is sometimes too strict for
+casual programming.) Currently, there are three possible things to be
+strict about: "subs", "vars", and "refs".
=over 6
This disables the poetry optimization,
generating a compile-time error if you
-try to use a bareword identifiers that's not a subroutine.
+try to use a bareword identifier that's not a subroutine.
use strict 'subs';
$SIG{PIPE} = Plumber; # blows up
Perl is at the mercy of your machine's definitions of various
operations such as type casting, atof() and sprintf().
-If your stdio requires an seek or eof between reads and writes on a
+If your stdio requires a seek or eof between reads and writes on a
particular stream, so does Perl. (This doesn't apply to sysread()
and syswrite().)
=head1 AUTHOR
-Dean Roehrich <roehrich@cray.com>
+Dean Roehrich C<roehrich@cray.com>
September 27, 1994
=head1 DESCRIPTION
You can order Perl books from O'Reilly & Associates, 1-800-998-9938.
-Local/overseas is 1-707-829-0515. If you can locate an O'Reilly order
-form, you can also fax to 1-707-829-0104. I<Programming Perl> is a
+Local/overseas is +1 707 829 0515. If you can locate an O'Reilly order
+form, you can also fax to +1 707 829 0104. I<Programming Perl> is a
reference work that covers nearly all of Perl (version 4, alas), while
I<Learning Perl> is a tutorial that covers the most frequently used subset
of the language.
conflict, use the same name for a scalar variable, an array, or a hash
(or, for that matter, a filehandle, a subroutine name, or a label).
This means that $foo and @foo are two different variables. It also
-means that $foo[1] is a part of @foo, not a part of $foo. This may
+means that C<$foo[1]> is a part of @foo, not a part of $foo. This may
seem a bit weird, but that's okay, because it is weird.
Since variable and array references always start with '$', '@', or '%',
print "The price is $Price.\n"; # interpreted
As in some shells, you can put curly brackets around the identifier to
-delimit it from following alphanumerics. Also note that a
+delimit it from following alphanumerics. In fact, an identifier
+within such curlies is forced to be a string, as is any single
+identifier within a hash subscript. Our earlier example,
+
+ $days{'Feb'}
+
+can be written as
+
+ $days{Feb}
+
+and the quotes will be assumed automatically. But anything more complicated
+in the subscript will be interpreted as an expression.
+
+Note that a
single-quoted string must be separated from a preceding word by a
-space, since single quote is a valid (though discouraged) character in
+space, since single quote is a valid (though deprecated) character in
an identifier (see L<perlmod/Packages>).
Two special literals are __LINE__ and __FILE__, which represent the
required file or evaluated string.) The two control characters ^D and
^Z are synonyms for __END__.
-A word that doesn't have any other interpretation in the grammar will
+A word that has no other interpretation in the grammar will
be treated as if it were a quoted string. These are known as
"barewords". As with filehandles and labels, a bareword that consists
entirely of lowercase letters risks conflict with future reserved
(LIST)
-In a context not requiring an list value, the value of the list
+In a context not requiring a list value, the value of the list
literal is the value of the final element, as with the C comma operator.
For example,
(P) An internal error you should never see (trappable).
(X) A very fatal error (non-trappable).
-Optional warnings are enabled by using the B<-w> switch. Trappable
-errors may be trapped using the eval operator. See L<perlfunc/eval>.
+Optional warnings are enabled by using the B<-w> switch. Warnings may
+be captured by setting C<$^Q> to a reference to a routine that will be
+called on each warning instead of printing it. See L<perlvar>.
+Trappable errors may be trapped using the eval operator. See
+L<perlfunc/eval>.
Some of these messages are generic. Spots that vary are denoted with a %s,
just as in a printf format. Note that some message start with a %s!
(F) msgsnd() requires a string at least as long as sizeof(long).
+=item Ambiguous use of %s resolved as %s
+
+(W)(S) You said something that may not be interpreted the way
+you thought. Normally it's pretty easy to disambiguate it by supplying
+a missing quote, operator, paren pair or declaration.
+
=item Args must match #! line
(F) The setuid emulator requires that the arguments Perl was invoked
=item Can't create pipe mailbox
-(F) An error peculiar to VMS.
+(P) An error peculiar to VMS. The process is suffering from exhausted quotas
+or other plumbing problems.
=item Can't declare %s in my
(F) A fatal error occurred while trying to fork while opening a pipeline.
+=item Can't get filespec - stale stat buffer?
+
+(S) A warning peculiar to VMS. This arises because of the difference between
+access checks under VMS and under the Unix model Perl assumes. Under VMS,
+access checks are done by filename, rather than by bits in the stat buffer, so
+that ACLs and other protections can be taken into account. Unfortunately, Perl
+assumes that the stat buffer contains all the necessary information, and passes
+it, instead of the filespec, to the access checking routine. It will try to
+retrieve the filespec using the device name and FID present in the stat buffer,
+but this works only if you haven't made a subsequent call to the CRTL stat()
+routine, since the device name is overwritten with each call. If this warning
+appears, the name lookup failed, and the access checking routine gave up and
+returned FALSE, just to be conservative. (Note: The access checking routine
+knows about the Perl C<stat> operator and file tests, so you shouldn't ever
+see this warning in response to a Perl command; it arises only if some internal
+code takes stat buffers lightly.)
+
=item Can't get pipe mailbox device name
-(F) An error peculiar to VMS.
+(P) An error peculiar to VMS. After creating a mailbox to act as a pipe, Perl
+can't retrieve its name for later use.
=item Can't get SYSGEN parameter value for MAXBUF
-(F) An error peculiar to VMS.
+(P) An error peculiar to VMS. Perl asked $GETSYI how big you want your
+mailbox buffers to be, and didn't get an answer.
=item Can't goto subroutine outside a subroutine
you should only be calling it out of an AUTOLOAD routine anyway. See
L<perlfunc/goto>.
+=item Can't localize lexical variable %s
+
+(F) You used local on a variable name that was previous declared as a
+lexical variable using "my". This is not allowed. If you want to
+localize a package variable of the same name, qualify it with the
+package name.
+
=item Can't locate %s in @INC
(F) You said to do (or require, or use) a file that couldn't be found
"open2.pl". Alternately, direct the pipe's output to a file using ">",
and then read it in under a different file handle.
+=item Can't open error file %s as stderr
+
+(F) An error peculiar to VMS. Perl does its own command line redirection, and
+couldn't open the file specified after '2>' or '2>>' on the command line for
+writing.
+
+=item Can't open input file %s as stdin
+
+(F) An error peculiar to VMS. Perl does its own command line redirection, and
+couldn't open the file specified after '<' on the command line for reading.
+
+=item Can't open output file %s as stdout
+
+(F) An error peculiar to VMS. Perl does its own command line redirection, and
+couldn't open the file specified after '>' or '>>' on the command line for
+writing.
+
+=item Can't open output pipe (name: %s)
+
+(P) An error peculiar to VMS. Perl does its own command line redirection, and
+couldn't open the pipe into which to send data destined for stdout.
+
=item Can't open perl script "%s": %s
(F) The script you specified can't be opened for the indicated reason.
(S) The rename done by the B<-i> switch failed for some reason, probably because
you don't have write permission to the directory.
+=item Can't reopen input pipe (name: %s) in binary mode
+
+(P) An error peculiar to VMS. Perl thought stdin was a pipe, and tried to
+reopen it to accept binary data. Alas, it failed.
+
=item Can't reswap uid and euid
(P) The setreuid() call failed for some reason in the setuid emulator
of upgradability. Upgrading to undef indicates an error in the
code calling sv_upgrade.
-=item Can't use %s as left arg of an implicit ->
-
-(F) The compiler tried to interpret a bracketed expression as a subscript
-to an array reference. But to the left of the brackets was an expression
-that didn't end in an arrow (->), or look like a subscripted expression.
-Only subscripted expressions with multiple subscripts are allowed to omit
-the intervening arrow.
-
=item Can't use %s for loop variable
(F) Only a simple scalar variable may be used as a loop variable on a foreach.
reference of the type needed. You can use the ref() function to
test the type of the reference, if need be.
-=item Can't use a string as %s ref while "strict refs" in use
+=item Can't use \1 to mean $1 in expression
+
+(W) In an ordinary expression, backslash is a unary operator that creates
+a reference to its argument. The use of backslash to indicate a backreference
+to a matched substring is only valid as part of a regular expression pattern.
+Trying to do this in ordinary Perl code produces a value that prints
+out looking like SCALAR(0xdecaf). Use the $1 form instead.
+
+=item Can't use string ("%s") as %s ref while "strict refs" in use
(F) Only hard references are allowed by "strict refs". Symbolic references
are disallowed. See L<perlref>.
variables in your program that looked like magical variables but
weren't.
+=item Can't use subscript on %s
+
+(F) The compiler tried to interpret a bracketed expression as a
+subscript. But to the left of the brackets was an expression that
+didn't look like an array reference, or anything else subscriptable.
+
=item Can't write to temp file for B<-e>: %s
(F) The write routine failed for some reason while trying to process
recursion, unless you're writing strange benchmark programs, in which
case it indicates something else.
-=item Did you mean $ instead of %?
+=item Did you mean $ or @ instead of %?
-(W) You probably said %hash{$key} when you meant $hash{$key}.
+(W) You probably said %hash{$key} when you meant $hash{$key} or @hash{@keys}.
+On the other hand, maybe you just meant %hash and got carried away.
+
+=item Do you need to predeclare %s?
+
+(S) This is an educated guess made in conjunction with the message "%s
+found where operator expected". It often means a subroutine or module
+name is being referenced that hasn't been declared yet. This may be
+because of ordering problems in your file, or because of a missing
+"sub", "package", "require", or "use" statement. If you're
+referencing something that isn't defined yet, you don't actually have
+to define the subroutine or package before the current location. You
+can use an empty "sub foo;" or "package FOO;" to enter a "forward"
+declaration.
=item Don't know how to handle magic of type '%s'
(F) An untrapped exception was raised while executing an END subroutine.
The interpreter is immediately exited.
+=item Error converting file specification %s
+
+(F) An error peculiar to VMS. Since Perl may have to deal with file
+specifications in either VMS or Unix syntax, it converts them to a
+single form when it must operate on them directly. Either you've
+passed an invalid file specification to Perl, or you've found a
+case the conversion routines don't handle. Drat.
+
=item Execution of %s aborted due to compilation errors.
(F) The final summary message when a Perl compilation fails.
(W) You are exiting a substitution by unconventional means, such as a
a return, a goto, or a loop control statement.
-=item Fatal $PUTMSG error: %d
+=item Fatal VMS error at %s, line %d
-(F) An error peculiar to VMS.
+(P) An error peculiar to VMS. Something untoward happened in a VMS system
+service or RTL routine; Perl's exit status should provide more details. The
+filename in "at %s" and the line number in "line %d" tell you which section of
+the Perl source code is distressed.
=item fcntl is not implemented
(W) You tried to get a socket or peer socket name on a closed socket.
Did you forget to check the return value of your socket() call?
+=item getpwnam returned invalid UIC %#o for user "%s"
+
+(S) A warning peculiar to VMS. The call to C<sys$getuai> underlying the
+C<getpwnam> operator returned an invalid UIC.
+
+
=item Glob not terminated
(F) The lexer saw a left angle bracket in a place where it was expecting
(F) You used an 8 or 9 in a octal number.
+=item Illegal octal digit ignored
+
+(W) You may have tried to use an 8 or 9 in a octal number. Interpretation
+of the octal number stopped before the 8 or 9.
+
=item Insecure dependency in %s
(F) You tried to do something that the tainting mechanism didn't like.
potentially supplied) by the user. The script must set the path to a
known value, using trustworthy data. See L<perlsec>.
+=item Internal inconsistency in tracking vforks
+
+(S) A warning peculiar to VMS. Perl keeps track of the number
+of times you've called C<fork> and C<exec>, in order to determine
+whether the current call to C<exec> should be affect the current
+script or a subprocess (see L<perlvms/exec>). Somehow, this count
+has become scrambled, so Perl is making a guess and treating
+this C<exec> as a request to terminate the Perl script
+and execute the specified command.
+
=item internal disaster in regexp
(P) Something went badly wrong in the regular expression parser.
(F) While certain functions allow you to specify a filehandle or an
"indirect object" before the argument list, this ain't one of them.
+=item Missing operator before %s?
+
+(S) This is an educated guess made in conjunction with the message "%s
+found where operator expected". Often the missing operator is a comma.
+
=item Missing right bracket
(F) The lexer counted more opening curly brackets (braces) than closing ones.
allowed to have a comma between that and the following arguments.
Otherwise it'd be just another one of the arguments.
+=item No command into which to pipe on command line
+
+(F) An error peculiar to VMS. Perl handles its own command line redirection,
+and found a '|' at the end of the command line, so it doesn't know whither you
+want to pipe the output from this command.
+
=item No DB::DB routine defined
(F) The currently executing code was compiled with the B<-d> switch,
didn't define a DB::sub routine to be called at the beginning of each
ordinary subroutine call.
+=item No error file after 2> or 2>> on command line
+
+(F) An error peculiar to VMS. Perl handles its own command line redirection,
+and found a '2>' or a '2>>' on the command line, but can't find the name of the
+file to which to write data destined for stderr.
+
+=item No input file after < on command line
+
+(F) An error peculiar to VMS. Perl handles its own command line redirection,
+and found a '<' on the command line, but can't find the name of the file from
+which to read data for stdin.
+
+=item No output file after > on command line
+
+(F) An error peculiar to VMS. Perl handles its own command line redirection,
+and found a lone '>' at the end of the command line, so it doesn't know whither
+you wanted to redirect stdout.
+
+=item No output file after > or >> on command line
+
+(F) An error peculiar to VMS. Perl handles its own command line redirection,
+and found a '>' or a '>>' on the command line, but can't find the name of the
+file to which to write data destined for stdout.
+
=item No Perl script found in input
(F) You called C<perl -x>, but no line was found in the file beginning
(F) The argument to B<-I> must follow the B<-I> immediately with no
intervening space.
+=item No such pipe open
+
+(P) An error peculiar to VMS. The internal routine my_pclose() tried to
+close a pipe which hadn't been opened. This should have been caught earlier as
+an attempt to close an unopened filehandle.
+
=item No such signal: SIG%s
(W) You specified a signal name as a subscript to %SIG that was not recognized.
(F) An attempt was made to use an entry in an overloading table that
somehow no longer points to a valid method. See L<perlovl>.
+=item Operator or semicolon missing before %s
+
+(S) You used a variable or subroutine call where the parser was
+expecting an operator. The parser has assumed you really meant
+to use an operator, but this is highly likely to be incorrect.
+For example, if you say "*foo *foo" it will be interpreted as
+if you said "*foo * 'foo'".
+
=item Out of memory for yacc stack
(F) The yacc parser wanted to grow its stack so it could continue parsing,
(F) The setuid emulator in suidperl decided you were up to no good.
+=item pid %d not a child
+
+(W) A warning peculiar to VMS. Waitpid() was asked to wait for a process which
+isn't a subprocess of the current process. While this is fine from VMS'
+perspective, it's probably not what you intended.
+
=item POSIX getpgrp can't take an argument
(F) Your C compiler uses POSIX getpgrp(), which takes no argument, unlike
like a list when you assign to it, and provides a list context to its
subscript, which can do weird things if you're only expecting one subscript.
+On the other hand, if you were actually hoping to treat the array
+element as a list, you need to look into how references work, since
+Perl will not magically convert between scalars and lists for you. See
+L<perlref>.
+
=item Script is not setuid/setgid in suidperl
(F) Oddly, the suidperl program was invoked on a script with its setuid
use the new C<//m> and C<//s> modifiers now to do that without the dangerous
action-at-a-distance effects of C<$*>.
+=item Use of %s in printf format not supported
+
+(F) You attempted to use a feature of printf that is accessible only
+from C. This usually means there's a better way to do it in Perl.
+
=item Use of %s is deprecated
(D) The construct indicated is no longer recommended for use, generally
($one, $two) = (1, 2);
+Another common error is to use ordinary parentheses to construct a list
+reference when you should be using square or curly brackets, for
+example, if you say
+
+ $array = (1,2);
+
+when you should have said
+
+ $array = [1,2];
+
+The square brackets explicitly turn a list value into a scalar value,
+while parentheses do not. So when a parenthesized list is evaluated in
+a scalar context, the comma is treated like C's comma operator, which
+throws away the left argument, which is not what you want. See
+L<perlref> for more on this.
+
=item Warning: unable to close filehandle %s properly.
(S) The implicit close() done by an open() got an error indication on the
because other Perl programmers will expect it, and it works better
if there are more than 9 backreferences.
+=item '|' and '<' may not both be specified on command line
+
+(F) An error peculiar to VMS. Perl does its own command line redirection, and
+found that STDIN was a pipe, and that you also tried to redirect STDIN using
+'<'. Only one STDIN stream to a customer, please.
+
+=item '|' and '>' may not both be specified on command line
+
+(F) An error peculiar to VMS. Perl does its own command line redirection, and
+thinks you tried to redirect stdout both to a file and into a pipe to another
+command. You need to choose one or the other, though nothing's stopping you
+from piping into a program or Perl script which 'splits' output into two
+streams, such as
+
+ open(OUT,">$ARGV[0]") or die "Can't write to $ARGV[0]: $!";
+ while (<STDIN>) {
+ print;
+ print OUT;
+ }
+ close OUT;
+
=back
facilitate this, Perl helps you lay out your output page in your code in a
fashion that's close to how it will look when it's printed. It can keep
track of things like how many lines on a page, what page you're, when to
-print page headers, etc. The keywords used are borrowed from FORTRAN:
+print page headers, etc. Keywords are borrowed from FORTRAN:
format() to declare and write() to execute; see their entries in
-L<manfunc>. Fortunately, the layout is much more legible, more like
+L<perlfunc>. Fortunately, the layout is much more legible, more like
BASIC's PRINT USING statement. Think of it as a poor man's nroff(1).
Formats, like packages and subroutines, are declared rather than executed,
$FORMAT_LINE_BREAK_CHARACTERS if you're using the English module) to a
list of the desired characters.
-Since use of caret fields can produce variable length records. If the text
+Using caret fields can produce variable length records. If the text
to be formatted is short, you can suppress blank lines by putting a
"~" (tilde) character anywhere in the line. The tilde will be translated
to a space upon output. If you put a second tilde contiguous to the
and the current top of form format name is in C<$^> ($FORMAT_TOP_NAME).
The current output page number is stored in C<$%> ($FORMAT_PAGE_NUMBER),
and the number of lines on the page is in C<$=> ($FORMAT_LINES_PER_PAGE).
-Whether to autoflush output on this handle is stored in $<$|>
+Whether to autoflush output on this handle is stored in C<$|>
($OUTPUT_AUTOFLUSH). The string output before each top of page (except
the first) is stored in C<$^L> ($FORMAT_FORMFEED). These variables are
set on a per-filehandle basis, so you'll need to select() into a different
=head1 NOTES
-Since the values line may contain arbitrary expression (for at fields,
-not caret fields), you can farm out any more sophisticated processing
+Since the values line may contain arbitrary expressions (for at fields,
+not caret fields), you can farm out more sophisticated processing
to other functions, like sprintf() or one of your own. For example:
format Ident =
Or to make an swrite() subroutine which is to write() what sprintf()
is to printf(), do this:
- use English;
use Carp;
sub swrite {
- croak "usage: swrite PICTURE ARGS" unless @ARG;
- local($ACCUMULATOR);
- formline(@ARG);
- return $ACCUMULATOR;
+ croak "usage: swrite PICTURE ARGS" unless @_;
+ my $format = shift;
+ $^A = "";
+ formline($format,@_);
+ return $^A;
}
$string = swrite(<<'END', 1, 2, 3);
=head1 WARNING
-During the execution of a format, only global variables are visible,
-or dynamically-scoped ones declared with local(). Lexically scoped
-variables declared with my() are I<NOT> available, as they are not
-considered to reside in the same lexical scope as the format.
+Lexical variables (declared with "my") are not visible within a
+format unless the format is declared within the scope of the lexical
+variable. (They weren't visiblie at all before version 5.001.)
returns TRUE if there is a caller, that is, if we're in a subroutine or
eval() or require(), and FALSE otherwise. In a list context, returns
- ($package,$filename,$line) = caller;
+ ($package, $filename, $line) = caller;
With EXPR, it returns some extra information that the debugger uses to
print a stack trace. The value of EXPR indicates how many call frames
to go back before the current one.
+ ($package, $filename, $line,
+ $subroutine, $hasargs, $wantargs) = caller($i);
+
+Furthermore, when called from within the DB package, caller returns more
+detailed information: it sets sets the list variable @DB:args to be the
+arguments with which that subroutine was invoked.
+
=item chdir EXPR
Changes the working directory to EXPR, if possible. If EXPR is
If you chop a list, each element is chopped. Only the value of the
last chop is returned.
+Note that chop returns the last character. To return all but the last
+character, use C<substr($string, 0, -1)>.
+
=item chown LIST
Changes the owner (and group) of a list of files. The first two
Attempts to connect to a remote socket, just as the connect system call
does. Returns TRUE if it succeeded, FALSE otherwise. NAME should be a
-package address of the appropriate type for the socket. See example in
+packed address of the appropriate type for the socket. See example in
L<perlipc>.
=item cos EXPR
}
Of course, typing in your own password to whoever asks you
-for it is unwise at best.
+for it is unwise.
=item dbmclose ASSOC_ARRAY
Outside of an eval(), prints the value of LIST to C<STDERR> and exits with
the current value of $! (errno). If $! is 0, exits with the value of
-C<($? E<gt>E<gt> 8)> (`command` status). If C<($? E<gt>E<gt> 8)> is 0,
-exits with 255. Inside an eval(), the error message is stuffed into C<$@>.
+C<($? E<gt>E<gt> 8)> (backtick `command` status). If C<($? E<gt>E<gt> 8)> is 0,
+exits with 255. Inside an eval(), the error message is stuffed into C<$@>,
and the eval() is terminated with the undefined value.
Equivalent examples:
FILEHANDLE is not open. FILEHANDLE may be an expression whose value
gives the real filehandle name. (Note that this function actually
reads a character and then ungetc()s it, so it is not very useful in an
-interactive context.) An C<eof> without an argument returns the eof status
-for the last file read. Empty parentheses () may be used to indicate
+interactive context.) Do not read from a terminal file (or call
+C<eof(FILEHANDLE)> on it) after end-of-file is reached. Filetypes such
+as terminals may lose the end-of-file condition if you do.
+
+An C<eof> without an argument uses the last file read as argument.
+Empty parentheses () may be used to indicate
the pseudo file formed of the files listed on the command line, i.e.
C<eof()> is reasonable to use inside a while (<>) loop to detect the end
of only the last file. Use C<eof(ARGV)> or eof without the parentheses to
test I<EACH> file in a while (<>) loop. Examples:
+ # reset line numbering on each input file
+ while (<>) {
+ print "$.\t$_";
+ close(ARGV) if (eof); # Not eof().
+ }
+
# insert dashes just before last line of last file
while (<>) {
if (eof()) {
print "--------------\n";
+ close(ARGV); # close or break; is needed if we
+ # are reading from the terminal
}
print;
}
- # reset line numbering on each input file
- while (<>) {
- print "$.\t$_";
- if (eof) { # Not eof().
- close(ARGV);
- }
- }
-
Practical hint: you almost never need to use C<eof> in Perl, because the
input operators return undef when they run out of data.
likewise behave in the same way: they run the code <$x>, which does
nothing at all. (Case 4 is preferred for purely visual reasons.) Case 5
is a place where normally you I<WOULD> like to use double quotes, except
-that in particular situation, you can just use symbolic references
+in that particular situation, you can just use symbolic references
instead, as in case 6.
=item exec LIST
C<$^A> are written to some filehandle, but you could also read C<$^A>
yourself and then set C<$^A> back to "". Note that a format typically
does one formline() per line of form, but the formline() function itself
-doesn't care how many newlines are embedded in the PICTURE. Be careful
-if you put double quotes around the picture, since an "C<@>" character may
-be taken to mean the beginning of an array name. formline() always
-returns TRUE.
+doesn't care how many newlines are embedded in the PICTURE. This means
+that the ~ and ~~ tokens will treat the entire PICTURE as a single line.
+You may therefore need to use multiple formlines to implement a single
+record format, just like the format compiler.
+
+Be careful if you put double quotes around the picture, since an "C<@>"
+character may be taken to mean the beginning of an array name.
+formline() always returns TRUE.
=item getc FILEHANDLE
=item gmtime EXPR
Converts a time as returned by the time function to a 9-element array
-with the time analyzed for the Greenwich timezone. Typically used as
+with the time localized for the Greenwich timezone. Typically used as
follows:
=item goto LABEL
+=item goto EXPR
+
=item goto &NAME
The goto-LABEL form finds the statement labeled with LABEL and resumes
construct such as last or die. The author of Perl has never felt the
need to use this form of goto (in Perl, that is--C is another matter).
+The goto-EXPR form expects a label name, whose scope will be resolved
+dynamically. This allows for computed gotos per FORTRAN, but isn't
+necessarily recommended if you're optimizing for maintainability:
+
+ goto ("FOO", "BAR", "GLARCH")[$i];
+
The goto-&NAME form is highly magical, and substitutes a call to the
named subroutine for the currently running subroutine. This is used by
AUTOLOAD subroutines that wish to load another subroutine and then
There is no built-in import() function. It is merely an ordinary
method subroutine defined (or inherited) by modules that wish to export
names to another module. The use() function calls the import() method
-for the package used. See also L</use> below and L<perlmod>.
+for the package used. See also L</use> and L<perlmod>.
=item index STR,SUBSTR,POSITION
=item local EXPR
In general, you should be using "my" instead of "local", because it's
-faster and safer. Format variables have to use "local" though, as
-do any other variables whose local value must be visible to called
+faster and safer. Format variables often use "local" though, as
+do other variables whose current value must be visible to called
subroutines. This is known as dynamic scoping. Lexical scoping is
done with "my", which works more like C's auto declarations.
}
Note that local() is a run-time command, and so gets executed every
-time through a loop. In Perl 4 it used up more stack storage each
+time through a loop. In Perl 4 it used more stack storage each
time until the loop was exited. Perl 5 reclaims the space each time
through, but it's still more efficient to declare your variables
outside the loop.
+A local is simply a modifier on an lvalue expression.
When you assign to a localized EXPR, the local doesn't change whether
EXPR is viewed as a scalar or an array. So
}
# Outer @ARGV again visible
-When you assign to the EXPR, the "my" doesn't change whether
+The "my" is simply a modifier on something you might assign to.
+So when you do assign to the EXPR, the "my" doesn't change whether
EXPR is viewed as a scalar or an array. So
- my($foo) = <STDIN>;
+ my ($foo) = <STDIN>;
my @FOO = <STDIN>;
both supply a list context to the righthand side, while
my $foo = <STDIN>;
-supplies a scalar context.
+supplies a scalar context. But the following only declares one variable:
+
+ my $foo, $bar = 1;
+
+That has the same effect as
+
+ my $foo;
+ $bar = 1;
+
+The declared variable is not introduced (is not visible) until after
+the current statement. Thus,
+
+ my $x = $x;
+
+can be used to initialize the new $x with the value of the old $x, and
+the expression
+
+ my $x = 123 and $x == 123
+
+is false unless the old $x happened to have the value 123.
Some users may wish to encourage the use of lexically scoped variables.
As an aid to catching implicit references to package variables,
to make it easy to load standard modules. This form of loading of
modules does not risk altering your namespace.
-For a yet more powerful import facility, see the L</use()> below, and
-also L<perlmod>.
+For a yet-more-powerful import facility, see the L</use()> and
+L<perlmod>.
=item reset EXPR
of the filehandle. The values for WHENCE are 0 to set the file pointer to
POSITION, 1 to set the it to current plus POSITION, and 2 to set it to EOF
plus offset. You may use the values SEEK_SET, SEEK_CUR, and SEEK_END for
-this is usin the POSIX module. Returns 1 upon success, 0 otherwise.
+this is using the POSIX module. Returns 1 upon success, 0 otherwise.
=item seekdir DIRHANDLE,POS
=item setpriority WHICH,WHO,PRIORITY
Sets the current priority for a process, a process group, or a user.
-(See Lsetpriority(2)>.) Will produce a fatal error if used on a machine
+(See setpriority(2).) Will produce a fatal error if used on a machine
that doesn't implement setpriority(2).
=item setsockopt SOCKET,LEVEL,OPTNAME,OPTVAL
value.) The use of implicit split to @_ is deprecated, however.
If EXPR is omitted, splits the $_ string. If PATTERN is also omitted,
-splits on whitespace (C</[ \t\n]+/>). Anything matching PATTERN is taken
+splits on whitespace (after skipping any leading whitespace).
+Anything matching PATTERN is taken
to be a delimiter separating the fields. (Note that the delimiter may
be longer than one character.) If LIMIT is specified and is not
negative, splits into no more than that many fields (though it may
had been specified.
A pattern matching the null string (not to be confused with
-a null pattern C<//., which is just one member of the set of patterns
+a null pattern C<//>, which is just one member of the set of patterns
matching a null string) will split the value of EXPR into separate
characters at each point it matches that way. For example:
The pattern C</PATTERN/> may be replaced with an expression to specify
patterns that vary at runtime. (To do runtime compilation only once,
-use C</$variable/o>.) As a special case, specifying a space S<(' ')> will
-split on white space just as split with no arguments does, but leading
-white space does I<NOT> produce a null first field. Thus, split(' ') can
-be used to emulate B<awk>'s default behavior, whereas C<split(/ /)> will
-give you as many null initial fields as there are leading spaces.
+use C</$variable/o>.)
+
+As a special case, specifying a PATTERN of space (C<' '>) will split on
+white space just as split with no arguments does. Thus, split(' ') can
+be used to emulate B<awk>'s default behavior, whereas C<split(/ /)>
+will give you as many null initial fields as there are leading spaces.
+A split on /\s+/ is like a split(' ') except that any leading
+whitespace produces a null first field. A split with no arguments
+really does a C<split(' ', $_)> internally.
Example:
open(passwd, '/etc/passwd');
while (<passwd>) {
- ($login, $passwd, $uid, $gid, $gcos, $home, $shell) = split(/:/);
+ ($login, $passwd, $uid, $gid, $gcos,
+ $home, $shell) = split(/:/);
...
}
Extracts a substring out of EXPR and returns it. First character is at
offset 0, or whatever you've set $[ to. If OFFSET is negative, starts
that far from the end of the string. If LEN is omitted, returns
-everything to the end of the string. You can use the substr() function
+everything to the end of the string. If LEN is negative, leaves that
+many characters off the end of the string.
+
+You can use the substr() function
as an lvalue, in which case EXPR must be an lvalue. If you assign
something shorter than LEN, the string will shrink, and if you assign
something longer than LEN, the string will grow to accommodate it. To
=item tie VARIABLE,PACKAGENAME,LIST
This function binds a variable to a package that will provide the
-implementation for the variable. VARIABLE is the name of the variable
-to be enchanted. PACKAGENAME is the name of a package implementing
-objects of correct type. Any additional arguments are passed to the
-"new" method of the package. Typically these are arguments such as
-might be passed to the dbm_open() function of C.
+implementation for the variable. VARIABLE is the name of the variable to
+be enchanted. PACKAGENAME is the name of a package implementing objects
+of correct type. Any additional arguments are passed to the "new" method
+of the package (meaning TIESCALAR, TIEARRAY, or TIEHASH). Typically these
+are arguments such as might be passed to the dbm_open() function of C.
Note that functions such as keys() and values() may return huge array
-values when used on large DBM files. You may prefer to use the each()
-function to iterate over large DBM files. Example:
+values when used on large objects, like DBM files. You may prefer to
+use the each() function to iterate over such. Example:
# print out history file offsets
tie(%HIST, NDBM_File, '/usr/lib/news/history', 1, 0);
gethostbyname($hostname);
($name, $aliases, $type, $len, $thataddr) = gethostbyname($them);
- $this = pack($sockaddr, &AF_INET, 0, $thisaddr);
- $that = pack($sockaddr, &AF_INET, $port, $thataddr);
+ $this = pack($sockaddr, AF_INET, 0, $thisaddr);
+ $that = pack($sockaddr, AF_INET, $port, $thataddr);
- socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!";
+ socket(S, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
bind(S, $this) || die "bind: $!";
connect(S, $that) || die "connect: $!";
($name, $aliases, $port) = getservbyname($port, 'tcp')
unless $port =~ /^\d+$/;
- $this = pack($sockaddr, &AF_INET, $port, "\0\0\0\0");
+ $this = pack($sockaddr, AF_INET, $port, "\0\0\0\0");
select(NS); $| = 1; select(stdout);
- socket(S, &PF_INET, &SOCK_STREAM, $proto) || die "socket: $!";
+ socket(S, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
bind(S, $this) || die "bind: $!";
listen(S, 5) || die "connect: $!";
=head2 Packages
-Perl provides a mechanism for alternate namespaces to protect packages
-from stomping on each others variables. By default, a Perl script starts
+Perl provides a mechanism for alternative namespaces to protect packages
+from stomping on each others variables. In fact, apart from certain magical
+variables, there's really no such thing as a global variable in Perl.
+By default, a Perl script starts
compiling into the package known as C<main>. You can switch namespaces
using the C<package> declaration. The scope of the package declaration is
from the declaration itself to the end of the enclosing block (the same
Only identifiers starting with letters (or underscore) are stored in a
package's symbol table. All other symbols are kept in package C<main>.
-In addition, the identifiers STDIN, STDOUT, STDERR, C<ARGV>,
+In addition, the identifiers STDIN, STDOUT, STDERR, ARGV,
ARGVOUT, ENV, INC and SIG are forced to be in package C<main>,
even when used for other purposes than their built-in one. Note also
that, if you have a package called C<m>, C<s> or C<y>, then you can't use
-the qualified form of an identifier since it will be interpreted instead
+the qualified form of an identifier because it will be interpreted instead
as a pattern match, a substitution, or a translation.
(Variables beginning with underscore used to be forced into package
Eval()ed strings are compiled in the package in which the eval() was
compiled. (Assignments to C<$SIG{}>, however, assume the signal
-handler specified is in the C<main. package. Qualify the signal handler
+handler specified is in the C<main> package. Qualify the signal handler
name if you wish to have a signal handler in a package.) For an
example, examine F<perldb.pl> in the Perl library. It initially switches
to the C<DB> package so that the debugger doesn't interfere with variables
*dick = *richard;
-causes variables, subroutines and filehandles accessible via the
+causes variables, subroutines and file handles accessible via the
identifier C<richard> to also be accessible via the symbol C<dick>. If
you only want to alias a particular variable or subroutine, you can
assign a reference instead:
interpreter is being exited, even if it is exiting as a result of a
die() function. (But not if it's is being blown out of the water by a
signal--you have to trap that yourself (if you can).) You may have
-multiple C<END> blocks within a file--they wil execute in reverse
+multiple C<END> blocks within a file--they will execute in reverse
order of definition; that is: last in, first out (LIFO).
Note that when you use the B<-n> and B<-p> switches to Perl, C<BEGIN>
A number of modules are included the the Perl distribution. These are
described below, and all end in F<.pm>. You may also discover files in
the library directory that end in either F<.pl> or F<.ph>. These are old
-libaries supplied so that old programs that use them still run. The
+libraries supplied so that old programs that use them still run. The
F<.pl> files will all eventually be converted into standard modules, and
the F<.ph> files made by B<h2ph> will probably end up as extension modules
made by B<h2xs>. (Some F<.ph> values may already be available through the
They work somewhat like pragmas in that they tend to affect the compilation of
your program, and thus will usually only work well when used within a
-C<use>, or C<no>. These are locally scoped, so if an inner BLOCK
+C<use>, or C<no>. These are locally scoped, so an inner BLOCK
may countermand any of these by saying
no integer;
=head2 Standard Modules
-The following modules are all expacted to behave in a well-defined
+The following modules are all expected to behave in a well-defined
manner with respect to namespace pollution because they use the
Exporter module.
See their own documentation for details.
=item C<Basename>
-parse file anme and path from a specification
+parse file name and path from a specification
=item C<Benchmark>
extension modules include the Socket, Fcntl, and POSIX modules.
The following are popular C extension modules, which while available at
-Perl 5.0 release time, do not come not bundled (at least, not completely)
+Perl 5.0 release time, do not come bundled (at least, not completely)
due to their size, volatility, or simply lack of time for adequate testing
and configuration across the multitude of platforms on which Perl was
beta-tested. You are encouraged to look for them in archie(1L), the Perl
-FAQ or Meta-FAQ, the WWW page, and even their authors before randomly
+FAQ or Meta-FAQ, the WWW page, and even with their authors before randomly
posting asking for their present condition and disposition. There's no
guarantee that the names or addresses below have not changed since printing,
and in fact, they probably have!
=item C<Sx>
This extension module is a front to the Athena and Xlib libraries for Perl
-GUI progamming, originally written by by Dominic Giampaolo
+GUI programming, originally written by by Dominic Giampaolo
<F<dbg@sgi.com>>, then and rewritten for Sx by FrE<eacute>dE<eacute>ric
Chauveau <F<fmc@pasteur.fr>>. It's available for FTP from
the reference is generally treated as an opaque value that may
only be accessed through the class's methods.
-A constructor may rebless a referenced object currently belonging to
+A constructor may re-bless a referenced object currently belonging to
another class, but then the new class is responsible for all cleanup
later. The previous blessing is forgotten, as an object may only
belong to one class at a time. (Although of course it's free to
$fred = Critter->MyCritter::find("Fred");
$fred->MyCritter::display('Height', 'Weight');
+Sometimes you want to call a method when you don't know the method name
+ahead of time. You can use the arrow form, replacing the method name
+with a simple scalar variable containing the method name:
+
+ $method = $fast ? "findfirst" : "findbest";
+ $fred->$method(@args);
+
=head2 Destructors
When the last reference to an object goes away, the object is
I<CONTAINED> in the current object will be freed and destroyed
automatically when the current object is freed.
+=head2 WARNING
+
+An indirect object is limited to a name, a scalar variable, or a block,
+because it would have to do too much lookahead otherwise, just like any
+other postfix dereference in the language. The left side of -> is not so
+limited, because it's an infix operator, not a postfix operator.
+
+That means that below, A and B are equivalent to each other, and C and D
+are equivalent, but AB and CD are different:
+
+ A: method $obref->{"fieldname"}
+ B: (method $obref)->{"fieldname"}
+ C: $obref->{"fieldname"}->method()
+ D: method {$obref->{"fieldname"}}
+
=head2 Summary
That's about all there is to it. Now you just need to go off and buy a
$a += 2;
$a *= 3;
-=head2
+=head2 Comma Operator
Binary "," is the comma operator. In a scalar context it evaluates
its left argument, throws that value away, then evaluates its right
In a list context, it's just the list argument separator, and inserts
both its arguments into the list.
+The => digraph is simply a synonym for the comma operator. It's useful
+for documenting arguments that come in pairs.
+
=head2 List Operators (Rightward)
On the right side of a list operator, it has very low precedence,
tr [\200-\377]
[\000-\177]; # delete 8th bit
+If multiple translations are given for a character, only the first one is used:
+
+ tr/AAA/XYZ/
+
+will translate any A to X.
+
Note that because the translation table is built at compile time, neither
the SEARCHLIST nor the REPLACEMENTLIST are subjected to double quote
interpolation. That means that if you want to use variables, you must use
The generalized form of backticks is C<qx//>.
Evaluating a filehandle in angle brackets yields the next line from
-that file (newline included, so it's never false until end of file, at which
-time an undefined value is returned). Ordinarily you must assign that
-value to a variable, but there is one situation where an automatic
+that file (newline included, so it's never false until end of file, at
+which time an undefined value is returned). Ordinarily you must assign
+that value to a variable, but there is one situation where an automatic
assignment happens. I<If and ONLY if> the input symbol is the only
thing inside the conditional of a C<while> loop, the value is
-automatically assigned to the variable C<$_>. (This may seem like an
-odd thing to you, but you'll use the construct in almost every Perl
-script you write.) Anyway, the following lines are equivalent to each
-other:
+automatically assigned to the variable C<$_>. The assigned value is
+then tested to see if it is defined. (This may seem like an odd thing
+to you, but you'll use the construct in almost every Perl script you
+write.) Anyway, the following lines are equivalent to each other:
- while ($_ = <STDIN>) { print; }
+ while (defined($_ = <STDIN>)) { print; }
while (<STDIN>) { print; }
for (;<STDIN>;) { print; }
- print while $_ = <STDIN>;
+ print while defined($_ = <STDIN>);
print while <STDIN>;
The filehandles STDIN, STDOUT and STDERR are predefined. (The
=item * I<Bit operations>
- "&", "^", "|", "neg", "!", "~",
+ "&", "^", "|", "&=", "^=", "|=", "neg", "!", "~",
"C<neg>" stands for unary minus. If the method for C<neg> is not
specified, it can be autogenerated using on the method for subtraction.
=head2 Copy Constructor
C<$OVERLOAD{"="}> is a reference to a function with three arguments,
-i.e., it looks like a usual value of %OVERLOAD. What is special about
-this subroutine is that it should not return a blessed reference into
-a package (as most other methods are expected to), but rather a freshly made
-copy of its dereferenced argument (see L<"BUGS">, though). This operation
+i.e., it looks like a usual value of %OVERLOAD. This operation
is called in the situations when a mutator is applied to a reference
that shares its object with some other reference, such as
=head1 WARNING
The restriction for the comparison operation is that even if, for example,
-`C<cmp>' should return a blessed reference, the autogenerated `C<lt>'
+`C<cmp>' should return a reference to a blessed object, the
+autogenerated `C<lt>'
function will produce only a standard logical value based on the
numerical value of the result of `C<cmp>'. In particular, a working
numeric conversion is needed in this case (possibly expressed in terms of
Because it's used for overloading, the per-package associative array
%OVERLOAD now has a special meaning in Perl.
-Although the copy constructor is specially designed to make overloading
-operations with references to an array simpler, as it now works it's
-useless for this because a subroutine cannot return an array in the same
-way as it returns a scalar (from the point of view of Perl
-internals). Expect a change of interface for the copy constructor.
-
As shipped, %OVERLOAD is not inherited via the @ISA tree. A patch for
this is available from the author.
the last alternative contains everything from the last "|" to the next
pattern delimiter. For this reason, it's common practice to include
alternatives in parentheses, to minimize confusion about where they
-start and end. Note also that the pattern C<(fee|fie|foe)> differs
-from the pattern C<[fee|fie|foe]> in that the former matches "fee",
-"fie", or "foe" in the target string, while the latter matches
-anything matched by the classes C<[fee]>, C<[fie]>, or C<[foe]> (i.e.
-the class C<[feio]>).
+start and end. Note however that "|" is interpreted as a literal with
+square brackets, so if you write C<[fee|fie|foe]> you're really only
+matching C<[feio|]>.
Within a pattern, you may designate subpatterns for later reference by
enclosing them in parentheses, and you may refer back to the I<n>th
Subpatterns are numbered based on the left to right order of their
opening parenthesis. Note that a backreference matches whatever
actually matched the subpattern in the string being examined, not the
-rules for that subpattern. Therefore, C<([0|0x])\d*\s\1\d*> will
+rules for that subpattern. Therefore, C<(0|0x)\d*\s\1\d*> will
match "0x1234 0x4321",but not "0x1234 01234", since subpattern 1
-actually matched "0x", even though the rule C<[0|0x]> could
+actually matched "0x", even though the rule C<0|0x> could
potentially match the leading 0 in the second number.
C<eval("...")>), C<$coderef> will still have a reference to the I<SAME>
anonymous subroutine.)
-For those who worry about these things, the current implementation
-uses shallow binding of local() variables; my() variables are not
-accessible. This precludes true closures. However, you can work
-around this with a run-time (rather than a compile-time) eval():
-
- {
- my $x = time;
- $coderef = eval "sub { \$x }";
+Anonymous subroutines act as closures with respect to my() variables,
+that is, variables visible lexically within the current scope. Closure
+is a notion out of the Lisp world that says if you define an anonymous
+function in a particular lexical context, it pretends to run in that
+context even when it's called outside of the context.
+
+In human terms, it's a funny way of passing arguments to a subroutine when
+you define it as well as when you call it. It's useful for setting up
+little bits of code to run later, such as callbacks. You can even
+do object-oriented stuff with it, though Perl provides a different
+mechanism to do that already--see L<perlobj>.
+
+You can also think of closure as a way to write a subroutine template without
+using eval. (In fact, in version 5.000, eval was the I<only> way to get
+closures. You may wish to use "require 5.001" if you use closures.)
+
+Here's a small example of how closures works:
+
+ sub newprint {
+ my $x = shift;
+ return sub { my $y = shift; print "$x, $y!\n"; };
}
+ $h = newprint("Howdy");
+ $g = newprint("Greetings");
+
+ # Time passes...
+
+ &$h("world");
+ &$g("earthlings");
-Normally--if you'd used just C<sub{}> or even C<eval{}>--your unew sub
-would only have been able to access the global $x. But because you've
-used a run-time eval(), this will not only generate a brand new subroutine
-reference each time called, it will all grant access to the my() variable
-lexically above it rather than the global one. The particular $x
-accessed will be different for each new sub you create. This mechanism
-yields deep binding of variables. (If you don't know what closures, deep
-binding, or shallow binding are, don't worry too much about it.)
+This prints
+
+ Howdy, world!
+ Greetings, earthlings!
+
+Note particularly that $x continues to refer to the value passed into
+newprint() *despite* the fact that the "my $x" has seemingly gone out of
+scope by the time the anonymous subroutine runs. That's what closure
+is all about.
+
+This only applies to lexical variables, by the way. Dynamic variables
+continue to work as they have always worked. Closure is not something
+that most Perl programmers need trouble themselves about to begin with.
=item 5.
References are often returned by special subroutines called constructors.
-Perl objects are just reference a special kind of object that happens to know
+Perl objects are just references to a special kind of object that happens to know
which package it's associated with. Constructors are just special
subroutines that know how to create that association. They do so by
starting with an ordinary reference, and it remains an ordinary reference
lines like that above can be written:
$arrayref->[0] = "January";
- $hashref->{"KEY} = "VALUE";
+ $hashref->{"KEY"} = "VALUE";
The left side of the array can be any expression returning a reference,
including a previous dereference. Note that C<$array[$x]> is I<NOT> the
This will still print 10, not 20. Remember that local() affects package
variables, which are all "global" to the package.
+=head2 Not-so-symbolic references
+
+A new feature contributing to readability in 5.001 is that the brackets
+around a symbolic reference behave more like quotes, just as they
+always have within a string. That is,
+
+ $push = "pop on ";
+ print "${push}over";
+
+has always meant to print "pop on over", despite the fact that push is
+a reserved word. This has been generalized to work the same outside
+of quotes, so that
+
+ print ${push} . "over";
+
+and even
+
+ print ${ push } . "over";
+
+will have the same effect. (This would have been a syntax error in
+5.000, though Perl 4 allowed it in the spaceless form.) Note that this
+construct is I<not> considered to be a symbolic reference when you're
+using strict refs:
+
+ use strict 'refs';
+ ${ bareword }; # Okay, means $bareword.
+ ${ "bareword" }; # Error, symbolic reference.
+
+Similarly, because of all the subscripting that is done using single
+words, we've applied the same rule to any bareword that is used for
+subscripting a hash. So now, instead of writing
+
+ $array{ "aaa" }{ "bbb" }{ "ccc" }
+
+you can just write
+
+ $array{ aaa }{ bbb }{ ccc }
+
+and not worry about whether the subscripts are reserved words. In the
+rare event that you do wish to do something like
+
+ $array{ shift }
+
+you can force interpretation as a reserved word by adding anything that
+makes it more than a bareword:
+
+ $array{ shift() }
+ $array{ +shift }
+ $array{ shift @_ }
+
+The B<-w> switch will warn you if it interprets a reserved word as a string.
+But it will no longer warn you about using lowercase words, since the
+string is effectively quoted.
+
+=head2 WARNING
+
+You may not (usefully) use a reference as the key to a hash. It will be
+converted into a string:
+
+ $x{ \$a } = $a;
+
+If you try to dereference the key, it won't do a hard dereference, and
+you won't accomplish what you're attemping.
+
=head2 Further Reading
Besides the obvious documents, source code can be instructive.
=item B<-c>
causes Perl to check the syntax of the script and then exit without
-executing it.
+executing it. Actually, it will execute C<BEGIN> and C<use> blocks,
+since these are considered part of the compilation.
=item B<-d>
redefined subroutines, and references to undefined filehandles or
filehandles opened readonly that you are attempting to write on. Also
warns you if you use values as a number that doesn't look like numbers, using
-a an array as though it were a scalar, if
-your subroutines recurse more than 100 deep, and innumeriable other things.
+an array as though it were a scalar, if
+your subroutines recurse more than 100 deep, and innumerable other things.
See L<perldiag> and L<perltrap>.
=item B<-x> I<directory>
for untainting user supplied filenames if you want to do file operations
on them (unless you make C<$E<gt>> equal to C<$E<lt>> ).
-For "Insecure PATH" messages, you need to set C<$ENV{'PATH}'> to a known
+For "Insecure $ENV{PATH}" messages, you need to set C<$ENV{'PATH'}> to a known
value, and each directory in the path must be non-writable by the world.
A frequently voiced gripe is that you can get this message even
if the pathname to an executable is fully qualified. But Perl can't
sub NAME; # A "forward" declaration.
sub NAME BLOCK # A declaration and a definition.
+To define an anonymous subroutine at runtime:
+
+ $subref = sub BLOCK;
+
To import subroutines:
use PACKAGE qw(NAME1 NAME2 NAME3);
($_[0], $_[1], ...). The array @_ is a local array, but its values are
references to the actual scalar parameters. The return value of the
subroutine is the value of the last expression evaluated, and can be
-either an array value or a scalar value. Alternately, a return
+either an array value or a scalar value. Alternatively, a return
statement may be used to specify the returned value and exit the
subroutine. To create local variables see the local() and my()
operators.
-A subroutine may called using the "&" prefix. The "&" is optional in Perl
+A subroutine may be called using the "&" prefix. The "&" is optional in Perl
5, and so are the parens if the subroutine has been predeclared.
(Note, however, that the "&" is I<NOT> optional when you're just naming the
subroutine, such as when it's used as an argument to defined() or
&foo(); # the same
&foo; # pass no arguments--more efficient
+If a module wants to create a private subroutine that cannot be called
+from outside the module, it can declare a lexical variable containing
+an anonymous sub reference:
+
+ my $subref = sub { ... }
+ &$subref(1,2,3);
+
+As long as the reference is never returned by any function within the module,
+no outside module can see the subroutine, since its name is not in any
+package's symbol table.
+
=head2 Passing Symbol Table Entries
[Note: The mechanism described in this section works fine in Perl 5, but
side effects. Every simple statement must be terminated with a
semicolon, unless it is the final statement in a block, in which case
the semicolon is optional. (A semicolon is still encouraged there if the
-block takes up more than one line, since you may add another line.)
+block takes up more than one line, since you may eventually add another line.)
Note that there are some operators like C<eval {}> and C<do {}> that look
like compound statements, but aren't (they're just TERMs in an expression),
and thus need an explicit termination
LABEL while (EXPR) BLOCK
LABEL while (EXPR) BLOCK continue BLOCK
LABEL for (EXPR; EXPR; EXPR) BLOCK
- LABEL foreach VAR (ARRAY) BLOCK
+ LABEL foreach VAR (LIST) BLOCK
LABEL BLOCK continue BLOCK
Note that, unlike C and Pascal, these are defined in terms of BLOCKs,
The foreach loop iterates over a normal list value and sets the
variable VAR to be each element of the list in turn. The variable is
-implicitly local to the loop (unless declared previously with C<my>),
-and regains its former value upon exiting the loop. The C<foreach>
-keyword is actually a synonym for the C<for> keyword, so you can use
-C<foreach> for readability or C<for> for brevity. If VAR is omitted, $_
-is set to each value. If ARRAY is an actual array (as opposed to an
-expression returning a list value), you can modify each element of the
-array by modifying VAR inside the loop. Examples:
+implicitly local to the loop and regains its former value upon exiting
+the loop. (If the variable was previously declared with C<my>, it uses
+that variable instead of the global one, but it's still localized to
+the loop.) The C<foreach> keyword is actually a synonym for the C<for>
+keyword, so you can use C<foreach> for readability or C<for> for
+brevity. If VAR is omitted, $_ is set to each value. If LIST is an
+actual array (as opposed to an expression returning a list value), you
+can modify each element of the array by modifying VAR inside the loop.
+Examples:
for (@ary) { s/foo/bar/; }
=item *
-People have a hard type remembering that some functions
+People have a hard time remembering that some functions
default to $_, or @ARGV, or whatever, but that others which
you might expect to do not.
=item *
+The <FH> construct is not the name of the filehandle, it is a readline
+operation on that handle. The data read is only assigned to $_ if the
+file read is the sole condition in a while loop:
+
+ while (<FH>) { }
+ while ($_ = <FH>) { }..
+ <FH>; # data discarded!
+
+=item *
+
Remember not to use "C<=>" when you need "C<=~>";
these two constructs are quite different:
may now need to use backslash to protect any C<@> that shouldn't interpolate.
=item *
+
Barewords that used to look like strings to Perl will now look like subroutine
calls if a subroutine by that name is defined before the compiler sees them.
For example:
sub SeeYa { die "Hasta la vista, baby!" }
- $SIG{QUIT} = SeeYa;
+ $SIG{'QUIT'} = SeeYa;
In Perl 4, that set the signal handler; in Perl 5, it actually calls the
function! You may use the B<-w> switch to find such places.
=item *
+The construct "this is $$x" used to interpolate the pid at that
+point, but now tries to dereference $x. C<$$> by itself still
+works fine, however.
+
+=item *
+
Some error messages will be different.
=item *
most of the methods do nothing to the current value, except for
autoflush(), which will assume a 1 for you, just to be different.
-A few of these variables are considered "read-only". This means that if you
-try to assign to this variable, either directly or indirectly through
-a reference. If you attempt to do so, you'll raise a run-time exception.
+A few of these variables are considered "read-only". This means that if
+you try to assign to this variable, either directly or indirectly through
+a reference, you'll raise a run-time exception.
=over 8
invoked may have failed in the normal fashion). (Mnemonic: Where was
the syntax error "at"?)
+Note that warning messages are not collected in this variable. You can,
+however, set up a routine to process warnings by setting $SIG{__WARN__} below.
+
=item $PROCESS_ID
=item $PID
The one marked scary is problematic because it's a bareword, which means
sometimes it's a string representing the function, and sometimes it's
going to call the subroutine call right then and there! Best to be sure
-and quote it or take a reference to it. *Plumber works too. See <perlsubs>.
+and quote it or take a reference to it. *Plumber works too. See L<perlsubs>.
+
+Certain internal hooks can be also set using the %SIG hash. The
+routine indicated by $SIG{__WARN__} is called when a warning message is
+about to be printed. The warning message is passed as the first
+argument. The presence of a __WARN__ hook causes the ordinary printing
+of warnings to STDERR to be suppressed. You can use this to save warnings
+in a variable, or turn warnings into fatal errors, like this:
+
+ local $SIG{__WARN__} = sub { die $_[0] };
+ eval $proggie;
+
+The routine indicated by $SIG{__DIE__} is called when a fatal exception
+is about to be thrown. The error message is passed as the first
+argument. When a __DIE__ hook routine returns, the exception
+processing continues as it would have in the absence of the hook,
+unless the hook routine itself exits via a goto, a loop exit, or a die.
=back
-#!../perl
+#!/usr/bin/perl
+#
+# pod2html - convert pod format to html
+#
+# usage: pod2html [podfiles]
+# will read the cwd and parse all files with .pod extension
+# if no arguments are given on the command line.
+#
+*RS = */;
+*ERRNO = *!;
+
+use Carp;
+
+$gensym = 0;
+
+while ($ARGV[0] =~ /^-d(.*)/) {
+ shift;
+ $Debug{ lc($1 || shift) }++;
+}
+
+# look in these pods for things not found within the current pod
+@inclusions = qw[
+ perlfunc perlvar perlrun perlop
+];
+
+# ck for podnames on command line
+while ($ARGV[0]) {
+ push(@Pods,shift);
+}
+$A={};
+
+# location of pods
+$dir=".";
# The beginning of the url for the anchors to the other sections.
-chop($wd=`pwd`);
-$type="<A HREF=\"file://localhost".$wd."/";
-$debug=0;
-$/ = "";
-$p=\%p;
-@exclusions=("perldebug","perlform","perlobj","perlstyle","perltrap","perlmod");
-$indent=0;
-opendir(DIR,".");
-@{$p->{"pods"}}=grep(/\.pod$/,readdir(DIR));
-closedir(DIR);
-
-# learn the important stuff
-
-foreach $tmpod (@{$p->{"pods"}}){
- ($pod=$tmpod)=~s/\.pod$//;
- $p->{"podnames"}->{$pod}=1;
- next if grep(/$pod/,@exclusions);
- open(POD,"<$tmpod");
- while(<POD>){
- s/B<([^<>]*)>/$1/g; # bold
- s/I<([^<>]*)>/$1/g; # bold
- if (s/^=//) {
- s/\n$//s;
- s/\n/ /g;
- ($cmd, $_) = split(' ', $_, 2);
- if ($cmd eq "item") {
- ($what,$rest)=split(' ', $_, 2);
- $what=~s#(-.).*#$1#;
- $what=~s/\s*$//;
- next if defined $p->{"items"}->{$what};
- $p->{"items"}->{$what} = $pod."_".$i++;
- }
- elsif($cmd =~ /^head/){
- $_=~s/\s*$//;
- next if defined($p->{"headers"}->{$_});
- $p->{"headers"}->{$_} = $pod."_".$i++;
- }
- }
- }
+# Edit $type to suit. It's configured for relative url's now.
+$type='<A HREF="';
+$debug = 0;
+
+unless(@Pods){
+ opendir(DIR,$dir) or die "Can't opendir $dir: $ERRNO";
+ @Pods = grep(/\.pod$/,readdir(DIR));
+ closedir(DIR) or die "Can't closedir $dir: $ERRNO";
}
+@Pods or die "expected pods";
-$/="";
-
-# parse the pods, produce html
-foreach $tmpod (@{$p->{"pods"}}){
- open(POD,"<$tmpod") || die "cant open $pod";
- ($pod=$tmpod)=~s/\.pod$//;
- open(HTML,">$pod.html");
- print HTML "<!-- \$RCSfile\$\$Revision\$\$Date\$ -->\n";
- print HTML "<!-- \$Log\$ -->\n";
- print HTML "<HTML>\n";
- print HTML "<TITLE> \U$pod\E </TITLE>\n";
- $cutting = 1;
- while (<POD>) {
- if ($cutting) {
- next unless /^=/;
- $cutting = 0;
+# loop twice through the pods, first to learn the links, then to produce html
+for $count (0,1){
+ foreach $podfh ( @Pods ) {
+ ($pod = $podfh) =~ s/\.pod$//;
+ Debug("files", "opening 2 $podfh" );
+ $RS = "\n=";
+ open($podfh,"<".$podfh) || die "can't open $podfh: $ERRNO";
+ @all=<$podfh>;
+ close($podfh);
+ $RS = "\n";
+ $all[0]=~s/^=//;
+ for(@all){s/=$//;}
+ $Podnames{$pod} = 1;
+ $in_list=0;
+ $html=$pod.".html";
+ if($count){
+ #open(HTML,">&STDOUT") || die "can't create $html: $ERRNO";
+ open(HTML,">$html") || die "can't create $html: $ERRNO";
+ print HTML <<'HTML__EOQ', <<"HTML__EOQQ";
+ <!-- $RCSfile$$Date$ -->
+ <!-- $Log$ -->
+ <HTML>
+HTML__EOQ
+ <TITLE> \U$pod\E </TITLE>
+HTML__EOQQ
}
- chop;
- length || (print "\n") && next;
- # Translate verabatim paragraph
-
- if (/^\s/) {
- $unordered=0;
- &pre_escapes;
- &post_escapes;
- @lines = split(/\n/);
- if($lines[0]=~/^\s+(\w*)\t(.*)/){ # listing or unordered list
- ($key,$rest)=($1,$2);
- if(defined($p->{"podnames"}->{$key})){
- print HTML "\n<ul>\n";
- $unordered = 1;
+
+ for($i=0;$i<=$#all;$i++){
+
+ $all[$i] =~ /^(\w+)\s*(.*)\n?([^\0]*)$/ ;
+ ($cmd, $title, $rest) = ($1,$2,$3);
+ if ($cmd eq "item") {
+ if($count ){
+ ($depth) or &do_list("over",$all[$i],\$in_list,\$depth);
+ &do_item($title,$rest,$in_list);
}
else{
- print HTML "\n<listing>\n";
+ # scan item
+ &scan_thing("item",$title,$pod);
}
- foreach $line (@lines){
- ($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rest)=($1,$2));
- print HTML defined($p->{"podnames"}->{$key}) ?
- "<li>$type$key.html\">$key<\/A>\t$rest\n" : "$line \n";
- }
- print HTML $unordered ? "</ul>\n" : "</listing>\n";
- next;
- }else{ # preformatted text
- print HTML "<pre>\n";
- for(@lines){
- s/^/ /;
- s/\t/ /g;
- print HTML $_,"\n";
- }
- print HTML "</pre>\n";
- next;
- }
- }
- &pre_escapes;
- s/S<([^<>]*)>/$1/g; # embedded special
- $_ = &Do_refs($_,$pod);
- s/Z<>/<p>/g; # ?
- s/E<([^<>]*)>/\&$1\;/g; # embedded special
- &post_escapes;
- if (s/^=//) {
- s/\n$//s;
- s/\n/ /g;
- ($cmd, $_) = split(' ', $_, 2);
- if ($cmd eq 'cut') {
- $cutting = 1;
- }
- elsif ($cmd eq 'head1') {
- print HTML qq{<h2>$_</h2>\n};
- }
- elsif ($cmd eq 'head2') {
- print HTML qq{<h3>$_</h3>\n};
}
- elsif ($cmd eq 'over') {
- push(@indent,$indent);
- $indent = $_ + 0;
- print HTML qq{\n<dl>\n};
+ elsif ($cmd =~ /^head([12])/){
+ $num=$1;
+ if($count){
+ &do_hdr($num,$title,$rest,$depth);
+ }
+ else{
+ # header scan
+ &scan_thing($cmd,$title,$pod); # skip head1
+ }
}
- elsif ($cmd eq 'back') {
- $indent = pop(@indent);
- warn "Unmatched =back\n" unless defined $indent;
- $needspace = 1;
- print HTML qq{\n</dl>\n\n};
+ elsif ($cmd =~ /^over/) {
+ $depth and &do_list("over",$all[$i+1],\$in_list,\$depth);
}
- elsif ($cmd eq 'item') {
- ($what,$rest)=split(' ', $_, 2);
- $what=~s/\s*$//;
- if($justdid ne $what){
- print HTML "\n<A NAME=\"".$p->{"items"}->{$what}."\"></A>\n";
- $justdid=$what;
+ elsif ($cmd =~ /^back/) {
+ if($count){
+ ($depth) or next; # just skip it
+ &do_list("back",$all[$i+1],\$in_list,\$depth);
+ &do_rest("$title.$rest");
}
- print HTML qq{<dt><B>$_</B> </dt>\n};
- $next_para=1;
+ }
+ elsif ($cmd =~ /^cut/) {
+ &do_rest($rest);
}
else {
- warn "Unrecognized directive: $cmd\n";
+ warn "unrecognized header: $cmd";
}
}
- else {
- length || next;
- $next_para && (print HTML qq{<dd>\n});
- print HTML "$_<p>";
- $next_para && (print HTML qq{</dd>\n<p>\n}) && ($next_para=0);
+ if($count){
+ while($depth){
+ &do_list("back",$all[$i+1],\$in_list,\$depth);
+ }
+ print HTML "\n</HTML>\n";
}
}
}
-print HTML "\n</HTML>\n";
-#########################################################################
-
-sub pre_escapes {
- s/\&/\&\;/g;
- s/<</\<\;\<\;/g;
- s/([^ESIBLCF])</$1\<\;/g;
+sub do_list{
+ my($which,$next_one,$list_type,$depth)=@_;
+ my($key);
+ if($which eq "over"){
+ ($next_one =~ /^item\s+(.*)/ ) or warn "Bad list, $1\n";
+ $key=$1;
+ if($key =~ /^1\.?/){
+ $$list_type = "OL";
+ }
+ elsif($key =~ /\*\s*$/){
+ $$list_type="UL";
+ }
+ elsif($key =~ /\*?\s*\w/){
+ $$list_type="DL";
+ }
+ else{
+ warn "unknown list type for item $key";
+ }
+ print HTML qq{\n};
+ print HTML qq{<$$list_type>};
+ $$depth++;
+ }
+ elsif($which eq "back"){
+ print HTML qq{\n</$$list_type>\n};
+ $$depth--;
+ }
}
-sub post_escapes{
- s/>>/\>\;\>\;/g;
- s/([^"AIB])>/$1\>\;/g;
+sub do_hdr{
+ my($num,$title,$rest,$depth)=@_;
+ ($num == 1) and print HTML qq{<p><hr>\n};
+ &process_thing(\$title,"NAME");
+ print HTML qq{\n<H$num> };
+ print HTML $title;
+ print HTML qq{</H$num>\n};
+ &do_rest($rest);
}
-sub Do_refs{
-local($para,$pod)=@_;
-foreach $char ("L","C","I","B"){
- next unless /($char<[^<>]*>)/;
- local(@ar) = split(/($char<[^<>]*>)/,$para);
- local($this,$key,$num);
- for($this=0;$this<=$#ar;$this++){
- next unless $ar[$this] =~ /${char}<([^<>]*)>/;
- $key=$1;
+sub do_item{
+ my($title,$rest,$list_type)=@_;
+ &process_thing(\$title,"NAME");
+ if($list_type eq "DL"){
+ print HTML qq{\n<DT><STRONG>\n};
+ print HTML $title;
+ print HTML qq{\n</STRONG></DT>\n};
+ print HTML qq{<DD>\n};
+ }
+ else{
+ print HTML qq{\n<LI>};
+ ($list_type ne "OL") && (print HTML $title,"\n");
+ }
+ &do_rest($rest);
+ print HTML ($list_type eq "DL" )? qq{</DD>} : qq{</LI>};
+}
- if((defined($p->{"podnames"}->{$key})) && ($char eq "L")){
- $ar[$this] = "\n$type$key.html\">\nthe $key manpage<\/A>\n"; #
+sub do_rest{
+ my($rest)=@_;
+ my(@lines,$p,$q,$line,@paras,$inpre);
+ @paras=split(/\n\n+/,$rest);
+ for($p=0;$p<=$#paras;$p++){
+ @lines=split(/\n/,$paras[$p]);
+ if($lines[0] =~ /^\s+\w*\t.*/){ # listing or unordered list
+ print HTML qq{<UL>};
+ foreach $line (@lines){
+ ($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rem) = ($1,$2));
+ print HTML defined($Podnames{$key}) ?
+ "<LI>$type$key.html\">$key<\/A>\t$rem</LI>\n" :
+ "<LI>$line</LI>\n";
+ }
+ print HTML qq{</UL>\n};
}
- elsif(defined($p->{"items"}->{$key})){
- ($pod2,$num)=split(/_/,$p->{"items"}->{$key},2);
- $ar[$this] = (($pod2 eq $pod) && ($para=~/^\=item/)) ?
- "\n<A NAME=\"".$p->{"items"}->{$key}."\">\n$key</A>\n"
- :
- "\n$type$pod2.html\#".$p->{"items"}->{$key}."\">$key<\/A>\n";
- }
- elsif(defined($p->{"headers"}->{$key})){
- ($pod2,$num)=split(/_/,$p->{"headers"}->{$key},2);
- $ar[$this] = (($pod eq $pod2) && ($para=~/^\=head/)) ?
- "\n<A NAME=\"".$p->{"headers"}->{$key}."\">\n$key</A>\n"
- :
- "\n$type$pod2.html\#".$p->{"headers"}->{$key}."\">$key<\/A>\n";
+ elsif($lines[0] =~ /^\s/){ # preformatted code
+ if($paras[$p] =~/>>|<</){
+ print HTML qq{\n<PRE>\n};
+ $inpre=1;
+ }
+ else{
+ print HTML qq{\n<XMP>\n};
+ $inpre=0;
+ }
+inner:
+ while(defined($paras[$p])){
+ @lines=split(/\n/,$paras[$p]);
+ foreach $q (@lines){
+ if($paras[$p]=~/>>|<</){
+ if($inpre){
+ &process_thing(\$q,"HTML");
+ }
+ else {
+ print HTML qq{\n</XMP>\n};
+ print HTML qq{<PRE>\n};
+ $inpre=1;
+ &process_thing(\$q,"HTML");
+ }
+ }
+ while($q =~ s/\t+/' 'x (length($&) * 8 - length($`) % 8)/e){
+ 1;
+ }
+ print HTML $q,"\n";
+ }
+ last if $paras[$p+1] !~ /^\s/;
+ $p++;
+ }
+ print HTML ($inpre==1) ? (qq{\n</PRE>\n}) : (qq{\n</XMP>\n});
}
- else{
- (warn "No \"=item\" or \"=head\" reference for $ar[$this] in $pod\n") if $debug;
- if($char =~ /^[BCF]$/){
- $ar[$this]="<B>$key</B>";
+ else{ # other text
+ @lines=split(/\n/,$paras[$p]);
+ foreach $line (@lines){
+ &process_thing(\$line,"HTML");
+ print HTML qq{$line\n};
}
- elsif($char eq "L"){
- $ar[$this]=$key;
+ }
+ print HTML qq{<p>};
+ }
+}
+
+sub process_thing{
+ my($thing,$htype)=@_;
+ &pre_escapes($thing);
+ &find_refs($thing,$htype);
+ &post_escapes($thing);
+}
+
+sub scan_thing{
+ my($cmd,$title,$pod)=@_;
+ $_=$title;
+ s/\n$//;
+ s/E<(.*?)>/&$1;/g;
+ # remove any formatting information for the headers
+ s/[SFCBI]<(.*?)>/$1/g;
+ # the "don't format me" thing
+ s/Z<>//g;
+ if ($cmd eq "item") {
+
+ if (/^\*/) { return } # skip bullets
+ if (/^\d+\./) { return } # skip numbers
+ s/(-[a-z]).*/$1/i;
+ trim($_);
+ return if defined $A->{$pod}->{"Items"}->{$_};
+ $A->{$pod}->{"Items"}->{$_} = gensym($pod, $_);
+ $A->{$pod}->{"Items"}->{(split(' ',$_))[0]}=$A->{$pod}->{"Items"}->{$_};
+ Debug("items", "item $_");
+ if (!/^-\w$/ && /([%\$\@\w]+)/ && $1 ne $_
+ && !defined($A->{$pod}->{"Items"}->{$_}) && ($_ ne $1))
+ {
+ $A->{$pod}->{"Items"}->{$1} = $A->{$pod}->{"Items"}->{$_};
+ Debug("items", "item $1 REF TO $_");
+ }
+ if ( m{^(tr|y|s|m|q[qwx])/.*[^/]} ) {
+ my $pf = $1 . '//';
+ $pf .= "/" if $1 eq "tr" || $1 eq "y" || $1 eq "s";
+ if ($pf ne $_) {
+ $A->{$pod}->{"Items"}->{$pf} = $A->{$pod}->{"Items"}->{$_};
+ Debug("items", "item $pf REF TO $_");
+ }
+ }
+ }
+ elsif ($cmd =~ /^head[12]/){
+ return if defined($Headers{$_});
+ $A->{$pod}->{"Headers"}->{$_} = gensym($pod, $_);
+ Debug("headers", "header $_");
+ }
+ else {
+ warn "unrecognized header: $cmd";
+ }
+}
+
+
+sub picrefs {
+ my($char, $bigkey, $lilkey,$htype) = @_;
+ my($key,$ref,$podname);
+ for $podname ($pod,@inclusions){
+ for $ref ( "Items", "Headers" ) {
+ if (defined $A->{$podname}->{$ref}->{$bigkey}) {
+ $value = $A->{$podname}->{$ref}->{$key=$bigkey};
+ Debug("subs", "bigkey is $bigkey, value is $value\n");
+ }
+ elsif (defined $A->{$podname}->{$ref}->{$lilkey}) {
+ $value = $A->{$podname}->{$ref}->{$key=$lilkey};
+ return "" if $lilkey eq '';
+ Debug("subs", "lilkey is $lilkey, value is $value\n");
+ }
+ }
+ if (length($key)) {
+ ($pod2,$num) = split(/_/,$value,2);
+ if($htype eq "NAME"){
+ return "\n<A NAME=\"".$value."\">\n$bigkey</A>\n"
}
- elsif($char eq "I"){
- $ar[$this]="<I>$key</I>";
+ else{
+ return "\n$type$pod2.html\#".$value."\">$bigkey<\/A>\n";
}
+ }
+ }
+ if ($char =~ /[IF]/) {
+ return "<EM> $bigkey </EM>";
+ } else {
+ return "<STRONG> $bigkey </STRONG>";
+ }
+}
+
+sub find_refs {
+ my($thing,$htype)=@_;
+ my($orig) = $$thing;
+ # LREF: a manpage(3f) we don't know about
+ $$thing=~s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))>:the I<$1>$2 manpage:g;
+ $$thing=~s/L<([^>]*)>/lrefs($1,$htype)/ge;
+ $$thing=~s/([CIBF])<(\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge;
+ $$thing=~s/((\w+)\(\))/picrefs("I", $1, $2,$htype)/ge;
+ $$thing=~s/([\$\@%]([\w:]+|\W\b))/varrefs($1,$htype)/ge;
+ (($$thing eq $orig) && ($htype eq "NAME")) &&
+ ($$thing=picrefs("I", $$thing, "", $htype));
+}
+
+sub lrefs {
+ my($page, $item) = split(m#/#, $_[0], 2);
+ my($htype)=$_[1];
+ my($podname);
+ my($section) = $page =~ /\((.*)\)/;
+ my $selfref;
+ if ($page =~ /^[A-Z]/ && $item) {
+ $selfref++;
+ $item = "$page/$item";
+ $page = $pod;
+ } elsif (!$item && $page =~ /[^a-z\-]/ && $page !~ /^\$.$/) {
+ $selfref++;
+ $item = $page;
+ $page = $pod;
+ }
+ $item =~ s/\(\)$//;
+ if (!$item) {
+ if (!defined $section && defined $Podnames{$page}) {
+ return "\n$type$page.html\">\nthe <EM> $page </EM> manpage<\/A>\n";
+ } else {
+ warn "Bizarre entry $page/$item";
+ return "the <EM> $_[0] </EM> manpage\n";
+ }
+ }
+
+ if ($item =~ s/"(.*)"/$1/ || ($item =~ /[^\w\/\-]/ && $item !~ /^\$.$/)) {
+ $text = "<EM> $item </EM>";
+ $ref = "Headers";
+ } else {
+ $text = "<EM> $item </EM>";
+ $ref = "Items";
+ }
+ for $podname ($pod, @inclusions){
+ undef $value;
+ if ($ref eq "Items") {
+ if (defined($value = $A->{$podname}->{$ref}->{$item})) {
+ ($pod2,$num) = split(/_/,$value,2);
+ return (($pod eq $pod2) && ($htype eq "NAME"))
+ ? "\n<A NAME=\"".$value."\">\n$text</A>\n"
+ : "\n$type$pod2.html\#".$value."\">$text<\/A>\n";
+ }
+ }
+ elsif($ref eq "Headers") {
+ if (defined($value = $A->{$podname}->{$ref}->{$item})) {
+ ($pod2,$num) = split(/_/,$value,2);
+ return (($pod eq $pod2) && ($htype eq "NAME"))
+ ? "\n<A NAME=\"".$value."\">\n$text</A>\n"
+ : "\n$type$pod2.html\#".$value."\">$text<\/A>\n";
+ }
+ }
+ }
+ warn "No $ref reference for $item (@_)";
+ return $text;
+}
+
+sub varrefs {
+ my ($var,$htype) = @_;
+ for $podname ($pod,@inclusions){
+ if ($value = $A->{$podname}->{"Items"}->{$var}) {
+ ($pod2,$num) = split(/_/,$value,2);
+ Debug("vars", "way cool -- var ref on $var");
+ return (($pod eq $pod2) && ($htype eq "NAME")) # INHERIT $_, $pod
+ ? "\n<A NAME=\"".$value."\">\n$var</A>\n"
+ : "\n$type$pod2.html\#".$value."\">$var<\/A>\n";
}
}
- $para=join('',@ar);
+ Debug( "vars", "bummer, $var not a var");
+ return "<STRONG> $var </STRONG>";
+}
+
+sub gensym {
+ my ($podname, $key) = @_;
+ $key =~ s/\s.*//;
+ ($key = lc($key)) =~ tr/a-z/_/cs;
+ my $name = "${podname}_${key}_0";
+ $name =~ s/__/_/g;
+ while ($sawsym{$name}++) {
+ $name =~ s/_?(\d+)$/'_' . ($1 + 1)/e;
+ }
+ return $name;
+}
+
+sub pre_escapes {
+ my($thing)=@_;
+ $$thing=~s/&/noremap("&")/ge;
+ $$thing=~s/<</noremap("<<")/eg;
+ $$thing=~s/(?:[^ESIBLCF])</noremap("<")/eg;
+ $$thing=~s/E<([^\/][^<>]*)>/\&$1\;/g; # embedded special
}
-$para;
+
+sub noremap {
+ my $hide = $_[0];
+ $hide =~ tr/\000-\177/\200-\377/;
+ $hide;
+}
+
+sub post_escapes {
+ my($thing)=@_;
+ $$thing=~s/[^GM]>>/\>\;\>\;/g;
+ $$thing=~s/([^"MGA])>/$1\>\;/g;
+ $$thing=~tr/\200-\377/\000-\177/;
}
-sub wait{1;}
+
+sub Debug {
+ my $level = shift;
+ print STDERR @_,"\n" if $Debug{$level};
+}
+
+sub dumptable {
+ my $t = shift;
+ print STDERR "TABLE DUMP $t\n";
+ foreach $k (sort keys %$t) {
+ printf STDERR "%-20s <%s>\n", $t->{$k}, $k;
+ }
+}
+sub trim {
+ for (@_) {
+ s/^\s+//;
+ s/\s\n?$//;
+ }
+}
+
+
--- /dev/null
+#!/usr/bin/perl
+# pod2latex, version 1.1
+# by Taro Kawagish (kawagish@imslab.co.jp), Jan 11, 1995.
+#
+# pod2latex filters Perl pod documents to LaTeX documents.
+#
+# What pod2latex does:
+# 1. Pod file 'perl_doc_entry.pod' is filtered to 'perl_doc_entry.tex'.
+# 2. Indented paragraphs are translated into
+# '\begin{verbatim} ... \end{verbatim}'.
+# 3. '=head1 heading' command is translated into '\section{heading}'
+# 4. '=head2 heading' command is translated into '\subsection*{heading}'
+# 5. '=over N' command is translated into
+# '\begin{itemize}' if following =item starts with *,
+# '\begin{enumerate}' if following =item starts with 1.,
+# '\begin{description}' if else.
+# (indentation level N is ignored.)
+# 6. '=item * heading' command is translated into '\item heading',
+# '=item 1. heading' command is translated into '\item heading',
+# '=item heading' command(other) is translated into '\item[heading]'.
+# 7. '=back' command is translated into
+# '\end{itemize}' if started with '\begin{itemize}',
+# '\end{enumerate}' if started with '\begin{enumerate}',
+# '\end{description}' if started with '\begin{description}'.
+# 8. other paragraphs are translated into strings with TeX special characters
+# escaped.
+# 9. In heading text, and other paragraphs, the following translation of pod
+# quotes are done, and then TeX special characters are escaped after that.
+# I<text> to {\em text\/},
+# B<text> to {\bf text},
+# S<text> to text1,
+# where text1 is a string with blank characters replaced with ~,
+# C<text> to {\tt text2},
+# where text2 is a string with TeX special characters escaped to
+# obtain a literal printout,
+# E<text> (HTML escape) to TeX escaped string,
+# L<text> to referencing string as is done by pod2man,
+# F<file> to {\em file\/},
+# Z<> to a null string,
+# 10. those headings are indexed:
+# '=head1 heading' => \section{heading}\index{heading}
+# '=head2 heading' => \subsection*{heading}\index{heading}
+# only when heading does not match frequent patterns such as
+# DESCRIPTION, DIAGNOSTICS,...
+# '=item heading' => \item{heading}\index{heading}
+#
+# Usage:
+# pod2latex perl_doc_entry.pod
+# this will write to a file 'perl_doc_entry.tex'.
+#
+# To LaTeX:
+# The following commands need to be defined in the preamble of the LaTeX
+# document:
+# \def\C++{{\rm C\kern-.05em\raise.3ex\hbox{\footnotesize ++}}}
+# \def\underscore{\leavevmode\kern.04em\vbox{\hrule width 0.4em height 0.3pt}}
+# and \parindent should be set zero:
+# \setlength{\parindent}{0pt}
+#
+# Note:
+# This script was written modifing pod2man.
+#
+# Bug:
+# If HTML escapes E<text> other than E<amp>,E<lt>,E<gt>,E<quot> are used
+# in C<>, translation will produce wrong character strings.
+# Translation of HTML escapes of various European accents might be wrong.
+
+
+$/ = ""; # record separator is blank lines
+# TeX special characters.
+##$tt_ables = "!@*()-=+|;:'\"`,./?<>";
+$backslash_escapables = "#\$%&{}_";
+$backslash_escapables2 = "#\$%&{}"; # except _
+##$nonverbables = "^\\~";
+##$bracketesc = "[]";
+##@tex_verb_fences = unpack("aaaaaaaaa","|#@!*+?:;");
+
+@head1_freq_patterns # =head1 patterns which need not be index'ed
+ = ("AUTHOR","Author","BUGS","DATE","DESCRIPTION","DIAGNOSTICS",
+ "ENVIRONMENT","EXAMPLES","FILES","INTRODUCTION","NAME","NOTE",
+ "SEE ALSO","SYNOPSIS","WARNING");
+
+$indent = 0;
+
+# parse the pods, produce LaTeX.
+
+open(POD,"<$ARGV[0]") || die "cant open $ARGV[0]";
+($pod=$ARGV[0]) =~ s/\.pod$//;
+open(LATEX,">$pod.tex");
+&do_hdr();
+
+$cutting = 1;
+while (<POD>) {
+ if ($cutting) {
+ next unless /^=/;
+ $cutting = 0;
+ }
+ chop;
+ length || (print LATEX "\n") && next;
+
+ # translate indented lines as a verabatim paragraph
+ if (/^\s/) {
+ @lines = split(/\n/);
+ print LATEX "\\begin{verbatim}\n";
+ for (@lines) {
+ 1 while s
+ {^( [^\t]* ) \t ( \t* ) }
+ { $1 . ' ' x (8 - (length($1)%8) + 8*(length($2))) }ex;
+ print LATEX $_,"\n";
+ }
+ print LATEX "\\end{verbatim}\n";
+ next;
+ }
+
+ # preserve '=item' line with pod quotes as they are.
+ if (/^=item/) {
+ ($bareitem = $_) =~ s/^=item\s*//;
+ }
+
+ # check for things that'll hosed our noremap scheme; affects $_
+ &init_noremap();
+
+ # expand strings "func()" as pod quotes.
+ if (!/^=item/) {
+ # first hide pod escapes.
+ # escaped strings are mapped into the ones with the MSB's on.
+ s/([A-Z]<[^<>]*>)/noremap($1)/ge;
+
+ # func() is a reference to a perl function
+ s{\b([:\w]+\(\))}{I<$1>}g;
+ # func(n) is a reference to a man page
+ s{(\w+)(\([^\s,\051]+\))}{I<$1>$2}g;
+ # convert simple variable references
+# s/([\$\@%][\w:]+)/C<$1>/g;
+# s/\$[\w:]+\[[0-9]+\]/C<$&>/g;
+
+ if (m{ ([\-\w]+\([^\051]*?[\@\$,][^\051]*?\))
+ }x && $` !~ /([LCI]<[^<>]*|-)$/ && !/^=\w/)
+ {
+ warn "``$1'' should be a [LCI]<$1> ref";
+ }
+ while (/(-[a-zA-Z])\b/g && $` !~ /[\w\-]$/) {
+ warn "``$1'' should be [CB]<$1> ref";
+ }
+
+ # put back pod quotes so we get the inside of <> processed;
+ $_ = &clear_noremap($_);
+ }
+
+
+ # process TeX special characters
+
+ # First hide HTML quotes E<> since they can be included in C<>.
+ s/(E<[^<>]+>)/noremap($1)/ge;
+
+ # Then hide C<> type literal quotes.
+ # String inside of C<> will later be expanded into {\tt ..} strings
+ # with TeX special characters escaped as needed.
+ s/(C<[^<>]*>)/&noremap($1)/ge;
+
+ # Next escape TeX special characters including other pod quotes B< >,...
+ #
+ # NOTE: s/re/&func($str)/e evaluates $str just once in perl5.
+ # (in perl4 evaluation takes place twice before getting passed to func().)
+
+ # - hyphen => ---
+ s/(\S+)(\s+)-+(\s+)(\S+)/"$1".&noremap(" --- ")."$4"/ge;
+ # '-', '--', "-" => '{\tt -}', '{\tt --}', "{\tt -}"
+## s/("|')(\s*)(-+)(\s*)\1/&noremap("$1$2\{\\tt $3\}$4$1")/ge;
+## changed Wed Jan 25 15:26:39 JST 1995
+ # '-', '--', "-" => '$-$', '$--$', "$-$"
+ s/(\s+)(['"])(-+)([^'"\-]*)\2(\s+|[,.])/"$1$2".&noremap("\$$3\$")."$4$2$5"/ge;
+ s/(\s+)(['"])([^'"\-]*)(-+)(\s*)\2(\s+|[,.])/"$1$2$3".&noremap("\$$4\$")."$5$2$6"/ge;
+ # (--|-) => ($--$|$-$)
+ s/(\s+)\((-+)([=@%\$\+\\\|\w]*)(-*)([=@%\$\+\\\|\w]*)\)(\s+|[,.])/"$1\(".&noremap("\$$2\$")."$3".&noremap("\$$4\$")."$5\)$6"/ge;
+ # numeral - => $-$
+ s/(\(|[0-9]+|\s+)-(\s*\(?\s*[0-9]+)/&noremap("$1\$-\$$2")/ge;
+ # -- in quotes => two separate -
+ s/B<([^<>]*)--([^<>]*)>/&noremap("B<$1\{\\tt --\}$2>")/ge;
+
+ # backslash escapable characters except _.
+ s/([$backslash_escapables2])/&noremap("\\$1")/ge;
+ s/_/&noremap("\\underscore{}")/ge; # a litle thicker than \_.
+ # quote TeX special characters |, ^, ~, \.
+ s/\|/&noremap("\$|\$")/ge;
+ s/\^/&noremap("\$\\hat{\\hspace{0.4em}}\$")/ge;
+ s/\~/&noremap("\$\\tilde{\\hspace{0.4em}}\$")/ge;
+ s/\\/&noremap("\$\\backslash{}\$")/ge;
+ # quote [ and ] to be used in \item[]
+ s/([\[\]])/&noremap("{\\tt $1}")/ge;
+ # characters need to be treated differently in TeX
+ # keep * if an item heading
+ s/^(=item[ \t]+)[*]((.|\n)*)/"$1" . &noremap("*") . "$2"/ge;
+ s/[*]/&noremap("\$\\ast\$")/ge; # other *
+
+ # hide other pod quotes.
+ s/([ABD-Z]<[^<>]*>)/&noremap($1)/ge;
+
+ # escape < and > as math strings,
+ # now that we are done with hiding pod <> quotes.
+ s/</&noremap("\$<\$")/ge;
+ s/>/&noremap("\$>\$")/ge;
+
+ # put it back so we get the <> processed again;
+ $_ = &clear_noremap($_);
+
+
+ # Expand pod quotes recursively:
+ # (1) type face directives [BIFS]<[^<>]*> to appropriate TeX commands,
+ # (2) L<[^<>]*> to reference strings,
+ # (3) C<[^<>]*> to TeX literal quotes,
+ # (4) HTML quotes E<> inside of C<> quotes.
+
+ # Hide E<> again since they can be included in C<>.
+ s/(E<[^<>]+>)/noremap($1)/ge;
+
+ $maxnest = 10;
+ while ($maxnest-- && /[A-Z]</) {
+
+ # bold and italic quotes
+ s/B<([^<>]*)>/"{\\bf $1}"/eg;
+ s#I<([^<>]*)>#"{\\em $1\\/}"#eg;
+
+ # files and filelike refs in italics
+ s#F<([^<>]*)>#"{\\em $1\\/}"#eg;
+
+ # no break quote -- usually we want C<> for this
+ s/S<([^<>]*)>/&nobreak($1)/eg;
+
+ # LREF: a manpage(3f)
+ s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the {\\em $1\\/}$2 manpage:g;
+
+ # LREF: an =item on another manpage
+ s{
+ L<([^/]+)/([:\w]+(\(\))?)>
+ } {the C<$2> entry in the I<$1> manpage}gx;
+
+ # LREF: an =item on this manpage
+ s{
+ ((?:L</([:\w]+(\(\))?)>
+ (,?\s+(and\s+)?)?)+)
+ } { &internal_lrefs($1) }gex;
+
+ # LREF: a =head2 (head1?), maybe on a manpage, maybe right here
+ # the "func" can disambiguate
+ s{
+ L<(?:([a-zA-Z]\S+?) /)?"?(.*?)"?>
+ }{
+ do {
+ $1 # if no $1, assume it means on this page.
+ ? "the section on I<$2> in the I<$1> manpage"
+ : "the section on I<$2>"
+ }
+ }gex;
+
+ s/Z<>/\\&/g; # the "don't format me" thing
+
+ # comes last because not subject to reprocessing
+ s{
+ C<([^<>]*)>
+ }{
+ do {
+ ($str = $1) =~ tr/\200-\377/\000-\177/; #normalize hidden stuff
+ # expand HTML escapes if any;
+ # WARNING: if HTML escapes other than E<amp>,E<lt>,E<gt>,
+ # E<quot> are in C<>, they will not be printed correctly.
+ $str = &expand_HTML_escapes($str);
+ $strverb = &alltt($str); # Tex verbatim escape of a string.
+ &noremap("$strverb");
+ }
+ }gex;
+
+# if ( /C<([^<>]*)/ ) {
+# $str = $1;
+# if ($str !~ /\|/) { # if includes |
+# s/C<([^<>]*)>/&noremap("\\verb|$str|")/eg;
+# } else {
+# print STDERR "found \| in C<.*> at paragraph $.\n";
+# # find a character not contained in $str to use it as a
+# # separator of the \verb
+# ($chars = $str) =~ s/(\W)/\\$1/g;
+# ## ($chars = $str) =~ s/([\$<>,\|"'\-^{}()*+?\\])/\\$1/g;
+# @fence = grep(!/[ $chars]/,@tex_verb_fences);
+# s/C<([^<>]*)>/&noremap("\\verb$fence[0]$str$fence[0]")/eg;
+# }
+# }
+ }
+
+
+ # process each pod command
+ if (s/^=//) { # if a command
+ s/\n/ /g;
+ ($cmd, $rest) = split(' ', $_, 2);
+ $rest =~ s/^\s*//;
+ $rest =~ s/\s*$//;
+
+ if (defined $rest) {
+ &escapes;
+ }
+
+ $rest = &clear_noremap($rest);
+ $rest = &expand_HTML_escapes($rest);
+
+ if ($cmd eq 'cut') {
+ $cutting = 1;
+ $lastcmd = 'cut';
+ }
+ elsif ($cmd eq 'head1') { # heading type 1
+ $rest =~ s/^\s*//; $rest =~ s/\s*$//;
+ print LATEX "\n\\subsection*{$rest}";
+ # put index entry
+ ($index = $rest) =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The'
+ # index only those heads not matching the frequent patterns.
+ foreach $pat (@head1_freq_patterns) {
+ if ($index =~ /^$pat/) {
+ goto freqpatt;
+ }
+ }
+ print LATEX "%\n\\index{$index}\n" if ($index);
+ freqpatt:
+ $lastcmd = 'head1';
+ }
+ elsif ($cmd eq 'head2') { # heading type 2
+ $rest =~ s/^\s*//; $rest =~ s/\s*$//;
+ print LATEX "\n\\subsubsection*{$rest}";
+ # put index entry
+ ($index = $rest) =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The'
+ $index =~ s/^Example\s*[1-9][0-9]*\s*:\s*//; # remove 'Example :'
+ print LATEX "%\n\\index{$index}\n" if ($index);
+ $lastcmd = 'head2';
+ }
+ elsif ($cmd eq 'over') { # 1 level within a listing environment
+ push(@indent,$indent);
+ $indent = $rest + 0;
+ $lastcmd = 'over';
+ }
+ elsif ($cmd eq 'back') { # 1 level out of a listing environment
+ $indent = pop(@indent);
+ warn "Unmatched =back\n" unless defined $indent;
+ $listingcmd = pop(@listingcmd);
+ print LATEX "\n\\end{$listingcmd}\n" if ($listingcmd);
+ $lastcmd = 'back';
+ }
+ elsif ($cmd eq 'item') { # an item paragraph starts
+ if ($lastcmd eq 'over') { # if we have just entered listing env
+ # see what type of list environment we are in.
+ if ($rest =~ /^[0-9]\.?/) { # if numeral heading
+ $listingcmd = 'enumerate';
+ } elsif ($rest =~ /^\*\s*/) { # if * heading
+ $listingcmd = 'itemize';
+ } elsif ($rest =~ /^[^*]/) { # if other headings
+ $listingcmd = 'description';
+ } else {
+ warn "unknown list type for item $rest";
+ }
+ print LATEX "\n\\begin{$listingcmd}\n";
+ push(@listingcmd,$listingcmd);
+ } elsif ($lastcmd ne 'item') {
+ warn "Illegal '=item' command without preceding 'over':";
+ warn "=item $bareitem";
+ }
+
+ if ($listingcmd eq 'enumerate') {
+ $rest =~ s/^[0-9]+\.?\s*//; # remove numeral heading
+ print LATEX "\n\\item";
+ print LATEX "{\\bf $rest}" if $rest;
+ } elsif ($listingcmd eq 'itemize') {
+ $rest =~ s/^\*\s*//; # remove * heading
+ print LATEX "\n\\item";
+ print LATEX "{\\bf $rest}" if $rest;
+ } else { # description item
+ print LATEX "\n\\item[$rest]";
+ }
+ $lastcmd = 'item';
+ $rightafter_item = 'yes';
+
+ # check if the item heading is short or long.
+ ($itemhead = $rest) =~ s/{\\bf (\S*)}/$1/g;
+ if (length($itemhead) < 4) {
+ $itemshort = "yes";
+ } else {
+ $itemshort = "no";
+ }
+ # write index entry
+ if ($pod =~ "perldiag") { # skip 'perldiag.pod'
+ goto noindex;
+ }
+ # strip out the item of pod quotes and get a plain text entry
+ $bareitem =~ s/\n/ /g; # remove newlines
+ $bareitem =~ s/\s*$//; # remove trailing space
+ $bareitem =~ s/[A-Z]<([^<>]*)>/$1/g; # remove <> quotes
+ ($index = $bareitem) =~ s/^\*\s+//; # remove leading '*'
+ $index =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The'
+ $index =~ s/^\s*[1-9][0-9]*\s*[.]\s*$//; # remove numeral only
+ $index =~ s/^\s*\w\s*$//; # remove 1 char only's
+ # quote ", @ and ! with " to be used in makeindex.
+ $index =~ s/"/""/g; # quote "
+ $index =~ s/@/"@/g; # quote @
+ $index =~ s/!/"!/g; # quote !
+ ($rest2=$rest) =~ s/^\*\s+//; # remove *
+ $rest2 =~ s/"/""/g; # quote "
+ $rest2 =~ s/@/"@/g; # quote @
+ $rest2 =~ s/!/"!/g; # quote !
+ if ($pod =~ "(perlfunc|perlvar)") { # when doc is perlfunc,perlvar
+ # take only the 1st word of item heading
+ $index =~ s/^([^{}\s]*)({.*})?([^{}\s]*)\s+.*/\1\2\3/;
+ $rest2 =~ s/^([^{}\s]*)({.*})?([^{}\s]*)\s+.*/\1\2\3/;
+ }
+ if ($index =~ /[A-Za-z\$@%]/) {
+ # write \index{plain_text_entry@TeX_string_entry}
+ print LATEX "%\n\\index{$index\@$rest2}%\n";
+ }
+ noindex:
+ ;
+ }
+ else {
+ warn "Unrecognized directive: $cmd\n";
+ }
+ }
+ else { # if not command
+ &escapes;
+ $_ = &clear_noremap($_);
+ $_ = &expand_HTML_escapes($_);
+
+ # if the present paragraphs follows an =item declaration,
+ # put a line break.
+ if ($lastcmd eq 'item' &&
+ $rightafter_item eq 'yes' && $itemshort eq "no") {
+ print LATEX "\\hfil\\\\";
+ $rightafter_item = 'no';
+ }
+ print LATEX "\n",$_;
+ }
+}
+
+print LATEX "\n";
+close(POD);
+close(LATEX);
+
+
+#########################################################################
+
+sub do_hdr {
+ print LATEX "% LaTeX document produced by pod2latex from \"$pod.pod\".\n";
+ print LATEX "% The followings need be defined in the preamble of this document:\n";
+ print LATEX "%\\def\\C++{{\\rm C\\kern-.05em\\raise.3ex\\hbox{\\footnotesize ++}}}\n";
+ print LATEX "%\\def\\underscore{\\leavevmode\\kern.04em\\vbox{\\hrule width 0.4em height 0.3pt}}\n";
+ print LATEX "%\\setlength{\\parindent}{0pt}\n";
+ print LATEX "\n";
+ $podq = &escape_tex_specials("\U$pod\E");
+ print LATEX "\\section{$podq}%\n";
+ print LATEX "\\index{$podq}";
+ print LATEX "\n";
+}
+
+sub nobreak {
+ my $string = shift;
+ $string =~ s/ +/~/g; # TeX no line break
+ $string;
+}
+
+sub noremap {
+ local($thing_to_hide) = shift;
+ $thing_to_hide =~ tr/\000-\177/\200-\377/;
+ return $thing_to_hide;
+}
+
+sub init_noremap {
+ if ( /[\200-\377]/ ) {
+ warn "hit bit char in input stream";
+ }
+}
+
+sub clear_noremap {
+ local($tmp) = shift;
+ $tmp =~ tr/\200-\377/\000-\177/;
+ return $tmp;
+}
+
+sub expand_HTML_escapes {
+ local($s) = $_[0];
+ $s =~ s { E<([A-Za-z]+)> }
+ {
+ do {
+ exists $HTML_Escapes{$1}
+ ? do { $HTML_Escapes{$1} }
+ : do {
+ warn "Unknown escape: $& in $_";
+ "E<$1>";
+ }
+ }
+ }egx;
+ return $s;
+}
+
+sub escapes {
+ # make C++ into \C++, which is to be defined as
+ # \def\C++{{\rm C\kern-.05em\raise.3ex\hbox{\footnotesize ++}}}
+ s/\bC\+\+/\\C++{}/g;
+}
+
+# Translate a string into a TeX \tt string to obtain a verbatim print out.
+# TeX special characters are escaped by \.
+# This can be used inside of LaTeX command arguments.
+# We don't use LaTeX \verb since it doesn't work inside of command arguments.
+sub alltt {
+ local($str) = shift;
+ # other chars than #,\,$,%,&,{,},_,\,^,~ ([ and ] included).
+ $str =~ s/([^${backslash_escapables}\\\^\~]+)/&noremap("$&")/eg;
+ # chars #,\,$,%,&,{,} => \# , ...
+ $str =~ s/([$backslash_escapables2])/&noremap("\\$&")/eg;
+ # chars _,\,^,~ => \char`\_ , ...
+ $str =~ s/_/&noremap("\\char`\\_")/eg;
+ $str =~ s/\\/&noremap("\\char`\\\\")/ge;
+ $str =~ s/\^/\\char`\\^/g;
+ $str =~ s/\~/\\char`\\~/g;
+
+ $str =~ tr/\200-\377/\000-\177/; # put back
+ $str = "{\\tt ".$str."}"; # make it a \tt string
+ return $str;
+}
+
+sub escape_tex_specials {
+ local($str) = shift;
+ # other chars than #,\,$,%,&,{,}, _,\,^,~ ([ and ] included).
+ # backslash escapable characters #,\,$,%,&,{,} except _.
+ $str =~ s/([$backslash_escapables2])/&noremap("\\$1")/ge;
+ $str =~ s/_/&noremap("\\underscore{}")/ge; # \_ is too thin.
+ # quote TeX special characters |, ^, ~, \.
+ $str =~ s/\|/&noremap("\$|\$")/ge;
+ $str =~ s/\^/&noremap("\$\\hat{\\hspace{0.4em}}\$")/ge;
+ $str =~ s/\~/&noremap("\$\\tilde{\\hspace{0.4em}}\$")/ge;
+ $str =~ s/\\/&noremap("\$\\backslash{}\$")/ge;
+ # characters need to be treated differently in TeX
+ # *
+ $str =~ s/[*]/&noremap("\$\\ast\$")/ge;
+ # escape < and > as math string,
+ $str =~ s/</&noremap("\$<\$")/ge;
+ $str =~ s/>/&noremap("\$>\$")/ge;
+ $str =~ tr/\200-\377/\000-\177/; # put back
+ return $str;
+}
+
+sub internal_lrefs {
+ local($_) = shift;
+
+ s{L</([^>]+)>}{$1}g;
+ my(@items) = split( /(?:,?\s+(?:and\s+)?)/ );
+ my $retstr = "the ";
+ my $i;
+ for ($i = 0; $i <= $#items; $i++) {
+ $retstr .= "C<$items[$i]>";
+ $retstr .= ", " if @items > 2 && $i != $#items;
+ $retstr .= " and " if $i+2 == @items;
+ }
+ $retstr .= " entr" . ( @items > 1 ? "ies" : "y" )
+ . " elsewhere in this document";
+
+ return $retstr;
+}
+
+# map of HTML escapes to TeX escapes.
+BEGIN {
+%HTML_Escapes = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "\\'{A}", # capital A, acute accent
+ "aacute" => "\\'{a}", # small a, acute accent
+ "Acirc" => "\\^{A}", # capital A, circumflex accent
+ "acirc" => "\\^{a}", # small a, circumflex accent
+ "AElig" => '\\AE', # capital AE diphthong (ligature)
+ "aelig" => '\\ae', # small ae diphthong (ligature)
+ "Agrave" => "\\`{A}", # capital A, grave accent
+ "agrave" => "\\`{a}", # small a, grave accent
+ "Aring" => '\\u{A}', # capital A, ring
+ "aring" => '\\u{a}', # small a, ring
+ "Atilde" => '\\~{A}', # capital A, tilde
+ "atilde" => '\\~{a}', # small a, tilde
+ "Auml" => '\\"{A}', # capital A, dieresis or umlaut mark
+ "auml" => '\\"{a}', # small a, dieresis or umlaut mark
+ "Ccedil" => '\\c{C}', # capital C, cedilla
+ "ccedil" => '\\c{c}', # small c, cedilla
+ "Eacute" => "\\'{E}", # capital E, acute accent
+ "eacute" => "\\'{e}", # small e, acute accent
+ "Ecirc" => "\\^{E}", # capital E, circumflex accent
+ "ecirc" => "\\^{e}", # small e, circumflex accent
+ "Egrave" => "\\`{E}", # capital E, grave accent
+ "egrave" => "\\`{e}", # small e, grave accent
+ "ETH" => '\\OE', # capital Eth, Icelandic
+ "eth" => '\\oe', # small eth, Icelandic
+ "Euml" => '\\"{E}', # capital E, dieresis or umlaut mark
+ "euml" => '\\"{e}', # small e, dieresis or umlaut mark
+ "Iacute" => "\\'{I}", # capital I, acute accent
+ "iacute" => "\\'{i}", # small i, acute accent
+ "Icirc" => "\\^{I}", # capital I, circumflex accent
+ "icirc" => "\\^{i}", # small i, circumflex accent
+ "Igrave" => "\\`{I}", # capital I, grave accent
+ "igrave" => "\\`{i}", # small i, grave accent
+ "Iuml" => '\\"{I}', # capital I, dieresis or umlaut mark
+ "iuml" => '\\"{i}', # small i, dieresis or umlaut mark
+ "Ntilde" => '\\~{N}', # capital N, tilde
+ "ntilde" => '\\~{n}', # small n, tilde
+ "Oacute" => "\\'{O}", # capital O, acute accent
+ "oacute" => "\\'{o}", # small o, acute accent
+ "Ocirc" => "\\^{O}", # capital O, circumflex accent
+ "ocirc" => "\\^{o}", # small o, circumflex accent
+ "Ograve" => "\\`{O}", # capital O, grave accent
+ "ograve" => "\\`{o}", # small o, grave accent
+ "Oslash" => "\\O", # capital O, slash
+ "oslash" => "\\o", # small o, slash
+ "Otilde" => "\\~{O}", # capital O, tilde
+ "otilde" => "\\~{o}", # small o, tilde
+ "Ouml" => '\\"{O}', # capital O, dieresis or umlaut mark
+ "ouml" => '\\"{o}', # small o, dieresis or umlaut mark
+ "szlig" => '\\ss', # small sharp s, German (sz ligature)
+ "THORN" => '\\L', # capital THORN, Icelandic
+ "thorn" => '\\l',, # small thorn, Icelandic
+ "Uacute" => "\\'{U}", # capital U, acute accent
+ "uacute" => "\\'{u}", # small u, acute accent
+ "Ucirc" => "\\^{U}", # capital U, circumflex accent
+ "ucirc" => "\\^{u}", # small u, circumflex accent
+ "Ugrave" => "\\`{U}", # capital U, grave accent
+ "ugrave" => "\\`{u}", # small u, grave accent
+ "Uuml" => '\\"{U}', # capital U, dieresis or umlaut mark
+ "uuml" => '\\"{u}', # small u, dieresis or umlaut mark
+ "Yacute" => "\\'{Y}", # capital Y, acute accent
+ "yacute" => "\\'{y}", # small y, acute accent
+ "yuml" => '\\"{y}', # small y, dieresis or umlaut mark
+);
+}
print ".ft $CFont\n";
print <<'END';
'if n "\c
-'if t \\\\&\\\\$1\c
-'if n \\\\&\\\\$1\c
+'if t \\&\\$1\c
+'if n \\&\\$1\c
'if n \&"
-\\\\&\\\\$2 \\\\$3 \\\\$4 \\\\$5 \\\\$6 \\\\$7
+\\&\\$2 \\$3 \\$4 \\$5 \\$6 \\$7
'.ft R
..
.\" @(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2
. ds #] \fP
.\}
.if t \{\
-. ds #H ((1u-(\\\\\\\\n(.fu%2u))*.13m)
+. ds #H ((1u-(\\\\n(.fu%2u))*.13m)
. ds #V .6m
. ds #F 0
. ds #[ \&
. ds q
.\}
.if t \{\
-. ds ' \\\\k:\h'-(\\\\n(.wu*8/10-\*(#H)'\'\h"|\\\\n:u"
-. ds ` \\\\k:\h'-(\\\\n(.wu*8/10-\*(#H)'\`\h'|\\\\n:u'
-. ds ^ \\\\k:\h'-(\\\\n(.wu*10/11-\*(#H)'^\h'|\\\\n:u'
-. ds , \\\\k:\h'-(\\\\n(.wu*8/10)',\h'|\\\\n:u'
-. ds ~ \\\\k:\h'-(\\\\n(.wu-\*(#H-.1m)'~\h'|\\\\n:u'
+. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
+. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
+. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
+. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
+. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
. ds ? \s-2c\h'-\w'c'u*7/10'\u\h'\*(#H'\zi\d\s+2\h'\w'c'u*8/10'
. ds ! \s-2\(or\s+2\h'-\w'\(or'u'\v'-.8m'.\v'.8m'
-. ds / \\\\k:\h'-(\\\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\\\n:u'
+. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
. ds q o\h'-\w'o'u*8/10'\s-4\v'.4m'\z\(*i\v'-.4m'\s+4\h'\w'o'u*8/10'
.\}
. \" troff and (daisy-wheel) nroff accents
-.ds : \\\\k:\h'-(\\\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\\\n:u'\v'\*(#V'
+.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
.ds 8 \h'\*(#H'\(*b\h'-\*(#H'
-.ds v \\\\k:\h'-(\\\\n(.wu*9/10-\*(#H)'\v'-\*(#V'\*(#[\s-4v\s0\v'\*(#V'\h'|\\\\n:u'\*(#]
-.ds _ \\\\k:\h'-(\\\\n(.wu*9/10-\*(#H+(\*(#F*2/3))'\v'-.4m'\z\(hy\v'.4m'\h'|\\\\n:u'
-.ds . \\\\k:\h'-(\\\\n(.wu*8/10)'\v'\*(#V*4/10'\z.\v'-\*(#V*4/10'\h'|\\\\n:u'
+.ds v \\k:\h'-(\\n(.wu*9/10-\*(#H)'\v'-\*(#V'\*(#[\s-4v\s0\v'\*(#V'\h'|\\n:u'\*(#]
+.ds _ \\k:\h'-(\\n(.wu*9/10-\*(#H+(\*(#F*2/3))'\v'-.4m'\z\(hy\v'.4m'\h'|\\n:u'
+.ds . \\k:\h'-(\\n(.wu*8/10)'\v'\*(#V*4/10'\z.\v'-\*(#V*4/10'\h'|\\n:u'
.ds 3 \*(#[\v'.2m'\s-2\&3\s0\v'-.2m'\*(#]
-.ds o \\\\k:\h'-(\\\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\\\n:u'\*(#]
+.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
-.ds D- D\\\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\\\n:u'
+.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
.ds ae a\h'-(\w'a'u*4/10)'e
.ds oe o\h'-(\w'o'u*4/10)'e
.ds Oe O\h'-(\w'O'u*4/10)'E
. \" corrections for vroff
-.if v .ds ~ \\\\k:\h'-(\\\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\\\n:u'
-.if v .ds ^ \\\\k:\h'-(\\\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\\\n:u'
+.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
+.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
. \" for low resolution devices (crt and lpr)
.if \n(.H>23 .if \n(.V>19 \
\{\
} {I<$1>\\|$2}gx;
# convert simple variable references
- s/([\$\@%][\w:]+)/C<$1>/g;
+ s/(\s+)([\$\@%][\w:]+)/${1}C<$2>/g;
if (m{ (
[\-\w]+
}
else {
if (SvTYPE(sv) != SVt_PVGV) {
+ char *sym;
+
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
DIE(no_usym, "a symbol");
RETSETUNDEF;
}
+ sym = SvPV(sv, na);
if (op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, "a symbol");
- sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE, SVt_PVGV);
+ DIE(no_symref, sym, "a symbol");
+ sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
}
}
if (op->op_private & OPpLVAL_INTRO) {
}
else {
GV *gv = sv;
+ char *sym;
+
if (SvTYPE(gv) != SVt_PVGV) {
if (SvGMAGICAL(sv)) {
mg_get(sv);
DIE(no_usym, "a SCALAR");
RETSETUNDEF;
}
+ sym = SvPV(sv, na);
if (op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, "a SCALAR");
- gv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE, SVt_PV);
+ DIE(no_symref, sym, "a SCALAR");
+ gv = (SV*)gv_fetchpv(sym, TRUE, SVt_PV);
}
sv = GvSV(gv);
}
PP(pp_anoncode)
{
dSP;
- XPUSHs(cSVOP->op_sv);
+ CV* cv = (CV*)cSVOP->op_sv;
+ EXTEND(SP,1);
+
+ if (SvFLAGS(cv) & SVpcv_CLONE) {
+ cv = cv_clone(cv);
+ }
+
+ PUSHs((SV*)cv);
RETURN;
}
PP(pp_predec)
{
dSP;
- sv_dec(TOPs);
+ if (SvIOK(TOPs)) {
+ --SvIVX(TOPs);
+ SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
+ }
+ else
+ sv_dec(TOPs);
SvSETMAGIC(TOPs);
return NORMAL;
}
{
dSP; dTARGET;
sv_setsv(TARG, TOPs);
- sv_inc(TOPs);
+ if (SvIOK(TOPs)) {
+ ++SvIVX(TOPs);
+ SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
+ }
+ else
+ sv_inc(TOPs);
SvSETMAGIC(TOPs);
if (!SvOK(TARG))
sv_setiv(TARG, 0);
{
dSP; dTARGET;
sv_setsv(TARG, TOPs);
- sv_dec(TOPs);
+ if (SvIOK(TOPs)) {
+ --SvIVX(TOPs);
+ SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
+ }
+ else
+ sv_dec(TOPs);
SvSETMAGIC(TOPs);
SETs(TARG);
return NORMAL;
PP(pp_repeat)
{
- dSP; dATARGET;
+ dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
+ {
register I32 count = POPi;
if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
dMARK;
PUSHTARG;
}
RETURN;
+ }
}
PP(pp_subtract)
{
dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
{
- dPOPTOPiirl;
- SETi( left << right );
- RETURN;
+ dPOPTOPiirl;
+ SETi( left << right );
+ RETURN;
}
}
register I32 anum;
if (SvNIOK(sv)) {
- SETi( ~SvIV(sv) );
+ IV iv = ~SvIV(sv);
+ if (iv < 0)
+ SETn( (double) ~U_L(SvNV(sv)) );
+ else
+ SETi( iv );
}
else {
register char *tmps;
/* integer versions of some of the above */
-PP(pp_i_preinc)
-{
-#ifndef OVERLOAD
- dSP; dTOPiv;
- sv_setiv(TOPs, value + 1);
- SvSETMAGIC(TOPs);
-#else
- dSP;
- if (SvAMAGIC(TOPs) ) {
- sv_inc(TOPs);
- } else {
- dTOPiv;
- sv_setiv(TOPs, value + 1);
- SvSETMAGIC(TOPs);
- }
-#endif /* OVERLOAD */
- return NORMAL;
-}
-
-PP(pp_i_predec)
-{
-#ifndef OVERLOAD
- dSP; dTOPiv;
- sv_setiv(TOPs, value - 1);
- SvSETMAGIC(TOPs);
-#else
- dSP;
- if (SvAMAGIC(TOPs)) {
- sv_dec(TOPs);
- } else {
- dTOPiv;
- sv_setiv(TOPs, value - 1);
- SvSETMAGIC(TOPs);
- }
-#endif /* OVERLOAD */
- return NORMAL;
-}
-
-PP(pp_i_postinc)
-{
- dSP; dTARGET;
- sv_setsv(TARG, TOPs);
-#ifndef OVERLOAD
- sv_setiv(TOPs, SvIV(TOPs) + 1);
- SvSETMAGIC(TOPs);
-#else
- if (SvAMAGIC(TOPs) ) {
- sv_inc(TOPs);
- } else {
- sv_setiv(TOPs, SvIV(TOPs) + 1);
- SvSETMAGIC(TOPs);
- }
-#endif /* OVERLOAD */
- if (!SvOK(TARG))
- sv_setiv(TARG, 0);
- SETs(TARG);
- return NORMAL;
-}
-
-PP(pp_i_postdec)
-{
- dSP; dTARGET;
- sv_setsv(TARG, TOPs);
-#ifndef OVERLOAD
- sv_setiv(TOPs, SvIV(TOPs) - 1);
- SvSETMAGIC(TOPs);
-#else
- if (SvAMAGIC(TOPs) ) {
- sv_dec(TOPs);
- } else {
- sv_setiv(TOPs, SvIV(TOPs) - 1);
- SvSETMAGIC(TOPs);
- }
-#endif /* OVERLOAD */
- SETs(TARG);
- return NORMAL;
-}
-
PP(pp_i_multiply)
{
dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
if (MAXARG < 3)
len = curlen;
else if (len < 0) {
- len += curlen;
+ len += curlen - pos;
if (len < 0)
len = 0;
}
rem = len;
sv_setpvn(TARG, tmps, rem);
if (lvalue) { /* it's an lvalue! */
+ (void)SvPOK_only(sv);
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
sv_magic(TARG, Nullsv, 'x', Nullch, 0);
retnum = 0;
else {
offset >>= 3;
- if (size == 16)
- retnum = (unsigned long) s[offset] << 8;
- else if (size == 32) {
- if (offset < len) {
- if (offset + 1 < len)
- retnum = ((unsigned long) s[offset] << 24) +
- ((unsigned long) s[offset + 1] << 16) +
- (s[offset + 2] << 8);
- else
- retnum = ((unsigned long) s[offset] << 24) +
- ((unsigned long) s[offset + 1] << 16);
- }
+ if (size == 16) {
+ if (offset >= srclen)
+ retnum = 0;
else
+ retnum = (unsigned long) s[offset] << 8;
+ }
+ else if (size == 32) {
+ if (offset >= srclen)
+ retnum = 0;
+ else if (offset + 1 >= srclen)
retnum = (unsigned long) s[offset] << 24;
+ else if (offset + 2 >= srclen)
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16);
+ else
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16) +
+ (s[offset + 2] << 8);
}
}
}
dSP; dTARGET;
char *tmps;
- if (!SvPOK(TARG)) {
- (void)SvUPGRADE(TARG,SVt_PV);
- SvGROW(TARG,1);
- }
+ (void)SvUPGRADE(TARG,SVt_PV);
+ SvGROW(TARG,2);
SvCUR_set(TARG, 1);
tmps = SvPVX(TARG);
- *tmps = POPi;
+ *tmps++ = POPi;
+ *tmps = '\0';
(void)SvPOK_only(TARG);
XPUSHs(TARG);
RETURN;
register SV** svp;
register AV* av = (AV*)POPs;
register I32 lval = op->op_flags & OPf_MOD;
+ I32 arybase = curcop->cop_arybase;
+ I32 elem;
if (SvTYPE(av) == SVt_PVAV) {
+ if (lval && op->op_private & OPpLVAL_INTRO) {
+ I32 max = -1;
+ for (svp = mark + 1; svp <= sp; svp++) {
+ elem = SvIVx(*svp);
+ if (elem > max)
+ max = elem;
+ }
+ if (max > AvMAX(av))
+ av_extend(av, max);
+ }
while (++MARK <= SP) {
- I32 elem = SvIVx(*MARK);
+ elem = SvIVx(*MARK);
+ if (elem > 0)
+ elem -= arybase;
svp = av_fetch(av, elem, lval);
if (lval) {
if (!svp || *svp == &sv_undef)
*MARK = svp ? *svp : &sv_undef;
}
}
- else if (GIMME != G_ARRAY) {
+ if (GIMME != G_ARRAY) {
MARK = ORIGMARK;
*++MARK = *SP;
SP = MARK;
DIE("Not a HASH reference");
}
tmps = SvPV(tmpsv, len);
- sv = hv_delete(hv, tmps, len);
+ sv = hv_delete(hv, tmps, len,
+ op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0);
if (!sv)
RETPUSHUNDEF;
PUSHs(sv);
register I32 ix;
if (GIMME != G_ARRAY) {
- ix = SvIVx(*lastlelem) - arybase;
+ ix = SvIVx(*lastlelem);
+ if (ix < 0)
+ ix += max;
+ else
+ ix -= arybase;
if (ix < 0 || ix >= max)
*firstlelem = &sv_undef;
else
}
for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
- ix = SvIVx(*lelem) - arybase;
+ ix = SvIVx(*lelem);
if (ix < 0) {
ix += max;
if (ix < 0)
else if (!(*lelem = firstrelem[ix]))
*lelem = &sv_undef;
}
- else if (ix >= max || !(*lelem = firstrelem[ix]))
- *lelem = &sv_undef;
+ else {
+ ix -= arybase;
+ if (ix >= max || !(*lelem = firstrelem[ix]))
+ *lelem = &sv_undef;
+ }
}
SP = lastlelem;
RETURN;
if (GIMME != G_ARRAY) { /* arrange to do first one only */
/*SUPPRESS 530*/
for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
- if (strchr("aAbBhH", *patend) || *pat == '%') {
+ if (strchr("aAbBhHP", *patend) || *pat == '%') {
patend++;
while (isDIGIT(*patend) || *patend == '*')
patend++;
for (i = 1; i <= rx->nparens; i++) {
s = rx->startp[i];
m = rx->endp[i];
- dstr = NEWSV(33, m-s);
- sv_setpvn(dstr, s, m-s);
+ if (m && s) {
+ dstr = NEWSV(33, m-s);
+ sv_setpvn(dstr, s, m-s);
+ }
+ else
+ dstr = NEWSV(33, 0);
if (!realarray)
sv_2mortal(dstr);
XPUSHs(dstr);
#define RvDEEPCP(rv) do { SV* ref=SvRV(rv); \
if (SvREFCNT(ref)>1) { \
SvREFCNT_dec(ref); \
- SvRV(rv)=newSVsv(ref); \
+ SvRV(rv)=AMG_CALLun(rv,copy); \
} } while (0)
#else
pm->op_pmflags |= PMf_WHITE;
if (pm->op_pmflags & PMf_KEEP) {
-#ifdef NOTDEF
- if (!(pm->op_pmflags & PMf_FOLD))
- scan_prefix(pm, pm->op_pmregexp->precomp,
- pm->op_pmregexp->prelen);
-#endif
pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */
hoistmust(pm);
cLOGOP->op_first->op_next = op->op_next;
- /* XXX delete push code? */
}
RETURN;
}
{
SV *targ = cx->sb_targ;
sv_catpvn(dstr, s, cx->sb_strend - s);
- sv_replace(targ, dstr);
+
+ SvPVX(targ) = SvPVX(dstr);
+ SvCUR_set(targ, SvCUR(dstr));
+ SvLEN_set(targ, SvLEN(dstr));
+ SvPVX(dstr) = 0;
+ sv_free(dstr);
+
(void)SvPOK_only(targ);
SvSETMAGIC(targ);
PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
bool chopspace = (strchr(chopset, ' ') != Nullch);
char *chophere;
char *linemark;
- char *formmark;
- SV **markmark;
double value;
bool gotsome;
STRLEN len;
switch (*fpc++) {
case FF_LINEMARK:
linemark = t;
- formmark = f;
- markmark = MARK;
lines++;
gotsome = FALSE;
break;
char *message;
int oldrunlevel = runlevel;
int was_in_eval = in_eval;
+ HV *stash;
+ GV *gv;
+ CV *cv;
#ifdef I_STDARG
va_start(args, pat);
#endif
message = mess(pat, &args);
va_end(args);
+ if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
+ dSP;
+
+ PUSHMARK(sp);
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVpv(message,0)));
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ }
restartop = die_where(message);
if ((!restartop && was_in_eval) || oldrunlevel > 1)
longjmp(top_env, 3);
register CONTEXT *cx;
I32 gimme;
SV **newsp;
+ SV *errsv;
+
+ errsv = GvSV(gv_fetchpv("@",TRUE, SVt_PV));
+ /* As destructors may produce errors we set $@ at the last moment */
+ sv_setpv(errsv, ""); /* clear $@ before destroying */
- sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),message);
cxix = dopoptoeval(cxstack_ix);
if (cxix >= 0) {
I32 optype;
stack_sp = newsp;
LEAVE;
+
+ sv_insert(errsv, 0, 0, message, strlen(message));
if (optype == OP_REQUIRE)
DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na));
return pop_return();
(void)fflush(stderr);
if (e_fp)
(void)UNLINK(e_tmpname);
- statusvalue >>= 8;
+ statusvalue = SHIFTSTATUS(statusvalue);
+#ifdef VMS
+ my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
+#else
my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
+#endif
return 0;
}
PUSHs(sv_2mortal(newSViv(0)));
}
PUSHs(sv_2mortal(newSViv((I32)cx->blk_gimme)));
+ if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
+ PUSHs(cx->blk_eval.cur_text);
+
if (cx->blk_sub.hasargs && curcop->cop_stash == debstash) {
AV *ary = cx->blk_sub.argarray;
int off = AvARRAY(ary) - AvALLOC(ary);
{
SV **str1 = (SV **) a;
SV **str2 = (SV **) b;
+ I32 oldsaveix = savestack_ix;
I32 oldscopeix = scopestack_ix;
I32 result;
GvSV(firstgv) = *str1;
run();
if (stack_sp != stack_base + 1)
croak("Sort subroutine didn't return single value");
- if (!SvNIOK(*stack_sp))
+ if (!SvNIOKp(*stack_sp))
croak("Sort subroutine didn't return a numeric value");
result = SvIV(*stack_sp);
while (scopestack_ix > oldscopeix) {
LEAVE;
}
+ leave_scope(oldsaveix);
return result;
}
SV **sp;
register CV *cv;
register CONTEXT *cx;
- I32 gimme = GIMME;
+ I32 gimme = G_ARRAY;
I32 hasargs;
GV *gv;
ENTER;
SAVETMPS;
- SAVEI32(debug);
- debug = 0;
- hasargs = 0;
gv = DBgv;
cv = GvCV(gv);
- sp = stack_sp;
- *++sp = Nullsv;
-
if (!cv)
DIE("No DB::DB routine defined");
if (CvDEPTH(cv) >= 1) /* don't do recursive DB::DB call */
return NORMAL;
+
+ SAVEI32(debug);
+ SAVESPTR(stack_sp);
+ debug = 0;
+ hasargs = 0;
+ sp = stack_sp;
+
push_return(op->op_next);
- PUSHBLOCK(cx, CXt_SUB, sp - 1);
+ PUSHBLOCK(cx, CXt_SUB, sp);
PUSHSUB(cx);
CvDEPTH(cv)++;
(void)SvREFCNT_inc(cv);
break;
case CXt_EVAL:
POPEVAL(cx);
+ if (optype == OP_REQUIRE &&
+ (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
+ {
+ char *name = cx->blk_eval.old_name;
+ (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
+ DIE("%s did not return a true value", name);
+ }
break;
default:
DIE("panic: return");
*++newsp = sv_mortalcopy(*SP);
else
*++newsp = &sv_undef;
- if (optype == OP_REQUIRE && !SvTRUE(*newsp))
- DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na));
}
else {
- if (optype == OP_REQUIRE && MARK == SP)
- DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na));
while (MARK < SP)
*++newsp = sv_mortalcopy(*++MARK);
}
SV **newsp;
PMOP *newpm;
SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
- /* XXX The sp is probably not right yet... */
if (op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
GvENAME(CvGV(cv)));
if (CvDEPTH(cv) > AvFILL(padlist)) {
AV *newpad = newAV();
+ AV *oldpad = (AV*)AvARRAY(svp[CvDEPTH(cv)-1]);
I32 ix = AvFILL((AV*)svp[1]);
svp = AvARRAY(svp[0]);
- while (ix > 0) {
+ for ( ;ix > 0; ix--) {
if (svp[ix] != &sv_undef) {
- char *name = SvPVX(svp[ix]); /* XXX */
- if (*name == '@')
- av_store(newpad, ix--, sv = (SV*)newAV());
- else if (*name == '%')
- av_store(newpad, ix--, sv = (SV*)newHV());
- else
- av_store(newpad, ix--, sv = NEWSV(0,0));
- SvPADMY_on(sv);
+ char *name = SvPVX(svp[ix]);
+ if (SvFLAGS(svp[ix]) & SVf_FAKE) {
+ /* outer lexical? */
+ av_store(newpad, ix,
+ SvREFCNT_inc(AvARRAY(oldpad)[ix]) );
+ }
+ else { /* our own lexical */
+ if (*name == '@')
+ av_store(newpad, ix, sv = (SV*)newAV());
+ else if (*name == '%')
+ av_store(newpad, ix, sv = (SV*)newHV());
+ else
+ av_store(newpad, ix, sv = NEWSV(0,0));
+ SvPADMY_on(sv);
+ }
}
else {
- av_store(newpad, ix--, sv = NEWSV(0,0));
+ av_store(newpad, ix, sv = NEWSV(0,0));
SvPADTMP_on(sv);
}
}
/* push wanted frames */
- if (*enterops) {
+ if (*enterops && enterops[1]) {
OP *oldop = op;
- for (ix = 0 + (gotoprobe == main_root); enterops[ix]; ix++) {
+ for (ix = 1; enterops[ix]; ix++) {
op = enterops[ix];
(*op->op_ppaddr)();
}
do_undump = FALSE;
}
+ if (stack == signalstack) {
+ restartop = retop;
+ longjmp(top_env, 3);
+ }
+
RETURNOP(retop);
}
dSP;
OP *saveop = op;
HV *newstash;
+ AV* comppadlist;
in_eval = 1;
SAVEINT(comppad_name_fill);
SAVEINT(min_intro_pending);
SAVEINT(max_intro_pending);
+
+ SAVESPTR(compcv);
+ compcv = (CV*)NEWSV(1104,0);
+ sv_upgrade((SV *)compcv, SVt_PVCV);
+
comppad = newAV();
comppad_name = newAV();
comppad_name_fill = 0;
curpad = AvARRAY(comppad);
padix = 0;
+ comppadlist = newAV();
+ AvREAL_off(comppadlist);
+ av_store(comppadlist, 0, SvREFCNT_inc((SV*)comppad_name));
+ av_store(comppadlist, 1, SvREFCNT_inc((SV*)comppad));
+ CvPADLIST(compcv) = comppadlist;
+
/* make sure we compile in the right package */
newstash = curcop->cop_stash;
rschar = nrschar;
rspara = (nrslen == 2);
compiling.cop_line = 0;
- SAVEFREESV(comppad);
- SAVEFREESV(comppad_name);
+ SAVEFREESV(compcv);
SAVEFREEOP(eval_root);
if (gimme & G_ARRAY)
list(eval_root);
if (*tmpname == '/' ||
(*tmpname == '.' &&
(tmpname[1] == '/' ||
- (tmpname[1] == '.' && tmpname[2] == '/'))))
+ (tmpname[1] == '.' && tmpname[2] == '/')))
+#ifdef VMS
+ || ((*tmpname == '[' || *tmpname == '<') &&
+ (tmpname[1] == '-' || tmpname[1] == ']' || tmpname[1] == '>'))
+#endif
+ )
{
tryrsfp = fopen(tmpname,"r");
}
I32 i;
for (i = 0; i <= AvFILL(ar); i++) {
+#ifdef VMS
+ if (tounixpath_ts(SvPVx(*av_fetch(ar, i, TRUE), na),buf) == NULL)
+ croak("Error converting file specification %s",
+ SvPVx(*av_fetch(ar, i, TRUE), na));
+ strcat(buf,name);
+#else
(void)sprintf(buf, "%s/%s",
SvPVx(*av_fetch(ar, i, TRUE), na), name);
+#endif
tryrsfp = fopen(buf, "r");
if (tryrsfp) {
char *s = buf;
if (!SvPV(sv,len) || !len)
RETPUSHUNDEF;
+ TAINT_PROPER("eval");
ENTER;
- SAVETMPS;
lex_start(sv);
+ SAVETMPS;
/* switch to eval mode */
+ SAVESPTR(compiling.cop_filegv);
sprintf(tmpbuf, "_<(eval %d)", ++evalseq);
compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
compiling.cop_line = 1;
if (!(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
/* Unassume the success we assumed earlier. */
- (void)hv_delete(GvHVn(incgv), name, strlen(name));
+ (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
if (optype == OP_REQUIRE)
retop = die("%s did not return a true value", name);
RETURNOP(retop);
}
-#ifdef NOTYET
-PP(pp_evalonce)
-{
- dSP;
- SP = do_eval(st[1], OP_EVAL, curcop->cop_stash, TRUE,
- GIMME, arglast);
- if (eval_root) {
- SvREFCNT_dec(cSVOP->op_sv);
- op[1].arg_ptr.arg_cmd = eval_root;
- op[1].op_type = (A_CMD|A_DONT);
- op[0].op_type = OP_TRY;
- }
- RETURN;
-}
-#endif
-
PP(pp_entertry)
{
dSP;
PP(pp_sassign)
{
dSP; dPOPTOPssrl;
+ MAGIC *mg;
+
if (op->op_private & OPpASSIGN_BACKWARDS) {
SV *temp;
temp = left; left = right; right = temp;
}
if (tainting && tainted && (!SvGMAGICAL(left) || !SvSMAGICAL(left) ||
- !mg_find(left, 't'))) {
+ !((mg = mg_find(left, 't')) && mg->mg_len & 1)))
+ {
TAINT_NOT;
}
SvSetSV(right, left);
PP(pp_concat)
{
- dSP; dATARGET; dPOPTOPssrl;
+ dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
+ {
+ dPOPTOPssrl;
STRLEN len;
char *s;
if (TARG != left) {
s = SvPV(left,len);
sv_setpvn(TARG,s,len);
}
+ else if (!SvOK(TARG))
+ sv_setpv(TARG, ""); /* Suppress warning. */
s = SvPV(right,len);
sv_catpvn(TARG,s,len);
SETTARG;
RETURN;
+ }
}
PP(pp_padsv)
PP(pp_preinc)
{
dSP;
- sv_inc(TOPs);
+ if (SvIOK(TOPs)) {
+ ++SvIVX(TOPs);
+ SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
+ }
+ else
+ sv_inc(TOPs);
SvSETMAGIC(TOPs);
return NORMAL;
}
else
gv = defoutgv;
if (!(io = GvIO(gv))) {
- if (dowarn)
- warn("Filehandle %s never opened", GvNAME(gv));
- errno = EBADF;
+ if (dowarn) {
+ SV* sv = sv_newmortal();
+ gv_fullname(sv,gv);
+ warn("Filehandle %s never opened", SvPV(sv,na));
+ }
+
+ SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
if (dowarn) {
+ SV* sv = sv_newmortal();
+ gv_fullname(sv,gv);
if (IoIFP(io))
- warn("Filehandle %s opened only for input", GvNAME(gv));
+ warn("Filehandle %s opened only for input", SvPV(sv,na));
else
- warn("print on closed filehandle %s", GvNAME(gv));
+ warn("print on closed filehandle %s", SvPV(sv,na));
}
- errno = EBADF;
+ SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
}
else {
}
else {
if (SvTYPE(sv) != SVt_PVGV) {
+ char *sym;
+
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
DIE(no_usym, "an ARRAY");
RETPUSHUNDEF;
}
+ sym = SvPV(sv,na);
if (op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, "an ARRAY");
- sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE, SVt_PVAV);
+ DIE(no_symref, sym, "an ARRAY");
+ sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
}
av = GvAVn(sv);
if (op->op_private & OPpLVAL_INTRO)
}
else {
if (SvTYPE(sv) != SVt_PVGV) {
+ char *sym;
+
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
DIE(no_usym, "a HASH");
RETSETUNDEF;
}
+ sym = SvPV(sv,na);
if (op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, "a HASH");
- sv = (SV*)gv_fetchpv(SvPV(sv, na), TRUE, SVt_PVHV);
+ DIE(no_symref, sym, "a HASH");
+ sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
}
hv = GvHVn(sv);
if (op->op_private & OPpLVAL_INTRO)
switch (SvTYPE(sv)) {
case SVt_PVAV:
ary = (AV*)sv;
- magic = SvSMAGICAL(ary) != 0;
+ magic = SvMAGICAL(ary) != 0;
av_clear(ary);
i = 0;
SV *tmpstr;
hash = (HV*)sv;
- magic = SvSMAGICAL(hash) != 0;
+ magic = SvMAGICAL(hash) != 0;
hv_clear(hash);
while (relem < lastrelem) { /* gobble up all the rest */
#ifdef HAS_SETRUID
if ((delaymagic & DM_UID) == DM_RUID) {
(void)setruid(uid);
- delaymagic =~ DM_RUID;
+ delaymagic &= ~DM_RUID;
}
#endif /* HAS_SETRUID */
#endif /* HAS_SETRESUID */
#ifdef HAS_SETEUID
if ((delaymagic & DM_UID) == DM_EUID) {
(void)seteuid(uid);
- delaymagic =~ DM_EUID;
+ delaymagic &= ~DM_EUID;
}
#endif /* HAS_SETEUID */
if (delaymagic & DM_UID) {
#ifdef HAS_SETRGID
if ((delaymagic & DM_GID) == DM_RGID) {
(void)setrgid(gid);
- delaymagic =~ DM_RGID;
+ delaymagic &= ~DM_RGID;
}
#endif /* HAS_SETRGID */
#ifdef HAS_SETRESGID
#ifdef HAS_SETEGID
if ((delaymagic & DM_GID) == DM_EGID) {
(void)setegid(gid);
- delaymagic =~ DM_EGID;
+ delaymagic &= ~DM_EGID;
}
#endif /* HAS_SETEGID */
if (delaymagic & DM_GID) {
register REGEXP *rx = pm->op_pmregexp;
I32 gimme = GIMME;
STRLEN len;
+ I32 minmatch = 0;
if (op->op_flags & OPf_STACKED)
TARG = POPs;
rx->startp[0] = 0;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
MAGIC* mg = mg_find(TARG, 'g');
- if (mg && mg->mg_len >= 0)
+ if (mg && mg->mg_len >= 0) {
rx->endp[0] = rx->startp[0] = s + mg->mg_len;
+ minmatch = (mg->mg_flags & MGf_MINMATCH);
+ }
}
}
+ if (!rx->nparens && !global)
+ gimme = G_SCALAR; /* accidental array context? */
safebase = (gimme == G_ARRAY) || global;
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
SAVEINT(multiline);
t = s = rx->endp[0];
if (s > strend)
goto nope;
+ minmatch = (s == rx->startp[0]);
}
if (pm->op_pmshort) {
if (pm->op_pmflags & PMf_SCANFIRST) {
pm->op_pmshort = Nullsv; /* opt is being useless */
}
}
- if (!rx->nparens && !global) {
- gimme = G_SCALAR; /* accidental array context? */
- safebase = FALSE;
- }
- if (regexec(rx, s, strend, truebase, 0,
+ if (regexec(rx, s, strend, truebase, minmatch,
SvSCREAM(TARG) ? TARG : Nullsv,
safebase)) {
curpm = pm;
sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
mg = mg_find(TARG, 'g');
}
- mg->mg_len = rx->startp[0] ? rx->endp[0] - truebase : -1;
+ if (rx->startp[0]) {
+ mg->mg_len = rx->endp[0] - truebase;
+ if (rx->startp[0] == rx->endp[0])
+ mg->mg_flags |= MGf_MINMATCH;
+ else
+ mg->mg_flags &= ~MGf_MINMATCH;
+ }
+ else
+ mg->mg_len = -1;
}
RETPUSHYES;
}
if (cp[i] == '/') {
hasdir = isunix = 1;
break;
- }
+ }
if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
hasdir = 1;
break;
ok = (fputs(begin,tmpfp) != EOF);
}
if (cxt) (void)lib$find_file_end(&cxt);
- if (ok && sts != RMS$_NMF) ok = 0;
+ if (ok && sts != RMS$_NMF &&
+ sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
if (!ok) {
fp = NULL;
}
SP--;
}
if (!fp) {
- if (dowarn)
+ if (dowarn && !(IoFLAGS(io) & IOf_START))
warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
if (GIMME == G_SCALAR) {
(void)SvOK_off(TARG);
EXTEND(SP,1);
}
s = SvPV(TARG, len);
- if (!SvPOKp(TARG))
+ if (!SvPOKp(TARG) || SvREADONLY(TARG))
force_on_match = 1;
force_it:
} while (regexec(rx, s, strend, orig, s == m, Nullsv,
safebase));
sv_catpvn(dstr, s, strend - s);
- sv_replace(TARG, dstr);
+
+ SvPVX(TARG) = SvPVX(dstr);
+ SvCUR_set(TARG, SvCUR(dstr));
+ SvLEN_set(TARG, SvLEN(dstr));
+ SvPVX(dstr) = 0;
+ sv_free(dstr);
+
(void)SvPOK_only(TARG);
SvSETMAGIC(TARG);
PUSHs(sv_2mortal(newSViv((I32)iters)));
switch (SvTYPE(sv)) {
default:
if (!SvROK(sv)) {
+ char *sym;
+
if (sv == &sv_yes) /* unfound import, ignore */
RETURN;
if (!SvOK(sv))
DIE(no_usym, "a subroutine");
+ sym = SvPV(sv,na);
if (op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, "a subroutine");
- gv = gv_fetchpv(SvPV(sv, na), FALSE, SVt_PVCV);
- if (!gv)
- cv = 0;
- else
- cv = GvCV(gv);
+ DIE(no_symref, sym, "a subroutine");
+ cv = perl_get_cv(sym, TRUE);
break;
}
cv = (CV*)SvRV(sv);
if ((op->op_private & OPpDEREF_DB) && !CvXSUB(cv)) {
sv = GvSV(DBsub);
save_item(sv);
- gv = CvGV(cv);
- gv_efullname(sv,gv);
+ if (SvFLAGS(cv) & SVpcv_ANON) /* Is GV potentially non-unique? */
+ sv_setsv(sv, newRV((SV*)cv));
+ else {
+ gv = CvGV(cv);
+ gv_efullname(sv,gv);
+ }
cv = GvCV(DBsub);
if (!cv)
DIE("No DBsub routine");
stack_sp = stack_base + items;
}
else {
+ I32 markix = TOPMARK;
+
PUTBACK;
(void)(*CvXSUB(cv))(cv);
+
+ /* Enforce some sanity in scalar context. */
+ if (GIMME == G_SCALAR && ++markix != stack_sp - stack_base ) {
+ if (markix > stack_sp - stack_base)
+ *(stack_base + markix) = &sv_undef;
+ else
+ *(stack_base + markix) = *stack_sp;
+ stack_sp = stack_base + markix;
+ }
}
LEAVE;
return NORMAL;
if (CvDEPTH(cv) > AvFILL(padlist)) {
AV *av;
AV *newpad = newAV();
+ AV *oldpad = (AV*)AvARRAY(svp[CvDEPTH(cv)-1]);
I32 ix = AvFILL((AV*)svp[1]);
svp = AvARRAY(svp[0]);
- while (ix > 0) {
+ for ( ;ix > 0; ix--) {
if (svp[ix] != &sv_undef) {
- char *name = SvPVX(svp[ix]); /* XXX */
- if (*name == '@')
- av_store(newpad, ix--, sv = (SV*)newAV());
- else if (*name == '%')
- av_store(newpad, ix--, sv = (SV*)newHV());
- else
- av_store(newpad, ix--, sv = NEWSV(0,0));
- SvPADMY_on(sv);
+ char *name = SvPVX(svp[ix]);
+ if (SvFLAGS(svp[ix]) & SVf_FAKE) { /* outer lexical? */
+ av_store(newpad, ix,
+ SvREFCNT_inc(AvARRAY(oldpad)[ix]) );
+ }
+ else { /* our own lexical */
+ if (*name == '@')
+ av_store(newpad, ix, sv = (SV*)newAV());
+ else if (*name == '%')
+ av_store(newpad, ix, sv = (SV*)newHV());
+ else
+ av_store(newpad, ix, sv = NEWSV(0,0));
+ SvPADMY_on(sv);
+ }
}
else {
- av_store(newpad, ix--, sv = NEWSV(0,0));
+ av_store(newpad, ix, sv = NEWSV(0,0));
SvPADTMP_on(sv);
}
}
{
dSP;
SV** svp;
- I32 elem = POPi - curcop->cop_arybase;
+ I32 elem = POPi;
AV *av = (AV*)POPs;
I32 lval = op->op_flags & OPf_MOD;
+ if (elem > 0)
+ elem -= curcop->cop_arybase;
if (SvTYPE(av) != SVt_PVAV)
RETPUSHUNDEF;
svp = av_fetch(av, elem, lval);
SETs(gv);
RETURN;
}
+ *(stack_base + TOPMARK + 1) = iogv;
}
if (!ob || !SvOBJECT(ob)) {
if (!cv) {
if (fgv) {
- SV *tmpstr = sv_newmortal();
- gv_efullname(tmpstr, gv);
- DIE("Undefined format \"%s\" called",SvPVX(tmpstr));
+ SV *tmpsv = sv_newmortal();
+ gv_efullname(tmpsv, gv);
+ DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
}
DIE("Not a format reference");
}
+ IoFLAGS(io) &= ~IOf_DIDTOP;
return doform(cv,gv,op->op_next);
}
IoFMT_NAME(io) = savepv(GvNAME(gv));
sprintf(tmpbuf, "%s_TOP", IoFMT_NAME(io));
topgv = gv_fetchpv(tmpbuf,FALSE, SVt_PVFM);
- if ((topgv && GvFORM(topgv)) ||
+ if ((topgv && GvFORM(topgv)) ||
!gv_fetchpv("top",FALSE,SVt_PVFM))
IoTOP_NAME(io) = savepv(tmpbuf);
else
}
IoTOP_GV(io) = topgv;
}
+ if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
+ I32 lines = IoLINES_LEFT(io);
+ char *s = SvPVX(formtarget);
+ while (lines-- > 0) {
+ s = strchr(s, '\n');
+ if (!s)
+ break;
+ s++;
+ }
+ if (s) {
+ fwrite1(SvPVX(formtarget), s - SvPVX(formtarget), 1, ofp);
+ sv_chop(formtarget, s);
+ FmLINES(formtarget) -= IoLINES_LEFT(io);
+ }
+ }
if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
fwrite1(SvPVX(formfeed), SvCUR(formfeed), 1, ofp);
IoLINES_LEFT(io) = IoPAGE_LEN(io);
IoPAGE(io)++;
formtarget = toptarget;
+ IoFLAGS(io) |= IOf_DIDTOP;
return doform(GvFORM(IoTOP_GV(io)),gv,op);
}
else {
FmLINES(formtarget) = 0;
SvCUR_set(formtarget, 0);
+ *SvEND(formtarget) = '\0';
if (IoFLAGS(io) & IOf_FLUSH)
(void)fflush(fp);
PUSHs(&sv_yes);
else
gv = defoutgv;
if (!(io = GvIO(gv))) {
- if (dowarn)
- warn("Filehandle %s never opened", GvNAME(gv));
- errno = EBADF;
+ if (dowarn) {
+ gv_fullname(sv,gv);
+ warn("Filehandle %s never opened", SvPV(sv,na));
+ }
+ SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
if (dowarn) {
+ gv_fullname(sv,gv);
if (IoIFP(io))
- warn("Filehandle %s opened only for input", GvNAME(gv));
+ warn("Filehandle %s opened only for input", SvPV(sv,na));
else
- warn("printf on closed filehandle %s", GvNAME(gv));
+ warn("printf on closed filehandle %s", SvPV(sv,na));
}
- errno = EBADF;
+ SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
}
else {
char *buffer;
int length;
int bufsize;
- SV *bufstr;
+ SV *bufsv;
STRLEN blen;
gv = (GV*)*++MARK;
if (!gv)
goto say_undef;
- bufstr = *++MARK;
- buffer = SvPV_force(bufstr, blen);
+ bufsv = *++MARK;
+ buffer = SvPV_force(bufsv, blen);
length = SvIVx(*++MARK);
if (length < 0)
DIE("Negative length");
- errno = 0;
+ SETERRNO(0,0);
if (MARK < SP)
offset = SvIVx(*++MARK);
else
#ifdef HAS_SOCKET
if (op->op_type == OP_RECV) {
bufsize = sizeof buf;
- buffer = SvGROW(bufstr, length+1);
+ buffer = SvGROW(bufsv, length+1);
length = recvfrom(fileno(IoIFP(io)), buffer, length, offset,
(struct sockaddr *)buf, &bufsize);
if (length < 0)
RETPUSHUNDEF;
- SvCUR_set(bufstr, length);
- *SvEND(bufstr) = '\0';
- (void)SvPOK_only(bufstr);
- SvSETMAGIC(bufstr);
+ SvCUR_set(bufsv, length);
+ *SvEND(bufsv) = '\0';
+ (void)SvPOK_only(bufsv);
+ SvSETMAGIC(bufsv);
if (tainting)
- sv_magic(bufstr, Nullsv, 't', Nullch, 0);
+ sv_magic(bufsv, Nullsv, 't', Nullch, 0);
SP = ORIGMARK;
sv_setpvn(TARG, buf, bufsize);
PUSHs(TARG);
if (op->op_type == OP_RECV)
DIE(no_sock_func, "recv");
#endif
- buffer = SvGROW(bufstr, length+offset+1);
+ buffer = SvGROW(bufsv, length+offset+1);
if (op->op_type == OP_SYSREAD) {
length = read(fileno(IoIFP(io)), buffer+offset, length);
}
length = fread(buffer+offset, 1, length, IoIFP(io));
if (length < 0)
goto say_undef;
- SvCUR_set(bufstr, length+offset);
- *SvEND(bufstr) = '\0';
- (void)SvPOK_only(bufstr);
- SvSETMAGIC(bufstr);
+ SvCUR_set(bufsv, length+offset);
+ *SvEND(bufsv) = '\0';
+ (void)SvPOK_only(bufsv);
+ SvSETMAGIC(bufsv);
if (tainting)
- sv_magic(bufstr, Nullsv, 't', Nullch, 0);
+ sv_magic(bufsv, Nullsv, 't', Nullch, 0);
SP = ORIGMARK;
PUSHi(length);
RETURN;
GV *gv;
IO *io;
int offset;
- SV *bufstr;
+ SV *bufsv;
char *buffer;
int length;
STRLEN blen;
gv = (GV*)*++MARK;
if (!gv)
goto say_undef;
- bufstr = *++MARK;
- buffer = SvPV(bufstr, blen);
+ bufsv = *++MARK;
+ buffer = SvPV(bufsv, blen);
length = SvIVx(*++MARK);
if (length < 0)
DIE("Negative length");
- errno = 0;
+ SETERRNO(0,0);
io = GvIO(gv);
if (!io || !IoIFP(io)) {
length = -1;
int result = 1;
GV *tmpgv;
- errno = 0;
+ SETERRNO(0,0);
#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE)
#ifdef HAS_TRUNCATE
if (op->op_flags & OPf_SPECIAL) {
if (result)
RETPUSHYES;
if (!errno)
- errno = EBADF;
+ SETERRNO(EBADF,RMS$_IFI);
RETPUSHUNDEF;
#else
DIE("truncate not implemented");
PP(pp_ioctl)
{
dSP; dTARGET;
- SV *argstr = POPs;
+ SV *argsv = POPs;
unsigned int func = U_I(POPn);
int optype = op->op_type;
char *s;
GV *gv = (GV*)POPs;
IO *io = GvIOn(gv);
- if (!io || !argstr || !IoIFP(io)) {
- errno = EBADF; /* well, sort of... */
+ if (!io || !argsv || !IoIFP(io)) {
+ SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
RETPUSHUNDEF;
}
- if (SvPOK(argstr) || !SvNIOK(argstr)) {
+ if (SvPOK(argsv) || !SvNIOK(argsv)) {
STRLEN len;
- s = SvPV_force(argstr, len);
+ s = SvPV_force(argsv, len);
retval = IOCPARM_LEN(func);
if (len < retval) {
- s = Sv_Grow(argstr, retval+1);
- SvCUR_set(argstr, retval);
+ s = Sv_Grow(argsv, retval+1);
+ SvCUR_set(argsv, retval);
}
- s[SvCUR(argstr)] = 17; /* a little sanity check here */
+ s[SvCUR(argsv)] = 17; /* a little sanity check here */
}
else {
- retval = SvIV(argstr);
+ retval = SvIV(argsv);
#ifdef DOSISH
s = (char*)(long)retval; /* ouch */
#else
# endif
#endif
- if (SvPOK(argstr)) {
- if (s[SvCUR(argstr)] != 17)
+ if (SvPOK(argsv)) {
+ if (s[SvCUR(argsv)] != 17)
DIE("Possible memory corruption: %s overflowed 3rd argument",
op_name[optype]);
- s[SvCUR(argstr)] = 0; /* put our null back */
- SvSETMAGIC(argstr); /* Assume it has changed */
+ s[SvCUR(argsv)] = 0; /* put our null back */
+ SvSETMAGIC(argsv); /* Assume it has changed */
}
if (retval == -1)
gv = (GV*)POPs;
if (!gv) {
- errno = EBADF;
+ SETERRNO(EBADF,LIB$_INVARG);
RETPUSHUNDEF;
}
{
dSP;
#ifdef HAS_SOCKET
- SV *addrstr = POPs;
+ SV *addrsv = POPs;
char *addr;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
if (!io || !IoIFP(io))
goto nuts;
- addr = SvPV(addrstr, len);
+ addr = SvPV(addrsv, len);
TAINT_PROPER("bind");
if (bind(fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
RETPUSHYES;
nuts:
if (dowarn)
warn("bind() on closed fd");
- errno = EBADF;
+ SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
DIE(no_sock_func, "bind");
{
dSP;
#ifdef HAS_SOCKET
- SV *addrstr = POPs;
+ SV *addrsv = POPs;
char *addr;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
if (!io || !IoIFP(io))
goto nuts;
- addr = SvPV(addrstr, len);
+ addr = SvPV(addrsv, len);
TAINT_PROPER("connect");
if (connect(fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
RETPUSHYES;
nuts:
if (dowarn)
warn("connect() on closed fd");
- errno = EBADF;
+ SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
DIE(no_sock_func, "connect");
nuts:
if (dowarn)
warn("listen() on closed fd");
- errno = EBADF;
+ SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
DIE(no_sock_func, "listen");
PP(pp_accept)
{
+ struct sockaddr_in saddr; /* use a struct to avoid alignment problems */
dSP; dTARGET;
#ifdef HAS_SOCKET
GV *ngv;
GV *ggv;
register IO *nstio;
register IO *gstio;
- int len = sizeof buf;
+ int len = sizeof saddr;
int fd;
ggv = (GV*)POPs;
if (IoIFP(nstio))
do_close(ngv, FALSE);
- fd = accept(fileno(IoIFP(gstio)), (struct sockaddr *)buf, &len);
+ fd = accept(fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
if (fd < 0)
goto badexit;
IoIFP(nstio) = fdopen(fd, "r");
goto badexit;
}
- PUSHp(buf, len);
+ PUSHp((char *)&saddr, len);
RETURN;
nuts:
if (dowarn)
warn("accept() on closed fd");
- errno = EBADF;
+ SETERRNO(EBADF,SS$_IVCHAN);
badexit:
RETPUSHUNDEF;
nuts:
if (dowarn)
warn("shutdown() on closed fd");
- errno = EBADF;
+ SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
DIE(no_sock_func, "shutdown");
unsigned int lvl;
GV *gv;
register IO *io;
+ int aint;
if (optype == OP_GSOCKOPT)
sv = sv_2mortal(NEWSV(22, 257));
fd = fileno(IoIFP(io));
switch (optype) {
case OP_GSOCKOPT:
- SvGROW(sv, 256);
+ SvGROW(sv, 257);
(void)SvPOK_only(sv);
- if (getsockopt(fd, lvl, optname, SvPVX(sv), (int*)&SvCUR(sv)) < 0)
+ SvCUR_set(sv,256);
+ *SvEND(sv) ='\0';
+ aint = SvCUR(sv);
+ if (getsockopt(fd, lvl, optname, SvPVX(sv), &aint) < 0)
goto nuts2;
+ SvCUR_set(sv,aint);
+ *SvEND(sv) ='\0';
PUSHs(sv);
break;
case OP_SSOCKOPT: {
- int aint;
STRLEN len = 0;
char *buf = 0;
if (SvPOKp(sv))
nuts:
if (dowarn)
warn("[gs]etsockopt() on closed fd");
- errno = EBADF;
+ SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
int fd;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
+ int aint;
if (!io || !IoIFP(io))
goto nuts;
sv = sv_2mortal(NEWSV(22, 257));
- SvCUR_set(sv, 256);
- SvPOK_on(sv);
+ (void)SvPOK_only(sv);
+ SvCUR_set(sv,256);
+ *SvEND(sv) ='\0';
+ aint = SvCUR(sv);
fd = fileno(IoIFP(io));
switch (optype) {
case OP_GETSOCKNAME:
- if (getsockname(fd, (struct sockaddr *)SvPVX(sv), (int*)&SvCUR(sv)) < 0)
+ if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &aint) < 0)
goto nuts2;
break;
case OP_GETPEERNAME:
- if (getpeername(fd, (struct sockaddr *)SvPVX(sv), (int*)&SvCUR(sv)) < 0)
+ if (getpeername(fd, (struct sockaddr *)SvPVX(sv), &aint) < 0)
goto nuts2;
break;
}
+ SvCUR_set(sv,aint);
+ *SvEND(sv) ='\0';
PUSHs(sv);
RETURN;
nuts:
if (dowarn)
warn("get{sock, peer}name() on closed fd");
- errno = EBADF;
+ SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
if (op->op_flags & OPf_REF) {
tmpgv = cGVOP->op_gv;
+ do_fstat:
if (tmpgv != defgv) {
laststype = OP_STAT;
statgv = tmpgv;
max = 0;
}
else {
- sv_setpv(statname, POPp);
+ SV* sv = POPs;
+ if (SvTYPE(sv) == SVt_PVGV) {
+ tmpgv = (GV*)sv;
+ goto do_fstat;
+ }
+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+ tmpgv = (GV*)SvRV(sv);
+ goto do_fstat;
+ }
+ sv_setpv(statname, SvPV(sv,na));
statgv = Nullgv;
#ifdef HAS_LSTAT
laststype = op->op_type;
if (dowarn)
warn("Test on unopened file <%s>",
GvENAME(cGVOP->op_gv));
- errno = EBADF;
+ SETERRNO(EBADF,RMS$_IFI);
RETPUSHUNDEF;
}
}
}
TAINT_PROPER("chdir");
PUSHi( chdir(tmps) >= 0 );
+#ifdef VMS
+ /* Clear the DEFAULT element of ENV so we'll get the new value
+ * in the future. */
+ hv_delete(GvHVn(envgv),"DEFAULT",7);
+#endif
RETURN;
}
return 0;
#endif
}
- errno = 0;
+ SETERRNO(0,0);
#ifndef EACCES
#define EACCES EPERM
#endif
if (instr(mybuf, "cannot make"))
- errno = EEXIST;
+ SETERRNO(EEXIST,RMS$_FEX);
else if (instr(mybuf, "existing file"))
- errno = EEXIST;
+ SETERRNO(EEXIST,RMS$_FEX);
else if (instr(mybuf, "ile exists"))
- errno = EEXIST;
+ SETERRNO(EEXIST,RMS$_FEX);
else if (instr(mybuf, "non-exist"))
- errno = ENOENT;
+ SETERRNO(ENOENT,RMS$_FNF);
else if (instr(mybuf, "does not exist"))
- errno = ENOENT;
+ SETERRNO(ENOENT,RMS$_FNF);
else if (instr(mybuf, "not empty"))
- errno = EBUSY;
+ SETERRNO(EBUSY,SS$_DEVOFFLINE);
else if (instr(mybuf, "cannot access"))
- errno = EACCES;
+ SETERRNO(EACCES,RMS$_PRV);
else
- errno = EPERM;
+ SETERRNO(EPERM,RMS$_PRV);
return 0;
}
else { /* some mkdirs return no failure indication */
if (op->op_type == OP_RMDIR)
anum = !anum;
if (anum)
- errno = 0;
+ SETERRNO(0,0);
else
- errno = EACCES; /* a guess */
+ SETERRNO(EACCES,RMS$_PRV); /* a guess */
}
return anum;
}
RETPUSHYES;
nope:
if (!errno)
- errno = EBADF;
+ SETERRNO(EBADF,RMS$_DIR);
RETPUSHUNDEF;
#else
DIE(no_dir_func, "opendir");
nope:
if (!errno)
- errno = EBADF;
+ SETERRNO(EBADF,RMS$_ISI);
if (GIMME == G_ARRAY)
RETURN;
else
RETURN;
nope:
if (!errno)
- errno = EBADF;
+ SETERRNO(EBADF,RMS$_ISI);
RETPUSHUNDEF;
#else
DIE(no_dir_func, "telldir");
RETPUSHYES;
nope:
if (!errno)
- errno = EBADF;
+ SETERRNO(EBADF,RMS$_ISI);
RETPUSHUNDEF;
#else
DIE(no_dir_func, "seekdir");
RETPUSHYES;
nope:
if (!errno)
- errno = EBADF;
+ SETERRNO(EBADF,RMS$_ISI);
RETPUSHUNDEF;
#else
DIE(no_dir_func, "rewinddir");
#ifdef VOID_CLOSEDIR
closedir(IoDIRP(io));
#else
- if (closedir(IoDIRP(io)) < 0)
+ if (closedir(IoDIRP(io)) < 0) {
+ IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
goto nope;
+ }
#endif
IoDIRP(io) = 0;
RETPUSHYES;
nope:
if (!errno)
- errno = EBADF;
+ SETERRNO(EBADF,RMS$_IFI);
RETPUSHUNDEF;
#else
DIE(no_dir_func, "closedir");
if (childpid > 0)
pidgone(childpid, argflags);
value = (I32)childpid;
- statusvalue = (U16)argflags;
+ statusvalue = FIXSTATUS(argflags);
PUSHi(value);
RETURN;
#else
childpid = TOPi;
childpid = wait4pid(childpid, &argflags, optype);
value = (I32)childpid;
- statusvalue = (U16)argflags;
+ statusvalue = FIXSTATUS(argflags);
SETi(value);
RETURN;
#else
if (childpid > 0) {
ihand = signal(SIGINT, SIG_IGN);
qhand = signal(SIGQUIT, SIG_IGN);
- result = wait4pid(childpid, &status, 0);
+ do {
+ result = wait4pid(childpid, &status, 0);
+ } while (result == -1 && errno == EINTR);
(void)signal(SIGINT, ihand);
(void)signal(SIGQUIT, qhand);
- statusvalue = (U16)status;
+ statusvalue = FIXSTATUS(status);
if (result < 0)
value = -1;
else {
PUSHi(value);
RETURN;
#else
- pp_semget(ARGS);
+ return pp_semget(ARGS);
#endif
}
PUSHi(value);
RETURN;
#else
- pp_semget(ARGS);
+ return pp_semget(ARGS);
#endif
}
PUSHi(value);
RETURN;
#else
- pp_semget(ARGS);
+ return pp_semget(ARGS);
#endif
}
}
RETURN;
#else
- pp_semget(ARGS);
+ return pp_semget(ARGS);
#endif
}
PUSHi(value);
RETURN;
#else
- pp_semget(ARGS);
+ return pp_semget(ARGS);
#endif
}
}
else if (which == OP_GHBYADDR) {
int addrtype = POPi;
- SV *addrstr = POPs;
+ SV *addrsv = POPs;
STRLEN addrlen;
- char *addr = SvPV(addrstr, addrlen);
+ char *addr = SvPV(addrsv, addrlen);
hent = gethostbyaddr(addr, addrlen, addrtype);
}
#ifdef HOST_NOT_FOUND
if (!hent)
- statusvalue = (U16)h_errno & 0xffff;
+ statusvalue = FIXSTATUS(h_errno);
#endif
if (GIMME != G_ARRAY) {
unsigned long a[20];
register I32 i = 0;
I32 retval = -1;
+ MAGIC *mg;
if (tainting) {
while (++MARK <= SP) {
- if (SvGMAGICAL(*MARK) && SvSMAGICAL(*MARK) && mg_find(*MARK, 't'))
+ if (SvGMAGICAL(*MARK) && SvSMAGICAL(*MARK) &&
+ (mg = mg_find(*MARK, 't')) && mg->mg_len & 1)
tainted = TRUE;
}
MARK = ORIGMARK;
while (++MARK <= SP) {
if (SvNIOK(*MARK) || !i)
a[i++] = SvIV(*MARK);
- else
- a[i++] = (unsigned long)SvPVX(*MARK);
+ else if (*MARK == &sv_undef)
+ a[i++] = 0;
+ else
+ a[i++] = (unsigned long)SvPV_force(*MARK, na);
if (i > 15)
break;
}
#endif
#ifdef OVERLOAD
SV* amagic_call _((SV* left,SV* right,int method,int dir));
+bool Gv_AMupdate _((HV* stash));
#endif /* OVERLOAD */
OP* append_elem _((I32 optype, OP* head, OP* tail));
OP* append_list _((I32 optype, LISTOP* first, LISTOP* last));
OP* convert _((I32 optype, I32 flags, OP* op));
char* cpytill _((char* to, char* from, char* fromend, int delim, I32* retlen));
void croak _((char* pat,...)) __attribute__((format(printf,1,2),noreturn));
+CV* cv_clone _((CV* proto));
void cv_undef _((CV* cv));
#ifdef DEBUGGING
void cx_dump _((CONTEXT* cs));
void do_vop _((I32 optype, SV* sv, SV* left, SV* right));
void dump_all _((void));
void dump_eval _((void));
-#ifdef NOTDEF /* See util.c */
+#ifdef DUMP_FDS /* See util.c */
int dump_fds _((char* s));
#endif
void dump_form _((GV* gv));
void he_free _((HE* hent));
void hoistmust _((PMOP* pm));
void hv_clear _((HV* tb));
-SV* hv_delete _((HV* tb, char* key, U32 klen));
+SV* hv_delete _((HV* tb, char* key, U32 klen, I32 flags));
bool hv_exists _((HV* tb, char* key, U32 klen));
SV** hv_fetch _((HV* tb, char* key, U32 klen, I32 lval));
I32 hv_iterinit _((HV* tb));
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
char* my_bzero _((char* loc, I32 len));
#endif
-void my_exit _((I32 status)) __attribute__((noreturn));
+void my_exit _((U32 status)) __attribute__((noreturn));
#ifdef USE_MY_FMOD
double my_fmod _((double x, double y));
#endif
I32 my_stat _((void));
#ifdef MYSWAP
short my_swap _((short s));
+long my_htonl _((long l));
+long my_ntohl _((long l));
#endif
void my_unexec _((void));
OP* newANONLIST _((OP* op));
I32 perl_callsv _((SV* sv, I32 sp, I32 gimme, I32 hasargs, I32 numargs));
#endif
void perl_construct _((PerlInterpreter* sv_interp));
-void perl_destruct _((PerlInterpreter* sv_interp, int destruct_level));
+void perl_destruct _((PerlInterpreter* sv_interp));
void perl_free _((PerlInterpreter* sv_interp));
SV* perl_get_sv _((char* name, I32 create));
AV* perl_get_av _((char* name, I32 create));
unsigned long scan_hex _((char* start, I32 len, I32* retlen));
char* scan_num _((char* s));
unsigned long scan_oct _((char* start, I32 len, I32* retlen));
-#ifdef NOTDEF /* See toke.c pp_ctl.c and op.c */
-void scan_prefix _((PMOP* pm, char* string, I32 len));
-#endif
OP* scope _((OP* o));
char* screaminstr _((SV* bigsv, SV* littlesv));
#ifndef VMS
}
else /* single branch is ok */
scan = NEXTOPER(scan);
+ continue;
}
if (OP(scan) == UNLESSM) {
curback = -30000;
scan = regnext(scan);
+ continue;
}
if (OP(scan) == EXACTLY) {
char *t;
if (paren) {
if (*regparse == '?') {
regparse++;
- paren = *nextchar();
+ paren = *regparse++;
ret = NULL;
switch (paren) {
case ':':
while (*regparse && *regparse != ')')
regparse++;
if (*regparse != ')')
- croak("Sequence (?#... not terminated", *regparse);
+ croak("Sequence (?#... not terminated");
nextchar();
*flagp = TRYAGAIN;
return NULL;
char* retval = regparse++;
if (regflags & PMf_EXTENDED) {
- while (isSPACE(*regparse))
- regparse++;
+ for (;;) {
+ if (isSPACE(*regparse)) {
+ regparse++;
+ continue;
+ }
+ else if (*regparse == '(' && regparse[1] == '?' &&
+ regparse[2] == '#') {
+ while (*regparse && *regparse != ')')
+ regparse++;
+ regparse++;
+ continue;
+ }
+ else if (*regparse == '#') {
+ while (*regparse && *regparse != '\n')
+ regparse++;
+ regparse++;
+ continue;
+ }
+ break;
+ }
}
return retval;
}
if (OP(next) != BRANCH) /* No choice. */
next = NEXTOPER(scan);/* Avoid recursion. */
else {
+ int lastparen = *reglastparen;
do {
reginput = locinput;
if (regmatch(NEXTOPER(scan)))
return 1;
+ for (n = *reglastparen; n > lastparen; n--)
+ regendp[n] = 0;
+ *reglastparen = n;
+
#ifdef REGALIGN
/*SUPPRESS 560*/
if (n = NEXT(scan))
if (regmatch(next))
return 1;
/* Couldn't or didn't -- back up. */
+ reginput = locinput + ln;
if (regrepeat(scan, 1)) {
ln++;
reginput = locinput + ln;
{
stack_sp = sp;
av_extend(stack, (p - stack_base) + (n) + 128);
-#ifdef NOTDEF
- stack_sp = AvARRAY(stack) + (sp - stack_base);
- stack_base = AvARRAY(stack);
- stack_max = stack_base + AvMAX(stack) - 1;
-#endif
return stack_sp;
}
if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
sv_upgrade(sv, SvTYPE(osv));
if (SvGMAGICAL(osv)) {
+ MAGIC* mg;
+ bool oldtainted = tainted;
mg_get(osv);
+ if (tainting && tainted && (mg = mg_find(osv, 't'))) {
+ SAVESPTR(mg->mg_obj);
+ mg->mg_obj = osv;
+ }
SvFLAGS(osv) |= (SvFLAGS(osv) &
(SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ tainted = oldtainted;
}
SvMAGIC(sv) = SvMAGIC(osv);
SvFLAGS(sv) |= SvMAGICAL(osv);
- localizing = TRUE;
+ localizing = 1;
SvSETMAGIC(sv);
- localizing = FALSE;
+ localizing = 0;
}
return sv;
}
if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
sv_upgrade(sv, SvTYPE(osv));
if (SvGMAGICAL(osv)) {
+ MAGIC* mg;
+ bool oldtainted = tainted;
mg_get(osv);
+ if (tainting && tainted && (mg = mg_find(osv, 't'))) {
+ SAVESPTR(mg->mg_obj);
+ mg->mg_obj = osv;
+ }
SvFLAGS(osv) |= (SvFLAGS(osv) &
(SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ tainted = oldtainted;
}
SvMAGIC(sv) = SvMAGIC(osv);
SvFLAGS(sv) |= SvMAGICAL(osv);
- localizing = TRUE;
+ localizing = 1;
SvSETMAGIC(sv);
- localizing = FALSE;
+ localizing = 0;
}
return sv;
}
value = (SV*)SSPOPPTR;
sv = (SV*)SSPOPPTR;
sv_replace(sv,value);
- localizing = TRUE;
+ localizing = 2;
SvSETMAGIC(sv);
- localizing = FALSE;
+ localizing = 0;
break;
case SAVEt_SV: /* scalar reference */
value = (SV*)SSPOPPTR;
gv = (GV*)SSPOPPTR;
sv = GvSV(gv);
- if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) && SvTYPE(sv) != SVt_PVGV){
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
+ SvTYPE(sv) != SVt_PVGV)
+ {
(void)SvUPGRADE(value, SvTYPE(sv));
SvMAGIC(value) = SvMAGIC(sv);
SvFLAGS(value) |= SvMAGICAL(sv);
}
SvREFCNT_dec(sv);
GvSV(gv) = value;
- localizing = TRUE;
+ localizing = 2;
SvSETMAGIC(value);
- localizing = FALSE;
+ localizing = 0;
break;
case SAVEt_SVREF: /* scalar reference */
ptr = SSPOPPTR;
sv = *(SV**)ptr;
value = (SV*)SSPOPPTR;
- if (SvTYPE(sv) >= SVt_PVMG && SvTYPE(sv) != SVt_PVGV) {
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
+ SvTYPE(sv) != SVt_PVGV)
+ {
(void)SvUPGRADE(value, SvTYPE(sv));
SvMAGIC(value) = SvMAGIC(sv);
SvFLAGS(value) |= SvMAGICAL(sv);
}
SvREFCNT_dec(sv);
*(SV**)ptr = value;
- localizing = TRUE;
+ localizing = 2;
SvSETMAGIC(value);
- localizing = FALSE;
+ localizing = 0;
break;
case SAVEt_AV: /* array reference */
av = (AV*)SSPOPPTR;
ptr = SSPOPPTR;
hv = (HV*)ptr;
ptr = SSPOPPTR;
- hv_delete(hv, (char*)ptr, (U32)SSPOPINT);
+ (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
Safefree(ptr);
break;
case SAVEt_DESTRUCTOR:
} \
else \
sv = more_sv();
-#endif
static SV*
new_sv()
sv_arenaroot = sv_root;
return new_sv();
}
+#endif
void
sv_report_used()
magic = 0;
stash = 0;
del_XPV(SvANY(sv));
+ if (mt <= SVt_IV)
+ mt = SVt_PVIV;
+ else if (mt == SVt_NV)
+ mt = SVt_PVNV;
break;
case SVt_PVIV:
nv = 0.0;
break;
case SVt_PVCV:
SvANY(sv) = new_XPVCV();
+ Zero(SvANY(sv), 1, XPVCV);
SvPVX(sv) = pv;
SvCUR(sv) = cur;
SvLEN(sv) = len;
SvNVX(sv) = nv;
SvMAGIC(sv) = magic;
SvSTASH(sv) = stash;
- CvSTASH(sv) = 0;
- CvSTART(sv) = 0;
- CvROOT(sv) = 0;
- CvXSUB(sv) = 0;
- CvXSUBANY(sv).any_ptr = 0;
- CvFILEGV(sv) = 0;
- CvDEPTH(sv) = 0;
- CvPADLIST(sv) = 0;
- CvOLDSTYLE(sv) = 0;
break;
case SVt_PVGV:
SvANY(sv) = new_XPVGV();
break;
case SVt_PVFM:
SvANY(sv) = new_XPVFM();
+ Zero(SvANY(sv), 1, XPVFM);
SvPVX(sv) = pv;
SvCUR(sv) = cur;
SvLEN(sv) = len;
SvNVX(sv) = nv;
SvMAGIC(sv) = magic;
SvSTASH(sv) = stash;
- FmLINES(sv) = 0;
break;
case SVt_PVIO:
SvANY(sv) = new_XPVIO();
+ Zero(SvANY(sv), 1, XPVIO);
SvPVX(sv) = pv;
SvCUR(sv) = cur;
SvLEN(sv) = len;
SvNVX(sv) = nv;
SvMAGIC(sv) = magic;
SvSTASH(sv) = stash;
- IoIFP(sv) = 0;
- IoOFP(sv) = 0;
- IoDIRP(sv) = 0;
- IoLINES(sv) = 0;
- IoPAGE(sv) = 0;
IoPAGE_LEN(sv) = 60;
- IoLINES_LEFT(sv)= 0;
- IoTOP_NAME(sv) = 0;
- IoTOP_GV(sv) = 0;
- IoFMT_NAME(sv) = 0;
- IoFMT_GV(sv) = 0;
- IoBOTTOM_NAME(sv)= 0;
- IoBOTTOM_GV(sv) = 0;
- IoSUBPROCESS(sv)= 0;
- IoTYPE(sv) = 0;
- IoFLAGS(sv) = 0;
break;
}
SvFLAGS(sv) &= ~SVTYPEMASK;
mg_get(sv);
if (SvIOKp(sv))
return SvIVX(sv);
- if (SvNOKp(sv))
- return I_V(SvNVX(sv));
+ if (SvNOKp(sv)) {
+ if (SvNVX(sv) < 0.0)
+ return I_V(SvNVX(sv));
+ else
+ return (IV)(UV)SvNVX(sv);
+ }
if (SvPOKp(sv) && SvLEN(sv)) {
if (dowarn && !looks_like_number(sv))
not_a_number(sv);
return (IV)SvRV(sv);
}
if (SvREADONLY(sv)) {
- if (SvNOK(sv))
- return I_V(SvNVX(sv));
- if (SvPOK(sv) && SvLEN(sv)) {
+ if (SvNOKp(sv)) {
+ if (SvNVX(sv) < 0.0)
+ return I_V(SvNVX(sv));
+ else
+ return (IV)(UV)SvNVX(sv);
+ }
+ if (SvPOKp(sv) && SvLEN(sv)) {
if (dowarn && !looks_like_number(sv))
not_a_number(sv);
return (IV)atol(SvPVX(sv));
sv_upgrade(sv, SVt_PVNV);
break;
}
- if (SvNOK(sv))
- SvIVX(sv) = I_V(SvNVX(sv));
- else if (SvPOK(sv) && SvLEN(sv)) {
+ if (SvNOKp(sv)) {
+ if (SvNVX(sv) < 0.0)
+ SvIVX(sv) = I_V(SvNVX(sv));
+ else
+ SvIVX(sv) = (IV)(UV)SvNVX(sv);
+ }
+ else if (SvPOKp(sv) && SvLEN(sv)) {
if (dowarn && !looks_like_number(sv))
not_a_number(sv);
SvIVX(sv) = (IV)atol(SvPVX(sv));
if (SvNOKp(sv))
return SvNVX(sv);
if (SvPOKp(sv) && SvLEN(sv)) {
- if (dowarn && !SvIOK(sv) && !looks_like_number(sv))
+ if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
return atof(SvPVX(sv));
}
return (double)(unsigned long)SvRV(sv);
}
if (SvREADONLY(sv)) {
- if (SvPOK(sv) && SvLEN(sv)) {
- if (dowarn && !SvIOK(sv) && !looks_like_number(sv))
+ if (SvPOKp(sv) && SvLEN(sv)) {
+ if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
return atof(SvPVX(sv));
}
- if (SvIOK(sv))
+ if (SvIOKp(sv))
return (double)SvIVX(sv);
if (dowarn)
warn(warn_uninit);
}
else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
- if (SvIOK(sv) &&
- (!SvPOK(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
+ if (SvIOKp(sv) &&
+ (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
{
SvNVX(sv) = (double)SvIVX(sv);
}
- else if (SvPOK(sv) && SvLEN(sv)) {
- if (dowarn && !SvIOK(sv) && !looks_like_number(sv))
+ else if (SvPOKp(sv) && SvLEN(sv)) {
+ if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SvNVX(sv) = atof(SvPVX(sv));
}
return s;
}
if (SvREADONLY(sv)) {
- if (SvIOK(sv)) {
+ if (SvIOKp(sv)) {
(void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
goto tokensave;
}
- if (SvNOK(sv)) {
+ if (SvNOKp(sv)) {
Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
goto tokensave;
}
}
if (!SvUPGRADE(sv, SVt_PV))
return 0;
- if (SvNOK(sv)) {
+ if (SvNOKp(sv)) {
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
SvGROW(sv, 28);
s--;
#endif
}
- else if (SvIOK(sv)) {
+ else if (SvIOKp(sv)) {
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
SvGROW(sv, 11);
GvGP(dstr) = gp_ref(GvGP(sstr));
SvTAINT(dstr);
GvFLAGS(dstr) &= ~GVf_INTRO; /* one-shot flag */
+ SvMULTI_on(dstr);
return;
}
/* FALL THROUGH */
case SVt_PVCV:
if (intro)
SAVESPTR(GvCV(dstr));
- else
- dref = (SV*)GvCV(dstr);
+ else {
+ CV* cv = GvCV(dstr);
+ dref = (SV*)cv;
+ if (dowarn && cv && sref != dref &&
+ !GvCVGEN((GV*)dstr) &&
+ (CvROOT(cv) || CvXSUB(cv)) )
+ warn("Subroutine %s redefined", GvENAME((GV*)dstr));
+ }
GvFLAGS(dstr) |= GVf_IMPORTED;
GvCV(dstr) = (CV*)sref;
break;
register char *ptr;
register STRLEN len;
{
+ assert(len >= 0);
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv) && curcop != &compiling)
croak(no_modify);
register STRLEN len;
{
STRLEN tlen;
- char *s;
+ char *junk;
- s = SvPV_force(sv, tlen);
+ junk = SvPV_force(sv, tlen);
SvGROW(sv, tlen + len + 1);
Move(ptr,SvPVX(sv)+tlen,len,char);
SvCUR(sv) += len;
{
register STRLEN len;
STRLEN tlen;
- char *s;
+ char *junk;
if (!ptr)
return;
- s = SvPV_force(sv, tlen);
+ junk = SvPV_force(sv, tlen);
len = strlen(ptr);
SvGROW(sv, tlen + len + 1);
Move(ptr,SvPVX(sv)+tlen,len+1,char);
if (SvREADONLY(sv) && curcop != &compiling && !strchr("gB", how))
croak(no_modify);
if (SvMAGICAL(sv)) {
- if (SvMAGIC(sv) && mg_find(sv, how))
+ if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
+ if (how == 't')
+ mg->mg_len |= 1;
return;
+ }
}
else {
if (!SvUPGRADE(sv, SVt_PVMG))
mg->mg_moremagic = SvMAGIC(sv);
SvMAGIC(sv) = mg;
- if (obj == sv || how == '#')
+ if (!obj || obj == sv || how == '#')
mg->mg_obj = obj;
else {
mg->mg_obj = SvREFCNT_inc(obj);
break;
case 't':
mg->mg_virtual = &vtbl_taint;
+ mg->mg_len = 1;
break;
case 'U':
mg->mg_virtual = &vtbl_uvar;
PUSHs(&ref);
PUTBACK;
perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL);
+ del_XRV(SvANY(&ref));
}
LEAVE;
}
Safefree(IoFMT_NAME(sv));
Safefree(IoBOTTOM_NAME(sv));
/* FALL THROUGH */
- case SVt_PVFM:
case SVt_PVBM:
goto freescalar;
case SVt_PVCV:
+ case SVt_PVFM:
cv_undef((CV*)sv);
goto freescalar;
case SVt_PVHV:
sv_len(sv)
register SV *sv;
{
- char *s;
+ char *junk;
STRLEN len;
if (!sv)
if (SvGMAGICAL(sv))
len = mg_len(sv);
else
- s = SvPV(sv, len);
+ junk = SvPV(sv, len);
return len;
}
I32 append;
{
register char *bp; /* we're going to steal some values */
+#ifdef USE_STD_STDIO
register I32 cnt; /* from the stdio struct and put EVERYTHING */
register STDCHAR *ptr; /* in the innermost loop into registers */
- register I32 newline = rschar;/* (assuming >= 6 registers) */
- I32 i;
STRLEN bpx;
I32 shortbuffered;
+#endif
+ register I32 newline = rschar;/* (assuming >= 6 registers) */
+ I32 i;
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv) && curcop != &compiling)
}
} while (i != EOF);
}
-#ifdef USE_STD_STDIO /* Here is some breathtakingly efficient cheating */
+#ifdef USE_STD_STDIO /* Here is some breathtakingly efficient cheating */
cnt = fp->_cnt; /* get count into register */
(void)SvPOK_only(sv); /* validate pointer */
if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
}
}
- if (shortbuffered) { /* oh well, must extend */
+ if (shortbuffered) { /* oh well, must extend */
cnt = shortbuffered;
shortbuffered = 0;
bpx = bp - SvPVX(sv); /* prepare for possible relocation */
cnt = fp->_cnt;
ptr = fp->_ptr; /* reregisterize cnt and ptr */
- bpx = bp - SvPVX(sv); /* prepare for possible relocation */
+ if (i == EOF) /* all done for ever? */
+ goto thats_really_all_folks;
+
+ bpx = bp - SvPVX(sv); /* prepare for possible relocation */
SvCUR_set(sv, bpx);
SvGROW(sv, bpx + cnt + 2);
- bp = SvPVX(sv) + bpx; /* reconstitute our pointer */
+ bp = SvPVX(sv) + bpx; /* reconstitute our pointer */
if (i == newline) { /* all done for now? */
*bp++ = i;
goto thats_all_folks;
}
- else if (i == EOF) /* all done for ever? */
- goto thats_really_all_folks;
*bp++ = i; /* now go back to screaming loop */
}
thats_all_folks:
if (rslen > 1 && (bp - SvPVX(sv) < rslen || bcmp(bp - rslen, rs, rslen)))
- goto screamer; /* go back to the fray */
+ goto screamer; /* go back to the fray */
thats_really_all_folks:
if (shortbuffered)
cnt += shortbuffered;
return;
}
if (!(flags & SVp_POK) || !*SvPVX(sv)) {
- if (!SvUPGRADE(sv, SVt_NV))
- return;
+ sv_upgrade(sv, SVt_NV);
SvNVX(sv) = 1.0;
(void)SvNOK_only(sv);
return;
return;
}
if (!(flags & SVp_POK)) {
- if (!SvUPGRADE(sv, SVt_NV))
- return;
+ sv_upgrade(sv, SVt_NV);
SvNVX(sv) = -1.0;
(void)SvNOK_only(sv);
return;
*st = GvESTASH(gv);
fix_gv:
if (lref && !GvCV(gv)) {
+ ENTER;
sv = NEWSV(704,0);
gv_efullname(sv, gv);
- newSUB(savestack_ix,
+ newSUB(start_subparse(),
newSVOP(OP_CONST, 0, sv),
Nullop);
+ LEAVE;
}
return GvCV(gv);
}
*lp = SvCUR(sv);
}
else {
- if (SvTYPE(sv) > SVt_PVLV) {
+ if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
if (SvFAKE(sv))
sv_unglob(sv);
else
SvSTASH(ref) = (HV*)SvREFCNT_inc(stash);
#ifdef OVERLOAD
+ SvAMAGIC_off(sv);
if (Gv_AMG(stash)) {
SvAMAGIC_on(sv);
}
#define SVf_POK 0x00040000 /* has valid public pointer value */
#define SVf_ROK 0x00080000 /* has a valid reference pointer */
-#define SVf_FAKE 0x00100000 /* glob is just a copy */
+#define SVf_FAKE 0x00100000 /* glob or lexical is just a copy */
#define SVf_OOK 0x00200000 /* has valid offset value */
#define SVf_BREAK 0x00400000 /* refcnt is artificially low */
#define SVf_READONLY 0x00800000 /* may not be modified */
#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 */
GV * xcv_filegv;
long xcv_depth; /* >= 2 indicates recursive call */
AV * xcv_padlist;
+ CV * xcv_outside;
I32 xfm_lines;
};
#define IOf_ARGV 1 /* this fp iterates over ARGV */
#define IOf_START 2 /* check for null ARGV and substitute '-' */
#define IOf_FLUSH 4 /* this fp wants a flush after write op */
+#define IOf_DIDTOP 8 /* just did top of form */
/* The following macros define implementation-independent predicates on SVs. */
#define SvNIOK(sv) (SvFLAGS(sv) & (SVf_IOK|SVf_NOK))
+#define SvNIOKp(sv) (SvFLAGS(sv) & (SVp_IOK|SVp_NOK))
#define SvNIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK| \
SVp_IOK|SVp_NOK))
chdir 't' if -f 't/TEST';
+die "You need to run \"make test\" first to set things up.\n" unless -e 'perl';
+
if ($ARGV[0] eq '') {
@ARGV = split(/[ \n]/,
`echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t lib/*.t`);
--- /dev/null
+#!./perl
+
+BEGIN { unshift @INC, './lib', '../lib';
+ require Config; import Config;
+}
+use Math::BigInt;
+
+$test = 0;
+$| = 1;
+print "1..246\n";
+while (<DATA>) {
+ chop;
+ if (s/^&//) {
+ $f = $_;
+ } else {
+ ++$test;
+ @args = split(/:/,$_,99);
+ $ans = pop(@args);
+ $try = "\$x = new Math::BigInt \"$args[0]\";";
+ if ($f eq "bnorm"){
+ $try .= "\$x+0;";
+ } elsif ($f eq "bneg") {
+ $try .= "-\$x;";
+ } elsif ($f eq "babs") {
+ $try .= "abs \$x;";
+ } else {
+ $try .= "\$y = new Math::BigInt \"$args[1]\";";
+ if ($f eq bcmp){
+ $try .= "\$x <=> \$y;";
+ }elsif ($f eq badd){
+ $try .= "\$x + \$y;";
+ }elsif ($f eq bsub){
+ $try .= "\$x - \$y;";
+ }elsif ($f eq bmul){
+ $try .= "\$x * \$y;";
+ }elsif ($f eq bdiv){
+ $try .= "\$x / \$y;";
+ }elsif ($f eq bmod){
+ $try .= "\$x % \$y;";
+ }elsif ($f eq bgcd){
+ $try .= "Math::BigInt::bgcd(\$x, \$y);";
+ } else { warn "Unknown op"; }
+ }
+ #print ">>>",$try,"<<<\n";
+ $ans1 = eval $try;
+ if ("$ans1" eq $ans) { #bug!
+ print "ok $test\n";
+ } else {
+ print "not ok $test\n";
+ print "# '$try' expected: '$ans' got: '$ans1'\n";
+ }
+ }
+}
+__END__
+&bnorm
+abc:NaN
+ 1 a:NaN
+1bcd2:NaN
+11111b:NaN
++1z:NaN
+-1z:NaN
+0:+0
++0:+0
++00:+0
++0 0 0:+0
+000000 0000000 00000:+0
+-0:+0
+-0000:+0
++1:+1
++01:+1
++001:+1
++00000100000:+100000
+123456789:+123456789
+-1:-1
+-01:-1
+-001:-1
+-123456789:-123456789
+-00000100000:-100000
+&bneg
+abd:NaN
++0:+0
++1:-1
+-1:+1
++123456789:-123456789
+-123456789:+123456789
+&babs
+abc:NaN
++0:+0
++1:+1
+-1:+1
++123456789:+123456789
+-123456789:+123456789
+&bcmp
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
+-1:+0:-1
++0:-1:+1
++1:+0:+1
++0:+1:-1
+-1:+1:-1
++1:-1:+1
+-1:-1:+0
++1:+1:+0
++123:+123:+0
++123:+12:+1
++12:+123:-1
+-123:-123:+0
+-123:-12:-1
+-12:-123:+1
++123:+124:-1
++124:+123:+1
+-123:-124:+1
+-124:-123:-1
+&badd
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
++1:+0:+1
++0:+1:+1
++1:+1:+2
+-1:+0:-1
++0:-1:-1
+-1:-1:-2
+-1:+1:+0
++1:-1:+0
++9:+1:+10
++99:+1:+100
++999:+1:+1000
++9999:+1:+10000
++99999:+1:+100000
++999999:+1:+1000000
++9999999:+1:+10000000
++99999999:+1:+100000000
++999999999:+1:+1000000000
++9999999999:+1:+10000000000
++99999999999:+1:+100000000000
++10:-1:+9
++100:-1:+99
++1000:-1:+999
++10000:-1:+9999
++100000:-1:+99999
++1000000:-1:+999999
++10000000:-1:+9999999
++100000000:-1:+99999999
++1000000000:-1:+999999999
++10000000000:-1:+9999999999
++123456789:+987654321:+1111111110
+-123456789:+987654321:+864197532
+-123456789:-987654321:-1111111110
++123456789:-987654321:-864197532
+&bsub
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
++1:+0:+1
++0:+1:-1
++1:+1:+0
+-1:+0:-1
++0:-1:+1
+-1:-1:+0
+-1:+1:-2
++1:-1:+2
++9:+1:+8
++99:+1:+98
++999:+1:+998
++9999:+1:+9998
++99999:+1:+99998
++999999:+1:+999998
++9999999:+1:+9999998
++99999999:+1:+99999998
++999999999:+1:+999999998
++9999999999:+1:+9999999998
++99999999999:+1:+99999999998
++10:-1:+11
++100:-1:+101
++1000:-1:+1001
++10000:-1:+10001
++100000:-1:+100001
++1000000:-1:+1000001
++10000000:-1:+10000001
++100000000:-1:+100000001
++1000000000:-1:+1000000001
++10000000000:-1:+10000000001
++123456789:+987654321:-864197532
+-123456789:+987654321:-1111111110
+-123456789:-987654321:+864197532
++123456789:-987654321:+1111111110
+&bmul
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
++0:+1:+0
++1:+0:+0
++0:-1:+0
+-1:+0:+0
++123456789123456789:+0:+0
++0:+123456789123456789:+0
+-1:-1:+1
+-1:+1:-1
++1:-1:-1
++1:+1:+1
++2:+3:+6
+-2:+3:-6
++2:-3:-6
+-2:-3:+6
++111:+111:+12321
++10101:+10101:+102030201
++1001001:+1001001:+1002003002001
++100010001:+100010001:+10002000300020001
++10000100001:+10000100001:+100002000030000200001
++11111111111:+9:+99999999999
++22222222222:+9:+199999999998
++33333333333:+9:+299999999997
++44444444444:+9:+399999999996
++55555555555:+9:+499999999995
++66666666666:+9:+599999999994
++77777777777:+9:+699999999993
++88888888888:+9:+799999999992
++99999999999:+9:+899999999991
+&bdiv
+abc:abc:NaN
+abc:+1:abc:NaN
++1:abc:NaN
++0:+0:NaN
++0:+1:+0
++1:+0:NaN
++0:-1:+0
+-1:+0:NaN
++1:+1:+1
+-1:-1:+1
++1:-1:-1
+-1:+1:-1
++1:+2:+0
++2:+1:+2
++1000000000:+9:+111111111
++2000000000:+9:+222222222
++3000000000:+9:+333333333
++4000000000:+9:+444444444
++5000000000:+9:+555555555
++6000000000:+9:+666666666
++7000000000:+9:+777777777
++8000000000:+9:+888888888
++9000000000:+9:+1000000000
++35500000:+113:+314159
++71000000:+226:+314159
++106500000:+339:+314159
++1000000000:+3:+333333333
++10:+5:+2
++100:+4:+25
++1000:+8:+125
++10000:+16:+625
++999999999999:+9:+111111111111
++999999999999:+99:+10101010101
++999999999999:+999:+1001001001
++999999999999:+9999:+100010001
++999999999999999:+99999:+10000100001
+&bmod
+abc:abc:NaN
+abc:+1:abc:NaN
++1:abc:NaN
++0:+0:NaN
++0:+1:+0
++1:+0:NaN
++0:-1:+0
+-1:+0:NaN
++1:+1:+0
+-1:-1:+0
++1:-1:+0
+-1:+1:+0
++1:+2:+1
++2:+1:+0
++1000000000:+9:+1
++2000000000:+9:+2
++3000000000:+9:+3
++4000000000:+9:+4
++5000000000:+9:+5
++6000000000:+9:+6
++7000000000:+9:+7
++8000000000:+9:+8
++9000000000:+9:+0
++35500000:+113:+33
++71000000:+226:+66
++106500000:+339:+99
++1000000000:+3:+1
++10:+5:+0
++100:+4:+0
++1000:+8:+0
++10000:+16:+0
++999999999999:+9:+0
++999999999999:+99:+0
++999999999999:+999:+0
++999999999999:+9999:+0
++999999999999999:+99999:+0
+&bgcd
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
++0:+1:+1
++1:+0:+1
++1:+1:+1
++2:+3:+1
++3:+2:+1
++100:+625:+25
++4096:+81:+1
print $buffer eq "#!./perl\n" ? "ok 4\n" : "not ok 4\n";
@fds = POSIX::pipe();
-print $fds[0] == $testfd + 1 ? "ok 5\n" : "not ok 5\n";
+print $fds[0] > $testfd ? "ok 5\n" : "not ok 5\n";
$writer = FileHandle->new_from_fd($fds[1], "w");
$reader = FileHandle->new_from_fd($fds[0], "r");
print $writer "ok 6\n";
--- /dev/null
+#!./perl
+
+BEGIN { unshift @INC, './lib', '../lib';
+ require Config; import Config;
+}
+
+package Oscalar;
+
+%OVERLOAD = (
+ # Anonymous subroutines:
+'+' => sub {new Oscalar ${$_[0]}+$_[1]},
+'-' => sub {new Oscalar
+ $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]},
+'<=>' => sub {new Oscalar
+ $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]},
+'cmp' => sub {new Oscalar
+ $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])},
+'*' => sub {new Oscalar ${$_[0]}*$_[1]},
+'/' => sub {new Oscalar
+ $_[2]? $_[1]/${$_[0]} :
+ ${$_[0]}/$_[1]},
+'%' => sub {new Oscalar
+ $_[2]? $_[1]%${$_[0]} : ${$_[0]}%$_[1]},
+'**' => sub {new Oscalar
+ $_[2]? $_[1]**${$_[0]} : ${$_[0]}-$_[1]},
+
+qw(
+"" stringify
+0+ numify) # Order of arguments unsignificant
+);
+
+sub new {
+ my $foo = $_[1];
+ bless \$foo;
+}
+
+sub stringify { "${$_[0]}" }
+sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead
+ # comparing to direct compilation based on
+ # stringify
+
+package main;
+
+$test = 0;
+$| = 1;
+print "1..",&last,"\n";
+
+sub test {
+ $test++; if (shift) {print "ok $test\n";1} else {print "not ok $test\n";0}
+}
+
+$a = new Oscalar "087";
+$b= "$a";
+
+test (!defined ref $b); # 1
+test ($b eq $a); # 2
+test ($b eq "087"); # 3
+test (ref $a eq "Oscalar"); # 4
+test ($a eq $a); # 5
+test ($a eq "087"); # 6
+
+$c = $a + 7;
+
+test (ref $c eq "Oscalar"); # 7
+test (!($c eq $a)); # 8
+test ($c eq "94"); # 9
+
+$b=$a;
+
+test (ref $a eq "Oscalar"); # 10
+
+$b++;
+
+test (ref $b eq "Oscalar"); # 11
+test ( $a eq "087"); # 12
+test ( $b eq "88"); # 13
+test (ref $a eq "Oscalar"); # 14
+
+$c=$b;
+$c-=$a;
+
+test (ref $c eq "Oscalar"); # 15
+test ( $a eq "087"); # 16
+test ( $c eq "1"); # 17
+test (ref $a eq "Oscalar"); # 18
+
+$b=1;
+$b+=$a;
+
+test (ref $b eq "Oscalar"); # 19
+test ( $a eq "087"); # 20
+test ( $b eq "88"); # 21
+test (ref $a eq "Oscalar"); # 22
+
+$Oscalar::OVERLOAD{'++'} = sub {${$_[0]}++;$_[0]};
+
+$b=$a;
+
+test (ref $a eq "Oscalar"); # 23
+
+$b++;
+
+test (ref $b eq "Oscalar"); # 24
+test ( $a eq "087"); # 25
+test ( $b eq "88"); # 26
+test (ref $a eq "Oscalar"); # 27
+
+package Oscalar;
+$dummy=bless \$dummy; # Now cache of method should be reloaded
+package main;
+
+$b=$a;
+$b++;
+
+test (ref $b eq "Oscalar"); # 28
+test ( $a eq "087"); # 29
+test ( $b eq "88"); # 30
+test (ref $a eq "Oscalar"); # 31
+
+
+$Oscalar::OVERLOAD{'++'} = sub {${$_[0]}+=2;$_[0]};
+
+$b=$a;
+
+test (ref $a eq "Oscalar"); # 32
+
+$b++;
+
+test (ref $b eq "Oscalar"); # 33
+test ( $a eq "087"); # 34
+test ( $b eq "88"); # 35
+test (ref $a eq "Oscalar"); # 36
+
+package Oscalar;
+$dummy=bless \$dummy; # Now cache of method should be reloaded
+package main;
+
+$b++;
+
+test (ref $b eq "Oscalar"); # 37
+test ( $a eq "087"); # 38
+test ( $b eq "90"); # 39
+test (ref $a eq "Oscalar"); # 40
+
+$b=$a;
+$b++;
+
+test (ref $b eq "Oscalar"); # 41
+test ( $a eq "087"); # 42
+test ( $b eq "89"); # 43
+test (ref $a eq "Oscalar"); # 44
+
+
+test ($b? 1:0); # 45
+
+$Oscalar::OVERLOAD{'='} = sub {$copies++; package Oscalar; local $new=${$_[0]};bless \$new};
+
+$b=new Oscalar "$a";
+
+test (ref $b eq "Oscalar"); # 46
+test ( $a eq "087"); # 47
+test ( $b eq "087"); # 48
+test (ref $a eq "Oscalar"); # 49
+
+$b++;
+
+test (ref $b eq "Oscalar"); # 50
+test ( $a eq "087"); # 51
+test ( $b eq "89"); # 52
+test (ref $a eq "Oscalar"); # 53
+test ($copies == 0); # 54
+
+$b+=1;
+
+test (ref $b eq "Oscalar"); # 55
+test ( $a eq "087"); # 56
+test ( $b eq "90"); # 57
+test (ref $a eq "Oscalar"); # 58
+test ($copies == 0); # 59
+
+$b=$a;
+$b+=1;
+
+test (ref $b eq "Oscalar"); # 60
+test ( $a eq "087"); # 61
+test ( $b eq "88"); # 62
+test (ref $a eq "Oscalar"); # 63
+test ($copies == 0); # 64
+
+$b=$a;
+$b++;
+
+test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65
+test ( $a eq "087"); # 66
+test ( $b eq "89"); # 67
+test (ref $a eq "Oscalar"); # 68
+test ($copies == 1); # 69
+
+$Oscalar::OVERLOAD{'+='} = sub {${$_[0]}+=3*$_[1];$_[0]};
+$c=new Oscalar; # Cause rehash
+
+$b=$a;
+$b+=1;
+
+test (ref $b eq "Oscalar"); # 70
+test ( $a eq "087"); # 71
+test ( $b eq "90"); # 72
+test (ref $a eq "Oscalar"); # 73
+test ($copies == 2); # 74
+
+$b+=$b;
+
+test (ref $b eq "Oscalar"); # 75
+test ( $b eq "360"); # 76
+test ($copies == 2); # 77
+$b=-$b;
+
+test (ref $b eq "Oscalar"); # 78
+test ( $b eq "-360"); # 79
+test ($copies == 2); # 80
+
+$b=abs($b);
+
+test (ref $b eq "Oscalar"); # 81
+test ( $b eq "360"); # 82
+test ($copies == 2); # 83
+
+$b=abs($b);
+
+test (ref $b eq "Oscalar"); # 84
+test ( $b eq "360"); # 85
+test ($copies == 2); # 86
+
+$Oscalar::OVERLOAD{'x'} = sub {new Oscalar ($_[2]? "_.$_[1]._" x ${$_[0]}:
+ "_.${$_[0]}._" x $_[1])};
+
+$a=new Oscalar "yy";
+$a x= 3;
+test ($a eq "_.yy.__.yy.__.yy._"); # 87
+
+$Oscalar::OVERLOAD{'.'} = sub {new Oscalar ($_[2]? "_.$_[1].__.${$_[0]}._":
+ "_.${$_[0]}.__.$_[1]._")};
+
+$a=new Oscalar "xx";
+
+test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88
+
+# Here we test blessing to a package updates hash
+
+delete $Oscalar::OVERLOAD{'.'};
+
+test ("b${a}" eq "_.b.__.xx._"); # 89
+$x="1";
+bless \$x, Oscalar;
+test ("b${a}c" eq "bxxc"); # 90
+new Oscalar 1;
+test ("b${a}c" eq "bxxc"); # 91
+
+sub last {91}
#!./perl
-#From jhi@snakemail.hut.fi Mon May 16 10:36:46 1994
-#Date: Sun, 15 May 1994 20:39:09 +0300
-#From: Jarkko Hietaniemi <jhi@snakemail.hut.fi>
+# From: kgb@ast.cam.ac.uk (Karl Glazebrook)
-print "1..2\n";
+print "1..4\n";
-$n = 1000;
+srand;
-$c = 0;
-for (1..$n) {
- last if (rand() > 1 || rand() < 0);
- $c++;
+$m=0;
+for(1..1000){
+ $n = rand(1);
+ if ($n<0 || $n>=1) {
+ print "not ok 1\n# The value of randbits is likely too low in config.sh\n";
+ exit
+ }
+ $m += $n;
+
+}
+$m=$m/1000;
+print "ok 1\n";
+
+if ($m<0.4) {
+ print "not ok 2\n# The value of randbits is likely too high in config.sh\n";
+}
+elsif ($m>0.6) {
+ print "not ok 2\n# Something's really weird about rand()'s distribution.\n";
+}else{
+ print "ok 2\n";
}
-if ($c == $n) {print "ok 1\n";} else {print "not ok 1\n"}
+srand;
-$c = 0;
-for (1..$n) {
- last if (rand(10) > 10 || rand(10) < 0);
- $c++;
+$m=0;
+for(1..1000){
+ $n = rand(100);
+ if ($n<0 || $n>=100) {
+ print "not ok 3\n";
+ exit
+ }
+ $m += $n;
+
+}
+$m=$m/1000;
+print "ok 3\n";
+
+if ($m<40 || $m>60) {
+ print "not ok 4\n";
+}else{
+ print "ok 4\n";
}
-if ($c == $n) {print "ok 2\n";} else {print "not ok 2\n"}
+
sub BASEOBJ'doit {
local $ref = shift;
die "Not an OBJ" unless ref $ref eq OBJ;
- $ref->{shift};
+ $ref->{shift()};
}
package UNIVERSAL;
else
{ print "not ok 1\n"; }
+$fox = 'wolfishness';
+my $fox = 'foxiness'; # Test a lexical variable.
+
format OUT2 =
the quick brown @<<
$fox
open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
-$fox = 'foxiness';
$good = 'good';
$multiline = "forescore\nand\nseven years\n";
$foo = 'when in the course of human events it becomes necessary';
-abc abc y $& abc
-abc xbc n - -
-abc axc n - -
-abc abx n - -
-abc xabcy y $& abc
-abc ababc y $& abc
-ab*c abc y $& abc
-ab*bc abc y $& abc
-ab*bc abbc y $& abbc
-ab*bc abbbbc y $& abbbbc
-ab{0,}bc abbbbc y $& abbbbc
-ab+bc abbc y $& abbc
-ab+bc abc n - -
-ab+bc abq n - -
-ab{1,}bc abq n - -
-ab+bc abbbbc y $& abbbbc
-ab{1,}bc abbbbc y $& abbbbc
-ab{1,3}bc abbbbc y $& abbbbc
-ab{3,4}bc abbbbc y $& abbbbc
-ab{4,5}bc abbbbc n - -
-ab?bc abbc y $& abbc
-ab?bc abc y $& abc
-ab{0,1}bc abc y $& abc
-ab?bc abbbbc n - -
-ab?c abc y $& abc
-ab{0,1}c abc y $& abc
-^abc$ abc y $& abc
-^abc$ abcc n - -
-^abc abcc y $& abc
-^abc$ aabc n - -
-abc$ aabc y $& abc
-^ abc y $&
-$ abc y $&
-a.c abc y $& abc
-a.c axc y $& axc
-a.*c axyzc y $& axyzc
-a.*c axyzd n - -
-a[bc]d abc n - -
-a[bc]d abd y $& abd
-a[b-d]e abd n - -
-a[b-d]e ace y $& ace
-a[b-d] aac y $& ac
-a[-b] a- y $& a-
-a[b-] a- y $& a-
-a[b-a] - c - -
-a[]b - c - -
-a[ - c - -
-a] a] y $& a]
-a[]]b a]b y $& a]b
-a[^bc]d aed y $& aed
-a[^bc]d abd n - -
-a[^-b]c adc y $& adc
-a[^-b]c a-c n - -
-a[^]b]c a]c n - -
-a[^]b]c adc y $& adc
-ab|cd abc y $& ab
-ab|cd abcd y $& ab
-()ef def y $&-$1 ef-
-()* - c - -
-*a - c - -
-^* - c - -
-$* - c - -
-(*)b - c - -
-$b b n - -
-a\ - c - -
-a\(b a(b y $&-$1 a(b-
-a\(*b ab y $& ab
-a\(*b a((b y $& a((b
-a\\b a\b y $& a\b
-abc) - c - -
-(abc - c - -
-((a)) abc y $&-$1-$2 a-a-a
-(a)b(c) abc y $&-$1-$2 abc-a-c
-a+b+c aabbabc y $& abc
-a{1,}b{1,}c aabbabc y $& abc
-a** - c - -
a.+?c abcabc y $& abc
-(a*)* - c - -
-(a*)+ - c - -
-(a|)* - c - -
-(a*|b)* - c - -
(a+|b)* ab y $&-$1 ab-b
(a+|b){0,} ab y $&-$1 ab-b
-(a+|b)+ ab y $&-$1 ab-b
-(a+|b){1,} ab y $&-$1 ab-b
-(a+|b)? ab y $&-$1 a-a
-(a+|b){0,1} ab y $&-$1 a-a
-(^)* - c - -
-(ab|)* - c - -
-)( - c - -
-[^ab]* cde y $& cde
-abc n - -
-a* y $&
-([abc])*d abbbcd y $&-$1 abbbcd-c
-([abc])*bcd abcd y $&-$1 abcd-a
-a|b|c|d|e e y $& e
-(a|b|c|d|e)f ef y $&-$1 ef-e
-((a*|b))* - c - -
-abcd*efg abcdefg y $& abcdefg
-ab* xabyabbbz y $& ab
-ab* xayabbbz y $& a
-(ab|cd)e abcde y $&-$1 cde-cd
-[abhgefdc]ij hij y $& hij
-^(ab|cd)e abcde n x$1y xy
-(abc|)ef abcdef y $&-$1 ef-
-(a|b)c*d abcd y $&-$1 bcd-b
-(ab|ab*)bc abc y $&-$1 abc-a
-a([bc]*)c* abc y $&-$1 abc-bc
-a([bc]*)(c*d) abcd y $&-$1-$2 abcd-bc-d
-a([bc]+)(c*d) abcd y $&-$1-$2 abcd-bc-d
-a([bc]*)(c+d) abcd y $&-$1-$2 abcd-b-cd
-a[bcd]*dcdcde adcdcde y $& adcdcde
-a[bcd]+dcdcde adcdcde n - -
-(ab|a)b*c abc y $&-$1 abc-ab
-((a)(b)c)(d) abcd y $1-$2-$3-$4 abc-a-b-d
-[a-zA-Z_][a-zA-Z0-9_]* alpha y $& alpha
-^a(bc+|b[eh])g|.h$ abh y $&-$1 bh-
-(bc+d$|ef*g.|h?i(j|k)) effgz y $&-$1-$2 effgz-effgz-
-(bc+d$|ef*g.|h?i(j|k)) ij y $&-$1-$2 ij-ij-j
-(bc+d$|ef*g.|h?i(j|k)) effg n - -
-(bc+d$|ef*g.|h?i(j|k)) bcdd n - -
-(bc+d$|ef*g.|h?i(j|k)) reffgz y $&-$1-$2 effgz-effgz-
-((((((((((a)))))))))) a y $10 a
-((((((((((a))))))))))\10 aa y $& aa
-((((((((((a))))))))))\41 aa n - -
-((((((((((a))))))))))\41 a! y $& a!
-(((((((((a))))))))) a y $& a
-multiple words of text uh-uh n - -
-multiple words multiple words, yeah y $& multiple words
-(.*)c(.*) abcde y $&-$1-$2 abcde-ab-de
-\((.*), (.*)\) (a, b) y ($2, $1) (b, a)
-[k] ab n - -
-abcd abcd y $&-\$&-\\$& abcd-$&-\abcd
-a(bc)d abcd y $1-\$1-\\$1 bc-$1-\bc
-a[-]?c ac y $& ac
-(abc)\1 abcabc y $1 abc
-([a-c]*)\1 abcabc y $1 abc
-'abc'i ABC y $& ABC
-'abc'i XBC n - -
-'abc'i AXC n - -
-'abc'i ABX n - -
-'abc'i XABCY y $& ABC
-'abc'i ABABC y $& ABC
-'ab*c'i ABC y $& ABC
-'ab*bc'i ABC y $& ABC
-'ab*bc'i ABBC y $& ABBC
-'ab*bc'i ABBBBC y $& ABBBBC
-'ab{0,}bc'i ABBBBC y $& ABBBBC
-'ab+bc'i ABBC y $& ABBC
-'ab+bc'i ABC n - -
-'ab+bc'i ABQ n - -
-'ab{1,}bc'i ABQ n - -
-'ab+bc'i ABBBBC y $& ABBBBC
-'ab{1,}bc'i ABBBBC y $& ABBBBC
-'ab{1,3}bc'i ABBBBC y $& ABBBBC
-'ab{3,4}bc'i ABBBBC y $& ABBBBC
-'ab{4,5}bc'i ABBBBC n - -
-'ab?bc'i ABBC y $& ABBC
-'ab?bc'i ABC y $& ABC
-'ab{0,1}bc'i ABC y $& ABC
-'ab?bc'i ABBBBC n - -
-'ab?c'i ABC y $& ABC
-'ab{0,1}c'i ABC y $& ABC
-'^abc$'i ABC y $& ABC
-'^abc$'i ABCC n - -
-'^abc'i ABCC y $& ABC
-'^abc$'i AABC n - -
-'abc$'i AABC y $& ABC
-'^'i ABC y $&
-'$'i ABC y $&
-'a.c'i ABC y $& ABC
-'a.c'i AXC y $& AXC
-'a.*c'i AXYZC y $& AXYZC
-'a.*c'i AXYZD n - -
-'a[bc]d'i ABC n - -
-'a[bc]d'i ABD y $& ABD
-'a[b-d]e'i ABD n - -
-'a[b-d]e'i ACE y $& ACE
-'a[b-d]'i AAC y $& AC
-'a[-b]'i A- y $& A-
-'a[b-]'i A- y $& A-
-'a[b-a]'i - c - -
-'a[]b'i - c - -
-'a['i - c - -
-'a]'i A] y $& A]
-'a[]]b'i A]B y $& A]B
-'a[^bc]d'i AED y $& AED
-'a[^bc]d'i ABD n - -
-'a[^-b]c'i ADC y $& ADC
-'a[^-b]c'i A-C n - -
-'a[^]b]c'i A]C n - -
-'a[^]b]c'i ADC y $& ADC
-'ab|cd'i ABC y $& AB
-'ab|cd'i ABCD y $& AB
-'()ef'i DEF y $&-$1 EF-
-'()*'i - c - -
-'*a'i - c - -
-'^*'i - c - -
-'$*'i - c - -
-'(*)b'i - c - -
-'$b'i B n - -
-'a\'i - c - -
-'a\(b'i A(B y $&-$1 A(B-
-'a\(*b'i AB y $& AB
-'a\(*b'i A((B y $& A((B
-'a\\b'i A\B y $& A\B
-'abc)'i - c - -
-'(abc'i - c - -
-'((a))'i ABC y $&-$1-$2 A-A-A
-'(a)b(c)'i ABC y $&-$1-$2 ABC-A-C
-'a+b+c'i AABBABC y $& ABC
-'a{1,}b{1,}c'i AABBABC y $& ABC
-'a**'i - c - -
-'a.+?c'i ABCABC y $& ABC
-'(a*)*'i - c - -
-'(a*)+'i - c - -
-'(a|)*'i - c - -
-'(a*|b)*'i - c - -
-'(a+|b)*'i AB y $&-$1 AB-B
-'(a+|b){0,}'i AB y $&-$1 AB-B
-'(a+|b)+'i AB y $&-$1 AB-B
-'(a+|b){1,}'i AB y $&-$1 AB-B
-'(a+|b)?'i AB y $&-$1 A-A
-'(a+|b){0,1}'i AB y $&-$1 A-A
-'(^)*'i - c - -
-'(ab|)*'i - c - -
-')('i - c - -
-'[^ab]*'i CDE y $& CDE
-'abc'i n - -
-'a*'i y $&
-'([abc])*d'i ABBBCD y $&-$1 ABBBCD-C
-'([abc])*bcd'i ABCD y $&-$1 ABCD-A
-'a|b|c|d|e'i E y $& E
-'(a|b|c|d|e)f'i EF y $&-$1 EF-E
-'((a*|b))*'i - c - -
-'abcd*efg'i ABCDEFG y $& ABCDEFG
-'ab*'i XABYABBBZ y $& AB
-'ab*'i XAYABBBZ y $& A
-'(ab|cd)e'i ABCDE y $&-$1 CDE-CD
-'[abhgefdc]ij'i HIJ y $& HIJ
-'^(ab|cd)e'i ABCDE n x$1y XY
-'(abc|)ef'i ABCDEF y $&-$1 EF-
-'(a|b)c*d'i ABCD y $&-$1 BCD-B
-'(ab|ab*)bc'i ABC y $&-$1 ABC-A
-'a([bc]*)c*'i ABC y $&-$1 ABC-BC
-'a([bc]*)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D
-'a([bc]+)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D
-'a([bc]*)(c+d)'i ABCD y $&-$1-$2 ABCD-B-CD
-'a[bcd]*dcdcde'i ADCDCDE y $& ADCDCDE
-'a[bcd]+dcdcde'i ADCDCDE n - -
-'(ab|a)b*c'i ABC y $&-$1 ABC-AB
-'((a)(b)c)(d)'i ABCD y $1-$2-$3-$4 ABC-A-B-D
-'[a-zA-Z_][a-zA-Z0-9_]*'i ALPHA y $& ALPHA
-'^a(bc+|b[eh])g|.h$'i ABH y $&-$1 BH-
-'(bc+d$|ef*g.|h?i(j|k))'i EFFGZ y $&-$1-$2 EFFGZ-EFFGZ-
-'(bc+d$|ef*g.|h?i(j|k))'i IJ y $&-$1-$2 IJ-IJ-J
-'(bc+d$|ef*g.|h?i(j|k))'i EFFG n - -
-'(bc+d$|ef*g.|h?i(j|k))'i BCDD n - -
-'(bc+d$|ef*g.|h?i(j|k))'i REFFGZ y $&-$1-$2 EFFGZ-EFFGZ-
-'((((((((((a))))))))))'i A y $10 A
-'((((((((((a))))))))))\10'i AA y $& AA
-'((((((((((a))))))))))\41'i AA n - -
-'((((((((((a))))))))))\41'i A! y $& A!
-'(((((((((a)))))))))'i A y $& A
-'multiple words of text'i UH-UH n - -
-'multiple words'i MULTIPLE WORDS, YEAH y $& MULTIPLE WORDS
-'(.*)c(.*)'i ABCDE y $&-$1-$2 ABCDE-AB-DE
-'\((.*), (.*)\)'i (A, B) y ($2, $1) (B, A)
-'[k]'i AB n - -
-'abcd'i ABCD y $&-\$&-\\$& ABCD-$&-\ABCD
-'a(bc)d'i ABCD y $1-\$1-\\$1 BC-$1-\BC
-'a[-]?c'i AC y $& AC
-'(abc)\1'i ABCABC y $1 ABC
-'([a-c]*)\1'i ABCABC y $1 ABC
if (tainting) {
MAGIC *mg = 0;
svp = hv_fetch(GvHVn(envgv),"PATH",4,FALSE);
- if (!svp || *svp == &sv_undef || (mg = mg_find(*svp, 't'))) {
- tainted = 1;
+ if (!svp || *svp == &sv_undef ||
+ ((mg = mg_find(*svp, 't')) && mg->mg_len & 1))
+ {
+ tainted = TRUE;
if (mg && MgTAINTEDDIR(mg))
taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
else
taint_proper("Insecure %s%s", "$ENV{PATH}");
}
svp = hv_fetch(GvHVn(envgv),"IFS",3,FALSE);
- if (svp && *svp != &sv_undef && mg_find(*svp, 't')) {
- tainted = 1;
+ if (svp && *svp != &sv_undef &&
+ (mg = mg_find(*svp, 't')) && mg->mg_len & 1)
+ {
+ tainted = TRUE;
taint_proper("Insecure %s%s", "$ENV{IFS}");
}
}
/* grandfather return to old style */
#define OLDLOP(f) return(yylval.ival=f,expect = XTERM,bufptr = s,(int)LSTOP)
-static cryptswitch_t cryptswitch_fp = NULL;
-
static int
ao(toketype)
int toketype;
char *s;
{
char tmpbuf[128];
- char *oldbufptr = bufptr;
+ char *oldbp = bufptr;
+ bool is_first = (oldbufptr == SvPVX(linestr));
bufptr = s;
sprintf(tmpbuf, "%s found where operator expected", what);
yywarn(tmpbuf);
- if (oldbufptr == SvPVX(linestr))
+ if (is_first)
warn("\t(Missing semicolon on previous line?)\n");
- bufptr = oldbufptr;
+ else if (oldoldbufptr && isIDFIRST(*oldoldbufptr)) {
+ char *t;
+ for (t = oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
+ if (t < bufptr && isSPACE(*t))
+ warn("\t(Do you need to predeclare %.*s?)\n",
+ t - oldoldbufptr, oldoldbufptr);
+
+ }
+ else
+ warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
+ bufptr = oldbp;
}
static void
int kind;
{
if (s && *s) {
- nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
+ OP* op = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
+ nextval[nexttoke].opval = op;
force_next(WORD);
- if (kind)
+ if (kind) {
+ op->op_private = OPpCONST_ENTERED;
gv_fetchpv(s, TRUE,
kind == '$' ? SVt_PV :
kind == '@' ? SVt_PVAV :
kind == '%' ? SVt_PVHV :
SVt_PVGV
);
+ }
}
}
return sv;
s = SvPV_force(sv, len);
+ if (SvIVX(sv) == -1)
+ return sv;
send = s + len;
while (s < send && *s != '\\')
s++;
SV *sv = NEWSV(93, send - start);
register char *s = start;
register char *d = SvPVX(sv);
- char delim = SvIVX(linestr);
bool dorange = FALSE;
I32 len;
char *leave =
lex_inpat
- ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]}"
+ ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
: (lex_inwhat & OP_TRANS)
? ""
: "";
s++;
}
}
+ else if (*s == '(' && lex_inpat && s[1] == '?' && s[2] == '#') {
+ while (s < send && *s != ')')
+ *d++ = *s++;
+ }
+ else if (*s == '#' && lex_inpat &&
+ ((PMOP*)lex_inpat)->op_pmflags & PMf_EXTENDED) {
+ while (s+1 < send && *s != '\n')
+ *d++ = *s++;
+ }
else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
break;
else if (*s == '$') {
}
if (*s == '\\' && s+1 < send) {
s++;
-#ifdef NOTDEF
- if (*s == delim) {
- *d++ = *s++;
- continue;
- }
-#endif
if (*s && strchr(leave, *s)) {
*d++ = '\\';
*d++ = *s++;
}
-static char* exp_name[] =
+#ifdef DEBUGGING
+ static char* exp_name[] =
{ "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
+#endif
extern int yychar; /* last token */
goto retry;
}
/* Give cryptswitch a chance. Note that cryptswitch_fp may */
- /* be called several times owing to "goto retry;"'s below. */
- if (cryptswitch_fp)
- rsfp = (*cryptswitch_fp)(rsfp);
+ /* be either be called once if it redirects rsfp and unregisters */
+ /* itself, or it may be called on every line if it loads linestr. */
+ if (cryptswitch_fp && (*cryptswitch_fp)()) {
+ oldoldbufptr = oldbufptr = s = SvPVX(linestr);
+ bufend = SvPVX(linestr) + SvCUR(linestr);
+ goto retry;
+ }
do {
if ((s = sv_gets(linestr, rsfp, 0)) == Nullch) {
fake_eof:
if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
s++;
if (!in_eval && *s == '#' && s[1] == '!') {
- if (!instr(s,"perl") && !instr(s,"indir") &&
- instr(origargv[0],"perl")) {
+ d = instr(s,"perl -");
+ if (!d)
+ d = instr(s,"perl");
+ if (!d &&
+ !minus_c &&
+ !instr(s,"indir") &&
+ instr(origargv[0],"perl"))
+ {
char **newargv;
char *cmd;
execv(cmd,newargv);
croak("Can't exec %s", cmd);
}
- if (d = instr(s, "perl -")) {
+ if (d) {
int oldpdb = perldb;
int oldn = minus_n;
int oldp = minus_p;
- d += 6;
- /*SUPPRESS 530*/
- while (d = moreswitches(d)) ;
- if (perldb && !oldpdb ||
- minus_n && !oldn ||
- minus_p && !oldp)
- {
- sv_setpv(linestr, "");
- oldoldbufptr = oldbufptr = s = SvPVX(linestr);
- bufend = SvPVX(linestr) + SvCUR(linestr);
- preambled = FALSE;
- if (perldb)
- (void)gv_fetchfile(origfilename);
- goto retry;
+
+ while (*d && !isSPACE(*d)) d++;
+ while (*d == ' ') d++;
+
+ if (*d++ == '-') {
+ while (d = moreswitches(d)) ;
+ if (perldb && !oldpdb ||
+ minus_n && !oldn ||
+ minus_p && !oldp)
+ {
+ sv_setpv(linestr, "");
+ oldoldbufptr = oldbufptr = s = SvPVX(linestr);
+ bufend = SvPVX(linestr) + SvCUR(linestr);
+ preambled = FALSE;
+ if (perldb)
+ (void)gv_fetchfile(origfilename);
+ goto retry;
+ }
}
}
}
case '-':
if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
s++;
+ bufptr = s;
+ tmp = *s++;
+
+ while (s < bufend && (*s == ' ' || *s == '\t'))
+ s++;
+
+ if (strnEQ(s,"=>",2)) {
+ if (dowarn)
+ warn("Ambiguous use of -%c => resolved to \"-%c\" =>",
+ tmp, tmp);
+ s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
+ OPERATOR('-'); /* unary minus */
+ }
last_uni = oldbufptr;
last_lop_op = OP_FTEREAD; /* good enough */
- switch (*s++) {
+ switch (tmp) {
case 'r': FTST(OP_FTEREAD);
case 'w': FTST(OP_FTEWRITE);
case 'x': FTST(OP_FTEEXEC);
case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
default:
- s -= 2;
+ croak("Unrecognized file test: -%c", tmp);
break;
}
}
s = force_word(s,METHOD,FALSE,TRUE,FALSE);
TOKEN(ARROW);
}
+ else if (*s == '$')
+ OPERATOR(ARROW);
else
- PREBLOCK(ARROW);
+ TERM(ARROW);
}
if (expect == XOPERATOR)
Aop(OP_SUBTRACT);
tokenbuf[0] = '%';
if (in_my) {
if (strchr(tokenbuf,':'))
- croak("\"my\" variable %s can't be in a package",tokenbuf);
+ croak(no_myglob,tokenbuf);
nextval[nexttoke].opval = newOP(OP_PADANY, 0);
nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf);
force_next(PRIVATEREF);
lex_brackstack[lex_brackets++] = XOPERATOR;
OPERATOR(HASHBRACK);
break;
- case XBLOCK:
case XOPERATOR:
+ while (s < bufend && (*s == ' ' || *s == '\t'))
+ s++;
+ if (s < bufend && isALPHA(*s)) {
+ d = scan_word(s, tokenbuf, FALSE, &len);
+ while (d < bufend && (*d == ' ' || *d == '\t'))
+ d++;
+ if (*d == '}') {
+ if (dowarn &&
+ (keyword(tokenbuf, len) ||
+ perl_get_cv(tokenbuf, FALSE) ))
+ warn("Ambiguous use of {%s} resolved to {\"%s\"}",
+ tokenbuf, tokenbuf);
+ s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ }
+ }
+ /* FALL THROUGH */
+ case XBLOCK:
lex_brackstack[lex_brackets++] = XSTATE;
expect = XSTATE;
break;
lex_state = LEX_INTERPEND;
}
}
+ if (lex_brackets < lex_fakebrack) {
+ bufptr = s;
+ lex_fakebrack = 0;
+ return yylex(); /* ignore fake brackets */
+ }
force_next('}');
TOKEN(';');
case '&':
if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
warn("Reversed %c= operator",tmp);
s--;
- if (isALPHA(tmp) && s == SvPVX(linestr)+1) {
+ if (expect == XSTATE && isALPHA(tmp) &&
+ (s == SvPVX(linestr)+1 || s[-2] == '\n') )
+ {
s = bufend;
doextract = TRUE;
goto retry;
Rop(OP_GT);
case '$':
- if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$", s[2]))) {
+ if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
s = scan_ident(s+1, bufend, tokenbuf+1, FALSE);
if (expect == XOPERATOR) {
if (lex_formbrack && lex_brackets == lex_formbrack) {
/* This kludge not intended to be bulletproof. */
if (tokenbuf[1] == '[' && !tokenbuf[2]) {
- yylval.opval = newSVOP(OP_CONST, OPf_SPECIAL,
+ yylval.opval = newSVOP(OP_CONST, 0,
newSViv((IV)compiling.cop_arybase));
+ yylval.opval->op_private = OPpCONST_ARYBASE;
TERM(THING);
}
tokenbuf[0] = '$';
if (*s == '{' && strEQ(tokenbuf, "$SIG") &&
(t = strchr(s,'}')) && (t = strchr(t,'='))) {
char tmpbuf[1024];
- char *d = tmpbuf;
STRLEN len;
for (t++; isSPACE(*t); t++) ;
- t = scan_word(t, tmpbuf, TRUE, &len);
- if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
- warn("You need to quote \"%s\"", tmpbuf);
+ if (isIDFIRST(*t)) {
+ t = scan_word(t, tmpbuf, TRUE, &len);
+ if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
+ warn("You need to quote \"%s\"", tmpbuf);
+ }
}
}
expect = XOPERATOR;
}
if (in_my) {
if (strchr(tokenbuf,':'))
- croak("\"my\" variable %s can't be in a package",tokenbuf);
+ croak(no_myglob,tokenbuf);
nextval[nexttoke].opval = newOP(OP_PADANY, 0);
nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf);
force_next(PRIVATEREF);
}
else if (!strchr(tokenbuf,':')) {
- if (oldexpect != XREF) {
+ if (oldexpect != XREF || oldoldbufptr == last_lop) {
if (*s == '[')
tokenbuf[0] = '@';
else if (*s == '{')
nextval[nexttoke].opval->op_targ = tmp;
force_next(PRIVATEREF);
}
- else
+ else {
+ if ((tainting || !euid) &&
+ !isLOWER(tokenbuf[1]) &&
+ (isDIGIT(tokenbuf[1]) ||
+ strchr("&`'+", tokenbuf[1]) ||
+ instr(tokenbuf,"MATCH") ))
+ hints |= HINT_BLOCK_SCOPE; /* Can't optimize block out*/
force_ident(tokenbuf+1, *tokenbuf);
+ }
}
else
force_ident(tokenbuf+1, *tokenbuf);
expect = XOPERATOR;
if (in_my) {
if (strchr(tokenbuf,':'))
- croak("\"my\" variable %s can't be in a package",tokenbuf);
+ croak(no_myglob,tokenbuf);
nextval[nexttoke].opval = newOP(OP_PADANY, 0);
nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf);
force_next(PRIVATEREF);
OPERATOR(tmp);
case '.':
- if (lex_formbrack && lex_brackets == lex_formbrack && s == oldbufptr) {
+ if (lex_formbrack && lex_brackets == lex_formbrack && s[1] == '\n' &&
+ (s == SvPVX(linestr) || s[-1] == '\n') ) {
lex_formbrack = 0;
expect = XSTATE;
goto rightbracket;
case '\\':
s++;
+ if (dowarn && lex_inwhat && isDIGIT(*s))
+ warn("Can't use \\%c to mean $%c in expression", *s, *s);
if (expect == XOPERATOR)
no_op("Backslash",s);
OPERATOR(REFGEN);
case 'z': case 'Z':
keylookup:
- d = s;
+ bufptr = s;
s = scan_word(s, tokenbuf, FALSE, &len);
tmp = keyword(tokenbuf, len);
+
+ /* Is this a word before a => operator? */
+ d = s;
+ while (d < bufend && (*d == ' ' || *d == '\t'))
+ d++; /* no comments skipped here, or s### is misparsed */
+ if (strnEQ(d,"=>",2)) {
+ CLINE;
+ if (dowarn && (tmp || perl_get_cv(tokenbuf, FALSE)))
+ warn("Ambiguous use of %s => resolved to \"%s\" =>",
+ tokenbuf, tokenbuf);
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
+ yylval.opval->op_private = OPpCONST_BARE;
+ TERM(WORD);
+ }
+
if (tmp < 0) { /* second-class keyword? */
GV* gv;
if (expect != XOPERATOR &&
default: /* not a keyword */
just_a_word: {
GV *gv;
+ char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
/* Get the rest if it looks like a package qualifier */
(expect == XREF ||
(opargs[last_lop_op] >> OASHIFT & 7) == OA_FILEREF) )
{
+ bool immediate_paren = *s == '(';
+
/* (Now we can afford to cross potential line boundary.) */
s = skipspace(s);
/* If not a declared subroutine, it's an indirect object. */
/* (But it's an indir obj regardless for sort.) */
- if (last_lop_op == OP_SORT || !gv || !GvCV(gv)) {
- expect = last_lop == oldoldbufptr ? XTERM : XOPERATOR;
- for (d = tokenbuf; *d && isLOWER(*d); d++) ;
- if (dowarn && !*d)
- warn(warn_reserved, tokenbuf);
- TOKEN(WORD);
+ if (last_lop_op == OP_SORT ||
+ (!immediate_paren && (!gv || !GvCV(gv))) ) {
+ expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
+ goto bareword;
}
}
force_next(WORD);
TOKEN('&');
}
+ if (lastchar == '-')
+ warn("Ambiguious use of -%s resolved as -&%s()",
+ tokenbuf, tokenbuf);
last_lop = oldbufptr;
last_lop_op = OP_ENTERSUB;
expect = XTERM;
force_next(WORD);
TOKEN(NOAMP);
}
- else if (hints & HINT_STRICT_SUBS &&
+
+ if (hints & HINT_STRICT_SUBS &&
+ lastchar != '-' &&
strnNE(s,"->",2) &&
last_lop_op != OP_ACCEPT &&
last_lop_op != OP_PIPE_OP &&
/* Call it a bare word */
- for (d = tokenbuf; *d && isLOWER(*d); d++) ;
- if (dowarn && !*d)
- warn(warn_reserved, tokenbuf);
+ bareword:
+ if (dowarn) {
+ if (lastchar != '-') {
+ for (d = tokenbuf; *d && isLOWER(*d); d++) ;
+ if (!*d)
+ warn(warn_reserved, tokenbuf);
+ }
+ }
+ if (lastchar && strchr("*%&", lastchar)) {
+ warn("Operator or semicolon missing before %c%s",
+ lastchar, tokenbuf);
+ warn("Ambiguious use of %c resolved as operator %c",
+ lastchar, lastchar);
+ }
TOKEN(WORD);
}
/*SUPPRESS 560*/
if (!in_eval) {
- gv = gv_fetchpv("DATA",TRUE, SVt_PVIO);
+ gv = gv_fetchpv("main::DATA",TRUE, SVt_PVIO);
SvMULTI_on(gv);
if (!GvIO(gv))
GvIOp(gv) = newIO();
case KEY_CORE:
if (*s == ':' && s[1] == ':') {
s += 2;
+ d = s;
s = scan_word(s, tokenbuf, FALSE, &len);
tmp = keyword(tokenbuf, len);
if (tmp < 0)
LOP(OP_CRYPT,XTERM);
case KEY_chmod:
- s = skipspace(s);
- if (dowarn && *s != '0' && isDIGIT(*s))
- yywarn("chmod: mode argument is missing initial 0");
+ if (dowarn) {
+ for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
+ if (*d != '0' && isDIGIT(*d))
+ yywarn("chmod: mode argument is missing initial 0");
+ }
LOP(OP_CHMOD,XTERM);
case KEY_chown:
OLDLOP(OP_RETURN);
case KEY_require:
+ *tokenbuf = '\0';
s = force_word(s,WORD,TRUE,TRUE,FALSE);
- if (*s == '<')
+ if (isIDFIRST(*tokenbuf))
+ gv_stashpv(tokenbuf, TRUE);
+ else if (*s == '<')
yyerror("<> should be quotes");
UNI(OP_REQUIRE);
LOP(OP_UTIME,XTERM);
case KEY_umask:
- s = skipspace(s);
- if (dowarn && *s != '0' && isDIGIT(*s))
- warn("umask: argument is missing initial 0");
+ if (dowarn) {
+ for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
+ if (*d != '0' && isDIGIT(*d))
+ yywarn("umask: argument is missing initial 0");
+ }
UNI(OP_UMASK);
case KEY_unshift:
{
register char *d;
char *bracket = 0;
+ char funny = *s++;
if (lex_brackets == 0)
lex_fakebrack = 0;
- s++;
if (isSPACE(*s))
s = skipspace(s);
d = dest;
lex_state = LEX_INTERPENDMAYBE;
return s;
}
- if (*s == '$' && s[1] && (isALPHA(s[1]) || strchr("$_{", s[1])))
+ if (*s == '$' && s[1] &&
+ (isALPHA(s[1]) || strchr("$_{", s[1]) || strnEQ(s+1,"::",2)) )
return s;
if (*s == '{') {
- if (lex_state == LEX_NORMAL)
- return s;
bracket = s;
s++;
}
if (s < send)
*d = *s++;
d[1] = '\0';
- if (*d == '^' && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
+ if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
*d = *s++ ^ 64;
}
if (bracket) {
+ if (isSPACE(s[-1])) {
+ while (s < send && (*s == ' ' || *s == '\t')) s++;
+ *d = *s;
+ }
if (isALPHA(*d) || *d == '_') {
d++;
- while (isALNUM(*s))
+ while (isALNUM(*s) || *s == ':')
*d++ = *s++;
*d = '\0';
- if ((*s == '[' || *s == '{') && !keyword(dest,d-dest)) {
- if (lex_brackets)
- croak("Can't use delimiter brackets within expression");
- lex_fakebrack = TRUE;
+ while (s < send && (*s == ' ' || *s == '\t')) s++;
+ if ((*s == '[' || *s == '{')) {
+ if (dowarn && keyword(dest, d - dest)) {
+ char *brack = *s == '[' ? "[...]" : "{...}";
+ warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
+ funny, dest, brack, funny, dest, brack);
+ }
+ lex_fakebrack = lex_brackets+1;
bracket++;
lex_brackstack[lex_brackets++] = XOPERATOR;
return s;
s++;
if (lex_state == LEX_INTERPNORMAL && !lex_brackets)
lex_state = LEX_INTERPEND;
+ if (funny == '#')
+ funny = '@';
+ if (dowarn &&
+ (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
+ warn("Ambiguous use of %c{%s} resolved to %c%s",
+ funny, dest, funny, dest);
}
else {
s = bracket; /* let the parser handle it */
return s;
}
-#ifdef NOTDEF
-void
-scan_prefix(pm,string,len)
-PMOP *pm;
-char *string;
-I32 len;
-{
- register SV *tmpstr;
- register char *t;
- register char *d;
- register char *e;
- char *origstring = string;
-
- if (ninstr(string, string+len, vert, vert+1))
- return;
- if (*string == '^')
- string++, len--;
- tmpstr = NEWSV(86,len);
- sv_upgrade(tmpstr, SVt_PVBM);
- sv_setpvn(tmpstr,string,len);
- t = SvPVX(tmpstr);
- e = t + len;
- BmUSEFUL(tmpstr) = 100;
- for (d=t; d < e; ) {
- switch (*d) {
- case '{':
- if (isDIGIT(d[1]))
- e = d;
- else
- goto defchar;
- break;
- case '(':
- if (d[1] == '?') { /* All bets off. */
- SvREFCNT_dec(tmpstr);
- return;
- }
- /* FALL THROUGH */
- case '.': case '[': case '$': case ')': case '|': case '+':
- case '^':
- e = d;
- break;
- case '\\':
- if (d[1] && strchr("AGZwWbB0123456789sSdDlLuUExc",d[1])) {
- e = d;
- break;
- }
- Move(d+1,d,e-d,char);
- e--;
- switch(*d) {
- case 'n':
- *d = '\n';
- break;
- case 't':
- *d = '\t';
- break;
- case 'f':
- *d = '\f';
- break;
- case 'r':
- *d = '\r';
- break;
- case 'e':
- *d = '\033';
- break;
- case 'a':
- *d = '\007';
- break;
- }
- /* FALL THROUGH */
- default:
- defchar:
- if (d[1] == '*' || (d[1] == '{' && d[2] == '0') || d[1] == '?') {
- e = d;
- break;
- }
- d++;
- }
- }
- if (d == t) {
- SvREFCNT_dec(tmpstr);
- return;
- }
- *d = '\0';
- SvCUR_set(tmpstr, d - t);
- if (d == t+len)
- pm->op_pmflags |= PMf_ALL;
- if (*origstring != '^')
- pm->op_pmflags |= PMf_SCANFIRST;
- pm->op_pmshort = tmpstr;
- pm->op_pmslen = d - t;
-}
-#endif
-
void pmflag(pmfl,ch)
U16* pmfl;
int ch;
else if (pm->op_pmflags & PMf_FOLD)
return;
pm->op_pmshort = SvREFCNT_inc(pm->op_pmregexp->regstart);
+ pm->op_pmslen = SvCUR(pm->op_pmshort);
}
else if (pm->op_pmregexp->regmust) {/* is there a better short-circuit? */
if (pm->op_pmshort &&
(SvCUR(pm->op_pmshort) < SvCUR(pm->op_pmregexp->regmust)) )){
SvREFCNT_dec(pm->op_pmshort); /* ok if null */
pm->op_pmshort = pm->op_pmregexp->regmust;
+ pm->op_pmslen = SvCUR(pm->op_pmshort);
pm->op_pmregexp->regmust = Nullsv;
pm->op_pmflags |= PMf_SCANFIRST;
}
else
s--, herewas = newSVpv(s,d-s);
s += SvCUR(herewas);
- if (term == '\'')
+
+ tmpstr = NEWSV(87,80);
+ sv_upgrade(tmpstr, SVt_PVIV);
+ if (term == '\'') {
op_type = OP_CONST;
- if (term == '`')
+ SvIVX(tmpstr) = -1;
+ }
+ else if (term == '`') {
op_type = OP_BACKTICK;
+ SvIVX(tmpstr) = '\\';
+ }
CLINE;
multi_start = curcop->cop_line;
multi_open = multi_close = '<';
- tmpstr = NEWSV(87,80);
- sv_upgrade(tmpstr, SVt_PVIV);
- SvIVX(tmpstr) = '\\';
term = *tokenbuf;
if (!rsfp) {
d = s;
start_subparse()
{
int oldsavestack_ix = savestack_ix;
+ CV* outsidecv = compcv;
+ AV* comppadlist;
save_I32(&subline);
save_item(subname);
SAVESPTR(curpad);
SAVESPTR(comppad);
SAVESPTR(comppad_name);
+ SAVESPTR(compcv);
SAVEINT(comppad_name_fill);
SAVEINT(min_intro_pending);
SAVEINT(max_intro_pending);
+ SAVEINT(pad_reset_pending);
+
+ compcv = (CV*)NEWSV(1104,0);
+ sv_upgrade((SV *)compcv, SVt_PVCV);
+
comppad = newAV();
SAVEFREESV((SV*)comppad);
comppad_name = newAV();
av_push(comppad, Nullsv);
curpad = AvARRAY(comppad);
padix = 0;
-
subline = curcop->cop_line;
+
+ comppadlist = newAV();
+ AvREAL_off(comppadlist);
+ av_store(comppadlist, 0, SvREFCNT_inc((SV*)comppad_name));
+ av_store(comppadlist, 1, SvREFCNT_inc((SV*)comppad));
+
+ CvPADLIST(compcv) = comppadlist;
+ CvOUTSIDE(compcv) = outsidecv;
+
return oldsavestack_ix;
}
char *s;
{
--error_count;
- return yyerror(s);
+ in_eval |= 2;
+ yyerror(s);
+ in_eval &= ~2;
+ return 0;
}
int
multi_open,multi_close,(long)multi_start);
multi_end = 0;
}
- if (in_eval)
+ if (in_eval & 2)
+ warn("%s",buf);
+ else if (in_eval)
sv_catpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),buf);
else
fputs(buf,stderr);
I32 rarest = 0;
U32 frequency = 256;
+ if (len > 255)
+ return; /* can't have offsets that big */
Sv_Grow(sv,len+258);
table = (unsigned char*)(SvPVX(sv) + len + 1);
s = table - 2;
{
char *tmps;
char *message;
+ HV *stash;
+ GV *gv;
+ CV *cv;
message = mess(pat,a1,a2,a3,a4);
+ if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
+ dSP;
+
+ PUSHMARK(sp);
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVpv(message,0)));
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ }
if (in_eval) {
restartop = die_where(message);
longjmp(top_env, 3);
(void)fflush(stderr);
if (e_fp)
(void)UNLINK(e_tmpname);
- statusvalue >>= 8;
- my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
+ statusvalue = SHIFTSTATUS(statusvalue);
+#ifdef VMS
+ my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
+#else
+ my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
+#endif
}
/*VARARGS1*/
long a1, a2, a3, a4;
{
char *message;
+ SV *sv;
+ HV *stash;
+ GV *gv;
+ CV *cv;
message = mess(pat,a1,a2,a3,a4);
- fputs(message,stderr);
+ if (warnhook && (cv = sv_2cv(warnhook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
+ dSP;
+
+ PUSHMARK(sp);
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVpv(message,0)));
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ }
+ else {
+ fputs(message,stderr);
#ifdef LEAKTEST
- DEBUG_L(xstat());
+ DEBUG_L(xstat());
#endif
- (void)fflush(stderr);
+ (void)fflush(stderr);
+ }
}
#else /* !defined(I_STDARG) && !defined(I_VARARGS) */
{
va_list args;
char *message;
+ HV *stash;
+ GV *gv;
+ CV *cv;
#ifdef I_STDARG
va_start(args, pat);
#endif
message = mess(pat, &args);
va_end(args);
+ if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
+ dSP;
+
+ PUSHMARK(sp);
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVpv(message,0)));
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ }
if (in_eval) {
restartop = die_where(message);
longjmp(top_env, 3);
(void)fflush(stderr);
if (e_fp)
(void)UNLINK(e_tmpname);
- statusvalue >>= 8;
- my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
+ statusvalue = SHIFTSTATUS(statusvalue);
+#ifdef VMS
+ my_exit((U32)(vaxc$errno?vaxc$errno:(statusvalue?statusvalue:44)));
+#else
+ my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
+#endif
}
void
{
va_list args;
char *message;
+ HV *stash;
+ GV *gv;
+ CV *cv;
#ifdef I_STDARG
va_start(args, pat);
message = mess(pat, &args);
va_end(args);
- fputs(message,stderr);
+ if (warnhook && (cv = sv_2cv(warnhook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
+ dSP;
+
+ PUSHMARK(sp);
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVpv(message,0)));
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ }
+ else {
+ fputs(message,stderr);
#ifdef LEAKTEST
- DEBUG_L(xstat());
+ DEBUG_L(xstat());
#endif
- (void)fflush(stderr);
+ (void)fflush(stderr);
+ }
}
#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
#endif /* HAS_VPRINTF */
#endif /* I_VARARGS */
-/*
- * I think my_swap(), htonl() and ntohl() have never been used.
- * perl.h contains last-chance references to my_swap(), my_htonl()
- * and my_ntohl(). I presume these are the intended functions;
- * but htonl() and ntohl() have the wrong names. There are no
- * functions my_htonl() and my_ntohl() defined anywhere.
- * -DWS
- */
#ifdef MYSWAP
#if BYTEORDER != 0x4321
short
+#ifndef CAN_PROTOTYPE
my_swap(s)
short s;
+#else
+my_swap(short s)
+#endif
{
#if (BYTEORDER & 1) == 0
short result;
}
long
-htonl(l)
+#ifndef CAN_PROTOTYPE
+my_htonl(l)
register long l;
+#else
+my_htonl(long l)
+#endif
{
union {
long result;
}
long
-ntohl(l)
+#ifndef CAN_PROTOTYPE
+my_ntohl(l)
register long l;
+#else
+my_ntohl(long l)
+#endif
{
union {
long l;
#endif /* !DOSISH */
-#ifdef NOTDEF
+#ifdef DUMP_FDS
dump_fds(s)
char *s;
{
int pid;
svp = av_fetch(fdpid,fileno(ptr),TRUE);
- pid = SvIVX(*svp);
+ pid = (int)SvIVX(*svp);
SvREFCNT_dec(*svp);
*svp = &sv_undef;
fclose(ptr);
hstat = signal(SIGHUP, SIG_IGN);
istat = signal(SIGINT, SIG_IGN);
qstat = signal(SIGQUIT, SIG_IGN);
- pid = wait4pid(pid, &status, 0);
+ do {
+ pid = wait4pid(pid, &status, 0);
+ } while (pid == -1 && errno == EINTR);
signal(SIGHUP, hstat);
signal(SIGINT, istat);
signal(SIGQUIT, qstat);
svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE);
if (svp && *svp != &sv_undef) {
*statusp = SvIVX(*svp);
- hv_delete(pidstatus,spid,strlen(spid));
+ (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
return pid;
}
}
sv = hv_iterval(pidstatus,entry);
*statusp = SvIVX(sv);
sprintf(spid, "%d", pid);
- hv_delete(pidstatus,spid,strlen(spid));
+ (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
return pid;
}
}
register char *s = start;
register unsigned long retval = 0;
- while (len-- && *s >= '0' && *s <= '7') {
+ while (len && *s >= '0' && *s <= '7') {
retval <<= 3;
retval |= *s++ - '0';
+ len--;
}
+ if (dowarn && len && (*s == '8' || *s == '9'))
+ warn("Illegal octal digit ignored");
*retlen = s - start;
return retval;
}
#> conversion process. For more information, see mms2make.pl
#>
# Makefile. for perl5 on VMS
-# Last revised 30-Sep-1994 by Charles Bailey bailey@genetics.upenn.edu
+# Last revised 10-Mar-1995 by Charles Bailey bailey@genetics.upenn.edu
#
#
# tidy -- purge files generated by executing this file
#### Start of system configuration section. ####
+
# File type to use for object files
+# File type to use for object libraries
# File type to use for executable images
# File type to use for object files
O = .obj
+# File type to use for object libraries
+OLB = .olb
# File type to use for executable images
E = .exe
-# used to incorporate 'custom' malloc routines
-mallocsrc =
-mallocobj =
+ARCHCORE = [.lib.VMS_VAX.CORE]
+ARCHAUTO = [.lib.auto.VMS_VAX]
-# We need separate MACRO files declaring global symbols
-SYMOPT = ,perlshr_gbl.opt/Option
+# -fno-builtin avoids bug in gcc up to version 2.6.2 which can destroy
+# data when memcpy() is called on large (>64 kB) blocks of memory
+# (fixed in gcc 2.6.3)
.first:
@ If f$$TrnLnm("Sys").eqs."" Then Define/NoLog SYS sys$$Library
XTRAOBJS =
XTRADEF =
LIBS2 = sys$$Share:VAXCRTL.Exe/Shareable
+
DBGCCFLAGS = /NoList
DBGLINKFLAGS = /NoMap
DBG =
-# Process option macros
# N.B. the targets for $(SOCKC) and $(SOCKH) assume that the permanent
# copies live in [.vms], and the `clean' target will delete copies of
# these files in the current default directory.
SOCKHLIS =
SOCKOBJ =
-# DEBUGGING ==> perl -D, not the VMS debugger
+# C preprocessor manifest "DEBUGGING" ==> perl -D, not the VMS debugger
CFLAGS = /Define=(DEBUGGING$(SOCKDEF)$(XTRADEF))$(XTRACCFLAGS)$(DBGCCFLAGS)
LINKFLAGS = $(DBGLINKFLAGS)
+MAKE = MMK
MAKEFILE = [.VMS]Makefile. # this file
NOOP = continue
-XSUBPP = MCR sys$$Disk:[]Miniperl$(E) [.ext]xsubpp -typemap [-]typemap
-# List of extensions to build into perlmain; enclose each in quotes and
-# separate by spaces.
-EXT = "DynaLoader"
-# Source and object files for these extensions; leading comma is required
+# Macros to invoke a copy of miniperl during the build. Targets which
+# are built using these macros should depend on $(MINIPERL_EXE)
+MINIPERL_EXE = sys$$Disk:[]miniperl$(E)
+MINIPERL = MCR $(MINIPERL_EXE)
+XSUBPP = $(MINIPERL) [.lib.extutils]xsubpp
+
+# Space-separated list of "static" extensions to build into perlshr (case counts).
+EXT = DynaLoader
+# object files for these extensions; the trailing comma is required if
+# there are any object files specified
# These must be built separately, or you must add rules below to build them
-extobj = , [.ext.dynaloader]dl_vms$(O)
+extobj = [.ext.dynaloader]dl_vms$(O),
#### End of system configuration section. ####
h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h
h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS)
-c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c $(mallocsrc)
-c2 = mg.c, perly.c, pp.c, pp_ctl.c, pp_hot.c, pp_sys.c, regcomp.c, regexec.c
-c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, vms.c $(SOCKCLIS)
+c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c
+c2 = perl.c, perly.c, pp.c, pp_hot.c, pp_ctl.c, pp_sys.c, regcomp.c, regexec.c
+c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, globals.c, vms.c $(SOCKCLIS)
-c = $(c1), $(c2), $(c3), perl.c, miniperlmain.c, perlmain.c
+c = $(c1), $(c2), $(c3), miniperlmain.c, perlmain.c
-obj1 = av$(O), scope$(O), op$(O), doop$(O), doio$(O), dump$(O), hv$(O) $(mallocobj)
-obj2 = mg$(O), perly$(O), pp$(O), pp_ctl$(O), pp_hot$(O), pp_sys$(O), regcomp$(O), regexec$(O)
-obj3 = gv$(O), sv$(O), taint$(O), toke$(O), util$(O), deb$(O), run$(O), vms$(O) $(SOCKOBJ)
+obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O)
+obj2 = hv$(O), av$(O), run$(O), pp_hot$(O), sv$(O), pp$(O), scope$(O), pp_ctl$(O), pp_sys$(O)
+obj3 = doop$(O), doio$(O), regexec$(O), taint$(O), deb$(O), globals$(O), vms$(O) $(SOCKOBJ)
obj = $(obj1), $(obj2), $(obj3)
+ac1 = $(ARCHCORE)EXTERN.h $(ARCHCORE)INTERN.h $(ARCHCORE)XSUB.h $(ARCHCORE)av.h
+ac2 = $(ARCHCORE)config.h $(ARCHCORE)cop.h $(ARCHCORE)cv.h $(ARCHCORE)embed.h
+ac3 = $(ARCHCORE)form.h $(ARCHCORE)gv.h $(ARCHCORE)handy.h $(ARCHCORE)hv.h
+ac4 = $(ARCHCORE)keywords.h $(ARCHCORE)mg.h $(ARCHCORE)op.h $(ARCHCORE)opcode.h
+ac5 = $(ARCHCORE)patchlevel.h $(ARCHCORE)perl.h $(ARCHCORE)perly.h
+ac6 = $(ARCHCORE)pp.h $(ARCHCORE)proto.h $(ARCHCORE)regcomp.h
+ac7 = $(ARCHCORE)regexp.h $(ARCHCORE)scope.h $(ARCHCORE)sv.h $(ARCHCORE)util.h
+ac8 = $(ARCHCORE)vmsish.h $(ARCHCORE)$(DBG)libperl$(OLB) $(ARCHCORE)perlshr_attr.opt
+ac9 = $(ARCHCORE)$(DBG)perlshr_bld.opt
+acs =
+
CRTL = []crtl.opt
CRTLOPTS =,$(CRTL)/Options
.suffixes:
-.suffixes: $(O) .c
+.suffixes: $(O) .c .xs
+
+.xs.c :
+ $(XSUBPP) $< >$@
+
.c$(O) :
$(CC) $(CFLAGS) $<
-all : base extras
+.xs$(O) :
+ $(XSUBPP) $< >$(MMS$SOURCE_NAME).c
+ $(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c
+
+all : base extras archcorefiles preplibrary
@ $(NOOP)
-base : $(DBG)miniperl$(E) perl$(E) [.lib]Config.pm
+base : miniperl$(E) perl$(E) [.lib]Config.pm
@ $(NOOP)
-extras : [.lib]DynaLoader.pm
+extras : [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm [.lib.extutils]MM_VMS.pm
+ @ $(NOOP)
+archcorefiles : $(ac1) $(ac2) $(ac3) $(ac4) $(ac5) $(ac6) $(ac7) $(ac8) $(ac9) $(acs) $(ARCHAUTO)time.stamp
@ $(NOOP)
-miniperl_objs = miniperlmain$(O), perl$(O), $(obj)
-miniperl$(E) : $(miniperl_objs) , coreobjs.opt $(CRTL)
- Link $(LINKFLAGS)/NoDebug/Exe=$@ miniperlmain$(O), perl$(O), coreobjs.opt/Option $(CRTLOPTS)
+miniperl_objs = miniperlmain$(O), $(obj)
+$(MINIPERL_EXE) : miniperlmain$(O), $(DBG)libperl$(OLB) $(CRTL)
+ Link $(LINKFLAGS)/NoDebug/Exe=$@ miniperlmain$(O), $(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
+miniperl$(E) : $(miniperl_objs), $(DBG)libperl$(OLB) $(CRTL)
+ Link $(LINKFLAGS)/Exe=$(DBG)$@ miniperlmain$(O),$(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
-# Use an options file to list object files since some Makes don't feed
-# long lines to DCL properly
-coreobjs.opt : $(MAKEFILE)
- @ $$@[.vms]genopt "$@/Write" "|" "$(obj1)"
- @ $$@[.vms]genopt "$@/Append" "|" "$(obj2)"
- @ $$@[.vms]genopt "$@/Append" "|" "$(obj3)"
+$(DBG)libperl$(OLB) : $(obj)
+ @ If f$$Search("$@").eqs."" Then Library/Object/Create $(MMS$TARGET)
+ Library/Object/Replace $@ $(obj1)
+ Library/Object/Replace $@ $(obj2)
+ Library/Object/Replace $@ $(obj3)
-perlmain.c : miniperlmain.c miniperl$(E)
- MCR sys$$Disk:[]Miniperl$(E) [.VMS]Writemain.pl $(EXT)
+perlmain.c : miniperlmain.c $(MINIPERL_EXE) [.vms]writemain.pl
+ $(MINIPERL) [.VMS]Writemain.pl "$(EXT)"
-perl$(E) : perlmain$(O) $(extobj), perlshr$(E), perlshr_attr.opt $(CRTL)
+perl$(E) : perlmain$(O), perlshr$(E), perlshr_attr.opt $(MINIPERL_EXE)
@ $$@[.vms]genopt "PerlShr.Opt/Write" "|" "''f$$Environment("Default")'$(DBG)PerlShr$(E)/Share"
- Link $(LINKFLAGS)/Exe=$(DBG)$@ perlmain$(O) $(extobj),[]perlshr.opt/Option,perlshr_attr.opt/Option
-shr_objs = perlshr$(O) ,perl$(O), $(obj)
-perlshr$(E) : $(shr_objs) ,perlshr_xtras.ts ,coreobjs.opt ,$(CRTL)
- Link $(LINKFLAGS)/Share/Exe=$(DBG)$@ perlshr$(O), perl$(O), coreobjs.opt/Option $(SYMOPT) , perlshr_attr.opt/Option, perlshr_sym.opt/Option $(CRTLOPTS)
-perlshr$(O) : [.vms]perlshr.c
- $(CC) $(CFLAGS)/NoOptimize/Object=$@ [.vms]perlshr.c
+ Link $(LINKFLAGS)/Exe=$(DBG)$@ perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option
+perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts
+ Link $(LINKFLAGS)/Share=$(DBG)$@ $(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, perlshr_sym.opt - VAX and AXP
-# perlshr_gbl*.mar, perlshr_gbl*$(O), perlshr_gbl.opt - VAX only
+# perlshr_attr.opt, $(DBG)perlshr_bld.opt - VAX and AXP
+# perlshr_gbl*.mar, perlshr_gbl*$(O) - VAX only
# 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.
-perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl miniperl$(E) $(MAKEFILE)
- MCR sys$$Disk:[]Miniperl$(E) [.vms]gen_shrfls.pl "$(CC)$(CFLAGS)" $(O)
- @ Copy NLA0: perlshr_xtras.ts
- @ Purge/NoLog/NoConfirm perlshr_xtras.ts
+$(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)"
+ @ If f$$Search("$(DBG)perlshr_xtras.ts").nes."" Then Delete/NoLog/NoConfirm $(DBG)perlshr_xtras.ts;*
+ @ Copy NLA0: $(DBG)perlshr_xtras.ts
-[.lib]config.pm : [.vms]config.vms [.vms]genconfig.pl miniperl$(E)
- MCR sys$$Disk:[]Miniperl$(E) [.VMS]GenConfig.Pl
- MCR sys$$Disk:[]Miniperl$(E) ConfigPM.
+[.lib]config.pm : [.vms]config.vms [.vms]genconfig.pl $(MINIPERL_EXE)
+ $(MINIPERL) [.VMS]GenConfig.Pl cc=$(CC)$(CFLAGS) ldflags=$(LINKFLAGS)
+ $(MINIPERL) ConfigPM.
-[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs miniperl$(E)
+[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs $(MINIPERL_EXE)
$(XSUBPP) [.ext.dynaloader]dl_vms.xs >$@
[.ext.dynaloader]dl_vms$(O) : [.ext.dynaloader]dl_vms.c
$(CC) $(CFLAGS) /Object=$@ [.ext.dynaloader]dl_vms.c
-preplibrary : miniperl$(E) [.lib]Config.pm
- @ Create/Directory [.lib.auto]
- MCR sys$$Disk:[]Miniperl$(E) "-Ilib" -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm
-
-[.lib]DynaLoader.pm : [.ext.dynaloader]dynaloader.pm preplibrary
+[.lib]DynaLoader.pm : [.ext.dynaloader]dynaloader.pm
Copy/Log/NoConfirm [.ext.dynaloader]dynaloader.pm [.lib]DynaLoader.pm
- MCR sys$$Disk:[]Miniperl$(E) autosplit DynaLoader
+
+[.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm
+ @ Create/Directory [.lib.VMS]
+ Copy/Log/NoConfirm [.vms.ext]Filespec.pm $@
+
+[.lib.ExtUtils]MM_VMS.pm : [.vms.ext]MM_VMS.pm
+ Copy/Log/NoConfirm [.vms.ext]MM_VMS.pm $@
+
+preplibrary : $(MINIPERL_EXE) [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm [.lib.ExtUtils]MM_VMS.pm
+ @ Write sys$$Output "Autosplitting Perl library . . ."
+ @ Create/Directory [.lib.auto]
+ @ $(MINIPERL) "-Ilib" -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm
-#opcode.h : opcode.pl
-# MCR Sys$Disk:[]Miniperl$(E) opcode.pl
+#opcode.h : opcode.pl $(MINIPERL_EXE)
+# $(MINIPERL) opcode.pl
perly.h : perly.c # Quick and dirty 'touch'
Copy/Log/NoConfirm perly.h; ;
test : perl$(E)
- @[.VMS]Test.Com
+# CORE subset for MakeMaker, so we can build Perl without sources
+# Should move to VMS installperl when we get one
+$(ARCHCORE)EXTERN.h : EXTERN.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log EXTERN.h $@
+$(ARCHCORE)INTERN.h : INTERN.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log INTERN.h $@
+$(ARCHCORE)XSUB.h : XSUB.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log XSUB.h $@
+$(ARCHCORE)av.h : av.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log av.h $@
+$(ARCHCORE)config.h : config.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log config.h $@
+$(ARCHCORE)cop.h : cop.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log cop.h $@
+$(ARCHCORE)cv.h : cv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log cv.h $@
+$(ARCHCORE)embed.h : embed.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log embed.h $@
+$(ARCHCORE)form.h : form.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log form.h $@
+$(ARCHCORE)gv.h : gv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log gv.h $@
+$(ARCHCORE)handy.h : handy.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log handy.h $@
+$(ARCHCORE)hv.h : hv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log hv.h $@
+$(ARCHCORE)keywords.h : keywords.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log keywords.h $@
+$(ARCHCORE)mg.h : mg.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log mg.h $@
+$(ARCHCORE)op.h : op.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log op.h $@
+$(ARCHCORE)opcode.h : opcode.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log opcode.h $@
+$(ARCHCORE)patchlevel.h : patchlevel.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log patchlevel.h $@
+$(ARCHCORE)perl.h : perl.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log perl.h $@
+$(ARCHCORE)perly.h : perly.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log perly.h $@
+$(ARCHCORE)pp.h : pp.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log pp.h $@
+$(ARCHCORE)proto.h : proto.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log proto.h $@
+$(ARCHCORE)regcomp.h : regcomp.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log regcomp.h $@
+$(ARCHCORE)regexp.h : regexp.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log regexp.h $@
+$(ARCHCORE)scope.h : scope.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log scope.h $@
+$(ARCHCORE)sv.h : sv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log sv.h $@
+$(ARCHCORE)util.h : util.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log util.h $@
+$(ARCHCORE)vmsish.h : vmsish.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log vmsish.h $@
+$(ARCHCORE)$(DBG)libperl$(OLB) : $(DBG)libperl$(OLB) $(DBG)perlshr_xtras.ts
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(DBG)libperl$(OLB) $@
+$(ARCHCORE)perlshr_attr.opt : $(DBG)perlshr_xtras.ts
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log perlshr_attr.opt $@
+$(ARCHCORE)$(DBG)perlshr_bld.opt : $(DBG)perlshr_xtras.ts
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(DBG)perlshr_bld.opt $@
+$(ARCHAUTO)time.stamp :
+ @ Create/Directory $(ARCHAUTO)
+ @ If f$$Search("$@").eqs."" Then Copy/NoConfirm _NLA0: $(MMS$TARGET)
+
# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
-# If this runs make out of memory, delete /usr/include lines.
av$(O) : EXTERN.h
av$(O) : av.c
av$(O) : av.h
hv$(O) : sv.h
hv$(O) : vmsish.h
hv$(O) : util.h
-malloc$(O) : EXTERN.h
-malloc$(O) : av.h
-malloc$(O) : config.h
-malloc$(O) : cop.h
-malloc$(O) : cv.h
-malloc$(O) : embed.h
-malloc$(O) : form.h
-malloc$(O) : gv.h
-malloc$(O) : handy.h
-malloc$(O) : hv.h
-malloc$(O) : malloc.c
-malloc$(O) : mg.h
-malloc$(O) : op.h
-malloc$(O) : opcode.h
-malloc$(O) : perl.h
-malloc$(O) : pp.h
-malloc$(O) : proto.h
-malloc$(O) : regexp.h
-malloc$(O) : scope.h
-malloc$(O) : sv.h
-malloc$(O) : vmsish.h
-malloc$(O) : util.h
mg$(O) : EXTERN.h
mg$(O) : av.h
mg$(O) : config.h
mg$(O) : sv.h
mg$(O) : vmsish.h
mg$(O) : util.h
+perl$(O) : EXTERN.h
+perl$(O) : av.h
+perl$(O) : config.h
+perl$(O) : cop.h
+perl$(O) : cv.h
+perl$(O) : embed.h
+perl$(O) : form.h
+perl$(O) : gv.h
+perl$(O) : handy.h
+perl$(O) : hv.h
+perl$(O) : mg.h
+perl$(O) : op.h
+perl$(O) : opcode.h
+perl$(O) : perl.c
+perl$(O) : perl.h
+perl$(O) : pp.h
+perl$(O) : proto.h
+perl$(O) : regexp.h
+perl$(O) : scope.h
+perl$(O) : sv.h
+perl$(O) : vmsish.h
+perl$(O) : util.h
perly$(O) : EXTERN.h
perly$(O) : av.h
perly$(O) : config.h
pp$(O) : sv.h
pp$(O) : vmsish.h
pp$(O) : util.h
+pp_ctl$(O) : EXTERN.h
+pp_ctl$(O) : av.h
+pp_ctl$(O) : config.h
+pp_ctl$(O) : cop.h
+pp_ctl$(O) : cv.h
+pp_ctl$(O) : embed.h
+pp_ctl$(O) : form.h
+pp_ctl$(O) : gv.h
+pp_ctl$(O) : handy.h
+pp_ctl$(O) : hv.h
+pp_ctl$(O) : mg.h
+pp_ctl$(O) : op.h
+pp_ctl$(O) : opcode.h
+pp_ctl$(O) : perl.h
+pp_ctl$(O) : pp_ctl.c
+pp_ctl$(O) : pp.h
+pp_ctl$(O) : proto.h
+pp_ctl$(O) : regexp.h
+pp_ctl$(O) : scope.h
+pp_ctl$(O) : sv.h
+pp_ctl$(O) : vmsish.h
+pp_ctl$(O) : util.h
+pp_hot$(O) : EXTERN.h
+pp_hot$(O) : av.h
+pp_hot$(O) : config.h
+pp_hot$(O) : cop.h
+pp_hot$(O) : cv.h
+pp_hot$(O) : embed.h
+pp_hot$(O) : form.h
+pp_hot$(O) : gv.h
+pp_hot$(O) : handy.h
+pp_hot$(O) : hv.h
+pp_hot$(O) : mg.h
+pp_hot$(O) : op.h
+pp_hot$(O) : opcode.h
+pp_hot$(O) : perl.h
+pp_hot$(O) : pp_hot.c
+pp_hot$(O) : pp.h
+pp_hot$(O) : proto.h
+pp_hot$(O) : regexp.h
+pp_hot$(O) : scope.h
+pp_hot$(O) : sv.h
+pp_hot$(O) : vmsish.h
+pp_hot$(O) : util.h
+pp_sys$(O) : EXTERN.h
+pp_sys$(O) : av.h
+pp_sys$(O) : config.h
+pp_sys$(O) : cop.h
+pp_sys$(O) : cv.h
+pp_sys$(O) : embed.h
+pp_sys$(O) : form.h
+pp_sys$(O) : gv.h
+pp_sys$(O) : handy.h
+pp_sys$(O) : hv.h
+pp_sys$(O) : mg.h
+pp_sys$(O) : op.h
+pp_sys$(O) : opcode.h
+pp_sys$(O) : perl.h
+pp_sys$(O) : pp_sys.c
+pp_sys$(O) : pp.h
+pp_sys$(O) : proto.h
+pp_sys$(O) : regexp.h
+pp_sys$(O) : scope.h
+pp_sys$(O) : sv.h
+pp_sys$(O) : vmsish.h
+pp_sys$(O) : util.h
regcomp$(O) : EXTERN.h
regcomp$(O) : INTERN.h
regcomp$(O) : av.h
cleanlis :
- If f$$Search("*.Lis").nes."" Then Delete/NoConfirm/Log *.Lis;*
+ - If f$$Search("*.CPP").nes."" Then Delete/NoConfirm/Log *.CPP;*
- If f$$Search("*.Map").nes."" Then Delete/NoConfirm/Log *.Map;*
tidy : cleanlis
- If f$$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar
- If f$$Search("[.Ext.DynaLoader]DL_VMS$(O);-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O)
- If f$$Search("[.Ext.DynaLoader]DL_VMS.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C
+ - If f$$Search("[.VMS.Ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*.C
+ - If f$$Search("[.VMS.Ext...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*$(O)
- If f$$Search("[.Lib.Auto...]*.al;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]*.al
- - If f$$Search("[.Lib.Auto...]autosplit.ts;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]autosplit.ts
+ - If f$$Search("[.Lib.Auto...]autosplit.ix;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]autosplit.ix
+ - If f$$Search("[.Lib]DynaLoader.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]DynaLoader.pm
+ - If f$$Search("[.Lib.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log [.Lib.VMS]*.*
+ - If f$$Search("[.Lib.ExtUtils]MM_VMS.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib.ExtUtils]MM_VMS.pm
+ - If f$$Search("$(ARCHCORE)*.*").nes."" Then Purge/NoConfirm/Log $(ARCHCORE)*.*
clean : tidy
- - If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_Attr.Opt
+ - If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
- If f$$Search("*$(O);*") .nes."" Then Delete/NoConfirm/Log *$(O);*
- If f$$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;*
- If f$$Search("Config.SH").nes."" Then Delete/NoConfirm/Log Config.SH;*
- If f$$Search("*.TS").nes."" Then Delete/NoConfirm/Log *.TS;*
- If f$$Search("[.Ext.DynaLoader]DL_VMS$(O)").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O);*
- If f$$Search("[.Ext.DynaLoader]DL_VMS.C").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.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);*
realclean : clean
- If f$$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);*
+ - If f$$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);*
- If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*
- - If f$$Search("[.Lib.Auto...]*.al;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;*
- - If f$$Search("[.Lib.Auto...]autosplit.ts;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;*
+ - If f$$Search("[.Lib.Auto...]*.al").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;*
+ - If f$$Search("[.Lib.Auto...]autosplit.ix;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ix;*
+ - If f$$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;*
+ - If f$$Search("[.Lib.VMS]*.*").nes."" Then Delete/NoConfirm/Log [.Lib.VMS...]*.*;*
+ - If f$$Search("[.Lib.ExtUtils]MM_VMS.pm").nes."" Then Delete/NoConfirm/Log [.Lib.ExtUtils]MM_VMS.pm;*
+ - If f$$Search("$(ARCHCORE)*.*").nes."" Then Delete/NoConfirm/Log $(ARCHCORE)*.*;*
cleansrc : clean
- - If f$$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);*
- If f$$Search("*.C;-1").nes."" Then Purge/NoConfirm/Log *.C
- If f$$Search("*.H;-1").nes."" Then Purge/NoConfirm/Log *.H
- If f$$Search("*.VMS;-1").nes."" Then Purge/NoConfirm/Log *.VMS
- - If f$$Search("$(MAKEFILE);-1").nes."" Then Purge/NoConfirm/Log $(MAKEFILE)
- If f$$Search("[.VMS]$(MAKEFILE);-1").nes."" Then Purge/NoConfirm/Log [.VMS]$(MAKEFILE)
- If f$$Search("[.VMS]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.C
- If f$$Search("[.VMS]*.H;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.H
- If f$$Search("[.VMS]*.Pl;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.Pl
- If f$$Search("[.VMS]*.VMS;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.VMS
+ - If f$$Search("[.VMS...]*.pm;-1").nes."" Then Purge/NoConfirm/Log [.VMS...]*.pm
+ - If f$$Search("[.VMS...]*.xs;-1").nes."" Then Purge/NoConfirm/Log [.VMS...]*.xs
- If f$$Search("[.Lib.Auto...]*.al").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;*
- - If f$$Search("[.Lib.Auto...]autosplit.ts;").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;*
- - If f$$Search("[.Lib]Config.pm;").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
+ - If f$$Search("[.Lib.Auto...]autosplit.ts").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;*
+ - If f$$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
* same as PRIVLIB_EXP, it is not defined, since presumably the
* program already searches PRIVLIB_EXP.
*/
-#undef ARCHLIB_EXP /**/
+#ifndef __ALPHA
+#define ARCHLIB_EXP "/perl_root/lib/VMS_AXP" /* config-skip */
+#else
+#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX" /* config-skip */
+#endif
/* CAT2:
* This macro catenates 2 tokens together.
*/
#define HAS_VFORK /**/
+/* Signal_t:
+ * This symbol's value is either "void" or "int", corresponding to the
+ * appropriate return type of a signal handler. Thus, you can declare
+ * a signal handler using "Signal_t (*handler)()", and define the
+ * handler using "Signal_t handler(sig)".
+ */
+#define Signal_t void /* Signal handler's return type */
+
/* HASVOLATILE:
* This symbol, if defined, indicates that this C compiler knows about
* the volatile declaration.
* This symbol, if defined, indicates that the waitpid routine is
* available to wait for child process.
*/
-#undef HAS_WAITPID /**/
+#define HAS_WAITPID /**/
/* HAS_WCSTOMBS:
* This symbol, if defined, indicates that the wcstombs routine is
#undef PWCHANGE /**/
#undef PWCLASS /**/
#undef PWEXPIRE /**/
-#undef PWCOMMENT /**/
+#define PWCOMMENT /**/
/* I_STDDEF:
* This symbol, if defined, indicates that <stddef.h> exists and should
* This symbol, if defined, indicates that the routine utime() is
* available to update the access and modification times of files.
*/
-#undef HAS_UTIME /**/
+#define HAS_UTIME /**/
/* I_STDARG:
* This symbol, if defined, indicates that <stdarg.h> exists and should
* getpwuid(), and getpwent() routines are available to
* get password entries.
*/
-#undef HAS_PASSWD /**/
+#define HAS_PASSWD /**/
/* HAS_PAUSE:
* This symbol, if defined, indicates that the pause routine is
*/
#define I_MATH /**/
+/* I_SYS_STAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/stat.h>.
+ */
+#define I_SYS_STAT /**/
+
+
/* Off_t:
* This symbol holds the type used to declare offsets in the kernel.
* It can be int, long, off_t, etc... It may be necessary to include
/* VMS: true for gcc, undef for VAXC/DECC. This is handled in Descrip.MMS
* C. Bailey 26-Aug-1994
*/
-/*#define GNUC_ATTRIBUTE_CHECK /* */
+/*#define GNUC_ATTRIBUTE_CHECK */
/* VOID_CLOSEDIR:
* This symbol, if defined, indicates that the closedir() routine
# Descrip.MMS for perl5 on VMS
-# Last revised 12-Oct-1994 by Charles Bailey bailey@genetics.upenn.edu
+# Last revised 10-Mar-1995 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
#### Start of system configuration section. ####
+
+#: >>>>> Architecture-specific options <<<<<
.ifdef AXE
# File type to use for object files
O = .abj
+# File type to use for object libraries
+OLB = .alb
# File type to use for executable images
E = .axe
.else
# File type to use for object files
O = .obj
+# File type to use for object libraries
+OLB = .olb
# File type to use for executable images
E = .exe
.endif
-# used to incorporate 'custom' malloc routines
-mallocsrc =
-mallocobj =
-
-#: Process hardware architecture macros
.ifdef __AXP__
-SYMOPT =
DECC = 1
+ARCHCORE = [.lib.VMS_AXP.CORE]
+ARCHAUTO = [.lib.auto.VMS_AXP]
.else
-# We need separate MACRO files declaring global symbols
-SYMOPT = ,perlshr_gbl.opt/Option
+ARCHCORE = [.lib.VMS_VAX.CORE]
+ARCHAUTO = [.lib.auto.VMS_VAX]
.endif
-#: Process compiler selection macros
+
+#: >>>>>Compiler-specific options <<<<<
.ifdef GNUC
.first
@ If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]
CC = gcc
-XTRACCFLAGS = /Obj=$(MMS$TARGET_NAME)$(O)
+# -fno-builtin avoids bug in gcc up to version 2.6.2 which can destroy
+# data when memcpy() is called on large (>64 kB) blocks of memory
+# (fixed in gcc 2.6.3)
+XTRACCFLAGS = /Obj=$(MMS$TARGET_NAME)$(O)/NoCase_Hack/Optimize=2/CC1="""""-fno-builtin"""""
DBGSPECFLAGS =
XTRADEF = ,GNUC_ATTRIBUTE_CHECK
XTRAOBJS =
DBGSPECFLAGS = /Show=(Source,Include,Expansion)
.ifdef decc
LIBS2 =
-XTRACCFLAGS = /Standard=VAXC/Include=[]/Prefix=All/Obj=$(MMS$TARGET_NAME)$(O)
+XTRACCFLAGS = /Warning=Disable=(ADDRCONSTEXT,MISSINGRETURN)/Include=[]/Prefix=All/Obj=$(MMS$TARGET_NAME)$(O)
XTRADEF =
.else # VAXC
XTRACCFLAGS = /Include=[]/Object=$(O)
.endif
.endif
+
+#: >>>>> Configuration options <<<<<
+#: __DEBUG__: builds images with full VMS debugger support
.ifdef __DEBUG__
DBGCCFLAGS = /List/Debug/NoOpt$(DBGSPECFLAGS)
DBGLINKFLAGS = /Debug/Map/Full/Cross
DBG =
.endif
-# Process option macros
+#: SOCKET: build in support for TCP/IP sockets
+#: By default, used SOCKETSHR library; see ReadMe.VMS
+#: for information on changing socket support
.ifdef SOCKET
SOCKDEF = ,VMS_DO_SOCKETS
SOCKLIB = SocketShr/Share
SOCKOBJ =
.endif
-# DEBUGGING ==> perl -D, not the VMS debugger
+# C preprocessor manifest "DEBUGGING" ==> perl -D, not the VMS debugger
CFLAGS = /Define=(DEBUGGING$(SOCKDEF)$(XTRADEF))$(XTRACCFLAGS)$(DBGCCFLAGS)
LINKFLAGS = $(DBGLINKFLAGS)
+MAKE = MMK
MAKEFILE = [.VMS]Descrip.MMS # this file
NOOP = continue
-XSUBPP = MCR Sys$Disk:[]Miniperl$(E) [.ext]xsubpp -typemap [-]typemap
-# List of extensions to build into perlmain; enclose each in quotes and
-# separate by spaces.
-EXT = "DynaLoader"
-# Source and object files for these extensions; leading comma is required
+# Macros to invoke a copy of miniperl during the build. Targets which
+# are built using these macros should depend on $(MINIPERL_EXE)
+MINIPERL_EXE = Sys$Disk:[]miniperl$(E)
+MINIPERL = MCR $(MINIPERL_EXE)
+XSUBPP = $(MINIPERL) [.lib.extutils]xsubpp
+
+# Space-separated list of "static" extensions to build into perlshr (case counts).
+EXT = DynaLoader
+# object files for these extensions; the trailing comma is required if
+# there are any object files specified
# These must be built separately, or you must add rules below to build them
-extobj = , [.ext.dynaloader]dl_vms$(O)
+extobj = [.ext.dynaloader]dl_vms$(O),
#### End of system configuration section. ####
h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h
h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS)
-c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c $(mallocsrc)
-c2 = mg.c, perly.c, pp.c, pp_ctl.c, pp_hot.c, pp_sys.c, regcomp.c, regexec.c
-c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, vms.c $(SOCKCLIS)
+c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c
+c2 = perl.c, perly.c, pp.c, pp_hot.c, pp_ctl.c, pp_sys.c, regcomp.c, regexec.c
+c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, globals.c, vms.c $(SOCKCLIS)
-c = $(c1), $(c2), $(c3), perl.c, miniperlmain.c, perlmain.c
+c = $(c1), $(c2), $(c3), miniperlmain.c, perlmain.c
-obj1 = av$(O), scope$(O), op$(O), doop$(O), doio$(O), dump$(O), hv$(O) $(mallocobj)
-obj2 = mg$(O), perly$(O), pp$(O), pp_ctl$(O), pp_hot$(O), pp_sys$(O), regcomp$(O), regexec$(O)
-obj3 = gv$(O), sv$(O), taint$(O), toke$(O), util$(O), deb$(O), run$(O), vms$(O) $(SOCKOBJ)
+obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O)
+obj2 = hv$(O), av$(O), run$(O), pp_hot$(O), sv$(O), pp$(O), scope$(O), pp_ctl$(O), pp_sys$(O)
+obj3 = doop$(O), doio$(O), regexec$(O), taint$(O), deb$(O), globals$(O), vms$(O) $(SOCKOBJ)
obj = $(obj1), $(obj2), $(obj3)
+ac1 = $(ARCHCORE)EXTERN.h $(ARCHCORE)INTERN.h $(ARCHCORE)XSUB.h $(ARCHCORE)av.h
+ac2 = $(ARCHCORE)config.h $(ARCHCORE)cop.h $(ARCHCORE)cv.h $(ARCHCORE)embed.h
+ac3 = $(ARCHCORE)form.h $(ARCHCORE)gv.h $(ARCHCORE)handy.h $(ARCHCORE)hv.h
+ac4 = $(ARCHCORE)keywords.h $(ARCHCORE)mg.h $(ARCHCORE)op.h $(ARCHCORE)opcode.h
+ac5 = $(ARCHCORE)patchlevel.h $(ARCHCORE)perl.h $(ARCHCORE)perly.h
+ac6 = $(ARCHCORE)pp.h $(ARCHCORE)proto.h $(ARCHCORE)regcomp.h
+ac7 = $(ARCHCORE)regexp.h $(ARCHCORE)scope.h $(ARCHCORE)sv.h $(ARCHCORE)util.h
+ac8 = $(ARCHCORE)vmsish.h $(ARCHCORE)$(DBG)libperl$(OLB) $(ARCHCORE)perlshr_attr.opt
+ac9 = $(ARCHCORE)$(DBG)perlshr_bld.opt
+.ifdef SOCKET
+acs = $(ARCHCORE)$(SOCKH)
+.else
+acs =
+.endif
+
CRTL = []crtl.opt
CRTLOPTS =,$(CRTL)/Options
.SUFFIXES
-.SUFFIXES $(O) .c
+.SUFFIXES $(O) .c .xs
+
+.xs.c :
+ $(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET)
+
.c$(O) :
$(CC) $(CFLAGS) $(MMS$SOURCE)
-all : base extras
+.xs$(O) :
+ $(XSUBPP) $(MMS$SOURCE) >$(MMS$SOURCE_NAME).c
+ $(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c
+
+all : base extras archcorefiles preplibrary
@ $(NOOP)
-base : $(DBG)miniperl$(E) perl$(E) [.lib]Config.pm
+base : miniperl$(E) perl$(E) [.lib]Config.pm
@ $(NOOP)
-extras : [.lib]DynaLoader.pm
+extras : [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm [.lib.extutils]MM_VMS.pm
+ @ $(NOOP)
+archcorefiles : $(ac1) $(ac2) $(ac3) $(ac4) $(ac5) $(ac6) $(ac7) $(ac8) $(ac9) $(acs) $(ARCHAUTO)time.stamp
@ $(NOOP)
-miniperl_objs = miniperlmain$(O), perl$(O), $(obj)
-miniperl$(E) : $(miniperl_objs) , coreobjs.opt $(CRTL)
- Link $(LINKFLAGS)/NoDebug/Exe=$(MMS$TARGET) miniperlmain$(O), perl$(O), coreobjs.opt/Option $(CRTLOPTS)
-.ifdef DBG
-$(DBG)miniperl$(E) : $(miniperl_objs) , coreobjs.opt $(CRTL)
- Link $(LINKFLAGS)/Exe=$(MMS$TARGET) miniperlmain$(O), perl$(O), coreobjs.opt/Option $(CRTLOPTS)
-.endif
+miniperl_objs = miniperlmain$(O), $(obj)
+$(MINIPERL_EXE) : miniperlmain$(O), $(DBG)libperl$(OLB) $(CRTL)
+ Link $(LINKFLAGS)/NoDebug/Exe=$(MMS$TARGET) miniperlmain$(O), $(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
+miniperl$(E) : $(miniperl_objs), $(DBG)libperl$(OLB) $(CRTL)
+ Link $(LINKFLAGS)/Exe=$(DBG)$(MMS$TARGET) miniperlmain$(O),$(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
-# Use an options file to list object files since some Makes don't feed
-# long lines to DCL properly
-coreobjs.opt : $(MAKEFILE)
- @ @[.vms]genopt "$(MMS$TARGET)/Write" "|" "$(obj1)"
- @ @[.vms]genopt "$(MMS$TARGET)/Append" "|" "$(obj2)"
- @ @[.vms]genopt "$(MMS$TARGET)/Append" "|" "$(obj3)"
+$(DBG)libperl$(OLB) : $(obj)
+ @ If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)
+ Library/Object/Replace $(MMS$TARGET) $(obj1)
+ Library/Object/Replace $(MMS$TARGET) $(obj2)
+ Library/Object/Replace $(MMS$TARGET) $(obj3)
-perlmain.c : miniperlmain.c miniperl$(E)
- MCR Sys$Disk:[]Miniperl$(E) [.VMS]Writemain.pl $(EXT)
+perlmain.c : miniperlmain.c $(MINIPERL_EXE) [.vms]writemain.pl
+ $(MINIPERL) [.VMS]Writemain.pl "$(EXT)"
-perl$(E) : perlmain$(O) $(extobj), perlshr$(E), perlshr_attr.opt $(CRTL)
+perl$(E) : perlmain$(O), perlshr$(E), perlshr_attr.opt $(MINIPERL_EXE)
@ @[.vms]genopt "PerlShr.Opt/Write" "|" "''F$Environment("Default")'$(DBG)PerlShr$(E)/Share"
- Link $(LINKFLAGS)/Exe=$(DBG)$(MMS$TARGET) perlmain$(O) $(extobj),[]perlshr.opt/Option,perlshr_attr.opt/Option
-shr_objs = perlshr$(O) ,perl$(O), $(obj)
-perlshr$(E) : $(shr_objs) ,perlshr_xtras.ts ,coreobjs.opt ,$(CRTL)
- Link $(LINKFLAGS)/Share/Exe=$(DBG)$(MMS$TARGET) perlshr$(O), perl$(O), coreobjs.opt/Option $(SYMOPT) , perlshr_attr.opt/Option, perlshr_sym.opt/Option $(CRTLOPTS)
-perlshr$(O) : [.vms]perlshr.c
- $(CC) $(CFLAGS)/NoOptimize/Object=$(MMS$TARGET) $(MMS$SOURCE)
+ 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
+ Link $(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, perlshr_sym.opt - VAX and AXP
-# perlshr_gbl*.mar, perlshr_gbl*$(O), perlshr_gbl.opt - VAX only
+# perlshr_attr.opt, $(DBG)perlshr_bld.opt - VAX and AXP
+# perlshr_gbl*.mar, perlshr_gbl*$(O) - VAX only
.ifdef DECC_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.
-perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl miniperl$(E) $(MAKEFILE)
+$(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
- MCR Sys$Disk:[]Miniperl$(E) [.vms]gen_shrfls.pl "~~NOCC~~perl.i" $(O)
+ $(MINIPERL) [.vms]gen_shrfls.pl "~~NOCC~~perl.i" "$(O)" "$(DBG)" "$(OLB)" "$(EXT)" "$(CRTL)"
@ Delete/NoLog/NoConfirm perl.i;
- @ Copy NLA0: perlshr_xtras.ts
- @ Purge/NoLog/NoConfirm perlshr_xtras.ts
+ @ If F$Search("$(DBG)perlshr_xtras.ts").nes."" Then Delete/NoLog/NoConfirm $(DBG)perlshr_xtras.ts;*
+ @ Copy NLA0: $(DBG)perlshr_xtras.ts
.else
-perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl miniperl$(E) $(MAKEFILE)
- MCR Sys$Disk:[]Miniperl$(E) [.vms]gen_shrfls.pl "$(CC)$(CFLAGS)" $(O)
- @ Copy NLA0: perlshr_xtras.ts
- @ Purge/NoLog/NoConfirm perlshr_xtras.ts
+$(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)"
+ @ If F$Search("$(DBG)perlshr_xtras.ts").nes."" Then Delete/NoLog/NoConfirm $(DBG)perlshr_xtras.ts;*
+ @ Copy NLA0: $(DBG)perlshr_xtras.ts
.endif
-[.lib]config.pm : [.vms]config.vms [.vms]genconfig.pl miniperl$(E)
- MCR Sys$Disk:[]Miniperl$(E) [.VMS]GenConfig.Pl
- MCR Sys$Disk:[]Miniperl$(E) ConfigPM.
+[.lib]config.pm : [.vms]config.vms [.vms]genconfig.pl $(MINIPERL_EXE)
+ $(MINIPERL) [.VMS]GenConfig.Pl cc=$(CC)$(CFLAGS) ldflags=$(LINKFLAGS)
+ $(MINIPERL) ConfigPM.
-[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs miniperl$(E)
+[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs $(MINIPERL_EXE)
$(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET)
[.ext.dynaloader]dl_vms$(O) : [.ext.dynaloader]dl_vms.c
$(CC) $(CFLAGS) /Object=$(MMS$TARGET) $(MMS$SOURCE)
-preplibrary : miniperl$(E) [.lib]Config.pm
- @ Create/Directory [.lib.auto]
- MCR Sys$Disk:[]Miniperl$(E) "-Ilib" -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm
-
-[.lib]DynaLoader.pm : [.ext.dynaloader]dynaloader.pm preplibrary
+[.lib]DynaLoader.pm : [.ext.dynaloader]dynaloader.pm
Copy/Log/NoConfirm [.ext.dynaloader]dynaloader.pm [.lib]DynaLoader.pm
- MCR Sys$Disk:[]Miniperl$(E) autosplit DynaLoader
+
+[.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm
+ @ Create/Directory [.lib.VMS]
+ Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
+
+[.lib.ExtUtils]MM_VMS.pm : [.vms.ext]MM_VMS.pm
+ Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
+
+preplibrary : $(MINIPERL_EXE) [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm [.lib.ExtUtils]MM_VMS.pm
+ @ Write Sys$Output "Autosplitting Perl library . . ."
+ @ Create/Directory [.lib.auto]
+ @ $(MINIPERL) "-Ilib" -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm
.ifdef SOCKET
$(SOCKOBJ) : $(SOCKC) $(SOCKH)
Copy/Log/NoConfirm [.vms]$(SOCKH) []$(SOCKH)
.endif
-#opcode.h : opcode.pl
-# MCR Sys$Disk:[]Miniperl$(E) opcode.pl
+#opcode.h : opcode.pl $(MINIPERL_EXE)
+# $(MINIPERL) opcode.pl
perly.h : perly.c # Quick and dirty 'touch'
Copy/Log/NoConfirm perly.h; ;
test : perl$(E)
- @[.VMS]Test.Com
+# CORE subset for MakeMaker, so we can build Perl without sources
+# Should move to VMS installperl when we get one
+$(ARCHCORE)EXTERN.h : EXTERN.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)INTERN.h : INTERN.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)XSUB.h : XSUB.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)av.h : av.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)config.h : config.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)cop.h : cop.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)cv.h : cv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)embed.h : embed.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)form.h : form.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)gv.h : gv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)handy.h : handy.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)hv.h : hv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)keywords.h : keywords.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)mg.h : mg.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)op.h : op.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)opcode.h : opcode.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)patchlevel.h : patchlevel.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)perl.h : perl.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)perly.h : perly.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)pp.h : pp.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)proto.h : proto.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)regcomp.h : regcomp.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)regexp.h : regexp.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)scope.h : scope.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)sv.h : sv.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)util.h : util.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)vmsish.h : vmsish.h
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+.ifdef SOCKET
+$(ARCHCORE)$(SOCKH) : $(SOCKH)
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+.endif
+$(ARCHCORE)$(DBG)libperl$(OLB) : $(DBG)libperl$(OLB) $(DBG)perlshr_xtras.ts
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)perlshr_attr.opt : $(DBG)perlshr_xtras.ts
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log perlshr_attr.opt $(MMS$TARGET)
+$(ARCHCORE)$(DBG)perlshr_bld.opt : $(DBG)perlshr_xtras.ts
+ @ Create/Directory $(ARCHCORE)
+ Copy/Log $(DBG)perlshr_bld.opt $(MMS$TARGET)
+$(ARCHAUTO)time.stamp :
+ @ Create/Directory $(ARCHAUTO)
+ @ If F$Search("$(MMS$TARGET)").eqs."" Then Copy/NoConfirm _NLA0: $(MMS$TARGET)
+
# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
-# If this runs make out of memory, delete /usr/include lines.
av$(O) : EXTERN.h
av$(O) : av.c
av$(O) : av.h
hv$(O) : sv.h
hv$(O) : vmsish.h
hv$(O) : util.h
-malloc$(O) : EXTERN.h
-malloc$(O) : av.h
-malloc$(O) : config.h
-malloc$(O) : cop.h
-malloc$(O) : cv.h
-malloc$(O) : embed.h
-malloc$(O) : form.h
-malloc$(O) : gv.h
-malloc$(O) : handy.h
-malloc$(O) : hv.h
-malloc$(O) : malloc.c
-malloc$(O) : mg.h
-malloc$(O) : op.h
-malloc$(O) : opcode.h
-malloc$(O) : perl.h
-malloc$(O) : pp.h
-malloc$(O) : proto.h
-malloc$(O) : regexp.h
-malloc$(O) : scope.h
-malloc$(O) : sv.h
-malloc$(O) : vmsish.h
-malloc$(O) : util.h
mg$(O) : EXTERN.h
mg$(O) : av.h
mg$(O) : config.h
mg$(O) : sv.h
mg$(O) : vmsish.h
mg$(O) : util.h
+perl$(O) : EXTERN.h
+perl$(O) : av.h
+perl$(O) : config.h
+perl$(O) : cop.h
+perl$(O) : cv.h
+perl$(O) : embed.h
+perl$(O) : form.h
+perl$(O) : gv.h
+perl$(O) : handy.h
+perl$(O) : hv.h
+perl$(O) : mg.h
+perl$(O) : op.h
+perl$(O) : opcode.h
+perl$(O) : perl.c
+perl$(O) : perl.h
+perl$(O) : pp.h
+perl$(O) : proto.h
+perl$(O) : regexp.h
+perl$(O) : scope.h
+perl$(O) : sv.h
+perl$(O) : vmsish.h
+perl$(O) : util.h
perly$(O) : EXTERN.h
perly$(O) : av.h
perly$(O) : config.h
pp$(O) : sv.h
pp$(O) : vmsish.h
pp$(O) : util.h
+pp_ctl$(O) : EXTERN.h
+pp_ctl$(O) : av.h
+pp_ctl$(O) : config.h
+pp_ctl$(O) : cop.h
+pp_ctl$(O) : cv.h
+pp_ctl$(O) : embed.h
+pp_ctl$(O) : form.h
+pp_ctl$(O) : gv.h
+pp_ctl$(O) : handy.h
+pp_ctl$(O) : hv.h
+pp_ctl$(O) : mg.h
+pp_ctl$(O) : op.h
+pp_ctl$(O) : opcode.h
+pp_ctl$(O) : perl.h
+pp_ctl$(O) : pp_ctl.c
+pp_ctl$(O) : pp.h
+pp_ctl$(O) : proto.h
+pp_ctl$(O) : regexp.h
+pp_ctl$(O) : scope.h
+pp_ctl$(O) : sv.h
+pp_ctl$(O) : vmsish.h
+pp_ctl$(O) : util.h
+pp_hot$(O) : EXTERN.h
+pp_hot$(O) : av.h
+pp_hot$(O) : config.h
+pp_hot$(O) : cop.h
+pp_hot$(O) : cv.h
+pp_hot$(O) : embed.h
+pp_hot$(O) : form.h
+pp_hot$(O) : gv.h
+pp_hot$(O) : handy.h
+pp_hot$(O) : hv.h
+pp_hot$(O) : mg.h
+pp_hot$(O) : op.h
+pp_hot$(O) : opcode.h
+pp_hot$(O) : perl.h
+pp_hot$(O) : pp_hot.c
+pp_hot$(O) : pp.h
+pp_hot$(O) : proto.h
+pp_hot$(O) : regexp.h
+pp_hot$(O) : scope.h
+pp_hot$(O) : sv.h
+pp_hot$(O) : vmsish.h
+pp_hot$(O) : util.h
+pp_sys$(O) : EXTERN.h
+pp_sys$(O) : av.h
+pp_sys$(O) : config.h
+pp_sys$(O) : cop.h
+pp_sys$(O) : cv.h
+pp_sys$(O) : embed.h
+pp_sys$(O) : form.h
+pp_sys$(O) : gv.h
+pp_sys$(O) : handy.h
+pp_sys$(O) : hv.h
+pp_sys$(O) : mg.h
+pp_sys$(O) : op.h
+pp_sys$(O) : opcode.h
+pp_sys$(O) : perl.h
+pp_sys$(O) : pp_sys.c
+pp_sys$(O) : pp.h
+pp_sys$(O) : proto.h
+pp_sys$(O) : regexp.h
+pp_sys$(O) : scope.h
+pp_sys$(O) : sv.h
+pp_sys$(O) : vmsish.h
+pp_sys$(O) : util.h
regcomp$(O) : EXTERN.h
regcomp$(O) : INTERN.h
regcomp$(O) : av.h
cleanlis :
- If F$Search("*.Lis").nes."" Then Delete/NoConfirm/Log *.Lis;*
+ - If F$Search("*.CPP").nes."" Then Delete/NoConfirm/Log *.CPP;*
- If F$Search("*.Map").nes."" Then Delete/NoConfirm/Log *.Map;*
tidy : cleanlis
- If F$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar
- If F$Search("[.Ext.DynaLoader]DL_VMS$(O);-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O)
- If F$Search("[.Ext.DynaLoader]DL_VMS.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C
+ - If F$Search("[.VMS.Ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*.C
+ - If F$Search("[.VMS.Ext...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*$(O)
- If F$Search("[.Lib.Auto...]*.al;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]*.al
- - If F$Search("[.Lib.Auto...]autosplit.ts;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]autosplit.ts
+ - If F$Search("[.Lib.Auto...]autosplit.ix;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]autosplit.ix
+ - If F$Search("[.Lib]DynaLoader.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]DynaLoader.pm
+ - If F$Search("[.Lib.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log [.Lib.VMS]*.*
+ - If F$Search("[.Lib.ExtUtils]MM_VMS.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib.ExtUtils]MM_VMS.pm
+ - If F$Search("$(ARCHCORE)*.*").nes."" Then Purge/NoConfirm/Log $(ARCHCORE)*.*
clean : tidy
- - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_Attr.Opt
+ - If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
- If F$Search("*$(O);*") .nes."" Then Delete/NoConfirm/Log *$(O);*
- If F$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;*
- If F$Search("Config.SH").nes."" Then Delete/NoConfirm/Log Config.SH;*
- If F$Search("*.TS").nes."" Then Delete/NoConfirm/Log *.TS;*
- If F$Search("[.Ext.DynaLoader]DL_VMS$(O)").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O);*
- If F$Search("[.Ext.DynaLoader]DL_VMS.C").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.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);*
realclean : clean
- If F$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);*
+ - If F$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);*
- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*
- - If F$Search("[.Lib.Auto...]*.al;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;*
- - If F$Search("[.Lib.Auto...]autosplit.ts;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;*
+ - If F$Search("[.Lib.Auto...]*.al").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;*
+ - If F$Search("[.Lib.Auto...]autosplit.ix;-1").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ix;*
+ - If F$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;*
+ - If F$Search("[.Lib.VMS]*.*").nes."" Then Delete/NoConfirm/Log [.Lib.VMS...]*.*;*
+ - If F$Search("[.Lib.ExtUtils]MM_VMS.pm").nes."" Then Delete/NoConfirm/Log [.Lib.ExtUtils]MM_VMS.pm;*
+ - If F$Search("$(ARCHCORE)*.*").nes."" Then Delete/NoConfirm/Log $(ARCHCORE)*.*;*
cleansrc : clean
- - If F$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);*
- If F$Search("*.C;-1").nes."" Then Purge/NoConfirm/Log *.C
- If F$Search("*.H;-1").nes."" Then Purge/NoConfirm/Log *.H
- If F$Search("*.VMS;-1").nes."" Then Purge/NoConfirm/Log *.VMS
- - If F$Search("$(MAKEFILE);-1").nes."" Then Purge/NoConfirm/Log $(MAKEFILE)
- If F$Search("[.VMS]$(MAKEFILE);-1").nes."" Then Purge/NoConfirm/Log [.VMS]$(MAKEFILE)
- If F$Search("[.VMS]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.C
- If F$Search("[.VMS]*.H;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.H
- If F$Search("[.VMS]*.Pl;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.Pl
- If F$Search("[.VMS]*.VMS;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.VMS
+ - If F$Search("[.VMS...]*.pm;-1").nes."" Then Purge/NoConfirm/Log [.VMS...]*.pm
+ - If F$Search("[.VMS...]*.xs;-1").nes."" Then Purge/NoConfirm/Log [.VMS...]*.xs
- If F$Search("[.Lib.Auto...]*.al").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]*.al;*
- - If F$Search("[.Lib.Auto...]autosplit.ts;").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;*
- - If F$Search("[.Lib]Config.pm;").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
+ - If F$Search("[.Lib.Auto...]autosplit.ts").nes."" Then Delete/NoConfirm/Log [.Lib.Auto...]autosplit.ts;*
+ - If F$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
--- /dev/null
+# Perl hooks into the routines in vms.c for interconversion
+# of VMS and Unix file specification syntax.
+#
+# Version: 1.1
+# Author: Charles Bailey bailey@genetics.upenn.edu
+# Revised: 08-Mar-1995
+
+=head1 NAME
+
+VMS::Filespec - convert between VMS and Unix file specification syntax
+
+=head1 SYNOPSIS
+
+use VMS::Filespec;
+$vmsspec = vmsify('/my/Unix/file/specification');
+$unixspec = unixify('my:[VMS]file.specification');
+$path = pathify('my:[VMS.or.Unix.directory]specification.dir');
+$dirfile = fileify('my:[VMS.or.Unix.directory.specification]');
+$vmsdir = vmspath('my/VMS/or/Unix/directory/specification.dir');
+$unixdir = unixpath('my:[VMS.or.Unix.directory]specification.dir');
+candelete('my:[VMS.or.Unix]file.specification');
+
+=head1 DESCRIPTION
+
+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.
+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.
+
+If you're running under VMS, the routines in this package are special,
+in that they're automatically made available to any Perl script,
+whether you're running F<miniperl> or the full F<perl>. The C<use
+VMS::Filespec> or C<require VMS::Filespec; import VMS::Filespec ...>
+statement can be used to import the function names into the current
+package, but they're always available if you use the fully qualified
+name, whether or not you've mentioned the F<.pm> file in your script.
+If you're running under another OS and have installed this package, it
+behaves like a normal Perl extension (in fact, you're using Perl
+substitutes to emulate the necessary VMS system calls).
+
+Each of these routines accepts a file specification in either VMS or
+Unix syntax, and returns the converted file specification, ir undef if
+an error occurs. The conversions are, for the most part, simply
+string manipulations; the routines do not check the details of syntax
+(e.g. that only legal characters are used). There is one exception:
+when running under VMS, conversions from VMS syntax use the $PARSE
+service to expand specifications, so illegal syntax, or a relative
+directory specification which extends above the tope of the current
+directory path (e.g [---.foo] when in dev:[dir.sub]) will cause
+errors. In general, any legal file specification will be converted
+properly, but garbage input tends to produce garbage output.
+
+The routines provided are:
+
+=head2 vmsify
+
+Converts a file specification to VMS syntax.
+
+=head2 unixify
+
+Converts a file specification to Unix syntax.
+
+=head2 pathify
+
+Converts a directory specification to a path - that is, a string you
+can prepend to a file name to form a valid file specification. If the
+input file specification uses VMS syntax, the returned path does, too;
+likewise for Unix syntax (Unix paths are guaranteed to end with '/').
+
+=head2 fileify
+
+Converts a directory specification to the file specification of the
+directory file - that is, a string you can pass to functions like
+C<stat> or C<rmdir> to manipulate the directory file. If the
+input directory specification uses VMS syntax, the returned file
+specification does, too; likewise for Unix syntax.
+
+=head2 vmspath
+
+Acts like C<pathify>, but insures the returned path uses VMS syntax.
+
+=head2 unixpath
+
+Acts like C<pathify>, but insures the returned path uses Unix syntax.
+
+=head2 candelete
+
+Determines whether you have delete access to a file. If you do, C<candelete>
+returns true. If you don't, or its argument isn't a legal file specification,
+C<candelete> returns FALSE. Unlike other file tests, the argument to
+C<candelete> must be a file name (not a FileHandle), and, since it's an XSUB,
+it's a list operator, so you need to be careful about parentheses. Both of
+these restrictions may be removed in the future if the functionality of
+C<candelete> becomes part of the Perl core.
+
+=head1 REVISION
+
+This document was last revised 08-Mar-1995, for Perl 5.001.
+
+=cut
+
+package VMS::Filespec;
+
+# If you want to use this package on a non-VMS system, uncomment
+# the following line, and add AutoLoader to @ISA.
+# require AutoLoader;
+require Exporter;
+
+@ISA = qw( Exporter );
+@EXPORT = qw( &rmsexpand &vmsify &unixify &pathify
+ &fileify &vmspath &unixpath &candelete);
+
+1;
+
+
+__END__
+
+
+# The autosplit routines here are provided for use by non-VMS systems
+# They are not guaranteed to function identically to the XSUBs of the
+# same name, since they do not have access to the RMS system routine
+# sys$parse() (in particular, no real provision is made for handling
+# of complex DECnet node specifications). However, these routines
+# should be adequate for most purposes.
+
+# A sort-of sys$parse() replacement
+sub rmsexpand {
+ my($fspec,$defaults) = @_;
+ if (!$fspec) { return undef }
+ my($node,$dev,$dir,$name,$type,$ver,$dnode,$ddev,$ddir,$dname,$dtype,$dver);
+
+ $fspec =~ s/:$//;
+ $defaults = [] unless $defaults;
+ $defaults = [ $defaults ] unless ref($defaults) && ref($defaults) eq 'ARRAY';
+
+ while ($fspec !~ m#[:>\]]# && $ENV{$fspec}) { $fspec = $ENV{$fspec} }
+
+ if ($fspec =~ /:/) {
+ my($dev,$devtrn,$base);
+ ($dev,$base) = split(/:/,$fspec);
+ $devtrn = $dev;
+ while ($devtrn = $ENV{$devtrn}) {
+ if ($devtrn =~ /(.)([:>\]])$/) {
+ $dev .= ':', last if $1 eq '.';
+ $dev = $devtrn, last;
+ }
+ }
+ $fspec = $dev . $base;
+ }
+
+ ($node,$dev,$dir,$name,$type,$ver) = $fspec =~
+ /([^:]*::)?([^:]*:)?([^>\]]*[>\]])?([^.;]*)(\.?[^.;]*)([.;]?\d*)/;
+ foreach ((@$defaults,$ENV{'DEFAULT'})) {
+ last if $node && $ver && $type && $dev && $dir && $name;
+ ($dnode,$ddev,$ddir,$dname,$dtype,$dver) =
+ /([^:]*::)?([^:]*:)?([^>\]]*[>\]])?([^.;]*)(\.?[^.;]*)([.;]?\d*)/;
+ $node = $dnode if $dnode && !$node;
+ $dev = $ddev if $ddev && !$dev;
+ $dir = $ddir if $ddir && !$dir;
+ $name = $dname if $dname && !$name;
+ $type = $dtype if $dtype && !$type;
+ $ver = $dver if $dver && !$ver;
+ }
+ # do this the long way to keep -w happy
+ $fspec = '';
+ $fspec .= $node if $node;
+ $fspec .= $dev if $dev;
+ $fspec .= $dir if $dir;
+ $fspec .= $name if $name;
+ $fspec .= $type if $type;
+ $fspec .= $ver if $ver;
+ $fspec;
+}
+
+sub vmsify {
+ my($fspec) = @_;
+ my($hasdev,$dev,$defdirs,$dir,$base,@dirs,@realdirs);
+
+ if ($fspec =~ m#^\.(\.?)/?$#) { return $1 ? '[-]' : '[]'; }
+ return $fspec if $fspec !~ m#/#;
+ ($hasdev,$dir,$base) = $fspec =~ m#(/?)(.*)/(.*)#;
+ @dirs = split(m#/#,$dir);
+ if ($base eq '.') { $base = ''; }
+ elsif ($base eq '..') {
+ push @dirs,$base;
+ $base = '';
+ }
+ foreach (@dirs) {
+ next unless $_; # protect against // in input
+ next if $_ eq '.';
+ if ($_ eq '..') {
+ if (@realdirs && $realdirs[$#realdirs] ne '-') { pop @realdirs }
+ else { push @realdirs, '-' }
+ }
+ else { push @realdirs, $_; }
+ }
+ if ($hasdev) {
+ $dev = shift @realdirs;
+ @realdirs = ('000000') unless @realdirs;
+ $base = '' unless $base; # keep -w happy
+ $dev . ':[' . join('.',@realdirs) . "]$base";
+ }
+ else {
+ '[' . join('',map($_ eq '-' ? $_ : ".$_",@realdirs)) . "]$base";
+ }
+}
+
+sub unixify {
+ my($fspec) = @_;
+
+ return $fspec if $fspec !~ m#[:>\]]#;
+ return '.' if ($fspec eq '[]' || $fspec eq '<>');
+ if ($fspec =~ m#^[<\[](\.|-+)(.*)# ) {
+ $fspec = ($1 eq '.' ? '' : "$1.") . $2;
+ my($dir,$base) = split(/[\]>]/,$fspec);
+ my(@dirs) = grep($_,split(m#\.#,$dir));
+ if ($dirs[0] =~ /^-/) {
+ my($steps) = shift @dirs;
+ for (1..length($steps)) { unshift @dirs, '..'; }
+ }
+ join('/',@dirs) . "/$base";
+ }
+ else {
+ $fspec = rmsexpand($fspec,'_N_O_T_:[_R_E_A_L_]');
+ $fspec =~ s/.*_N_O_T_:(?:\[_R_E_A_L_\])?//;
+ my($dev,$dir,$base) = $fspec =~ m#([^:<\[]*):?[<\[](.*)[>\]](.*)#;
+ my(@dirs) = split(m#\.#,$dir);
+ if ($dirs[0] && $dirs[0] =~ /^-/) {
+ my($steps) = shift @dirs;
+ for (1..length($steps)) { unshift @dirs, '..'; }
+ }
+ "/$dev/" . join('/',@dirs) . "/$base";
+ }
+}
+
+
+sub fileify {
+ my($path) = @_;
+
+ if (!$path) { return undef }
+ if ($path =~ /(.+)\.([^:>\]]*)$/) {
+ $path = $1;
+ if ($2 !~ /^dir(?:;1)?$/i) { return undef }
+ }
+
+ if ($path !~ m#[/>\]]#) {
+ $path =~ s/:$//;
+ while ($ENV{$path}) {
+ ($path = $ENV{$path}) =~ s/:$//;
+ last if $path =~ m#[/>\]]#;
+ }
+ }
+ if ($path =~ m#[>\]]#) {
+ my($dir,$sep,$base) = $path =~ /(.*)([>\]])(.*)/;
+ $sep =~ tr/<[/>]/;
+ if ($base) {
+ "$dir$sep$base.dir;1";
+ }
+ else {
+ if ($dir !~ /\./) { $dir =~ s/([<\[])/${1}000000./; }
+ $dir =~ s#\.(\w+)$#$sep$1#;
+ $dir =~ s/^.$sep//;
+ "$dir.dir;1";
+ }
+ }
+ else {
+ $path =~ s#/$##;
+ "$path.dir;1";
+ }
+}
+
+sub pathify {
+ my($fspec) = @_;
+
+ if (!$fspec) { return undef }
+ if ($fspec =~ m#[/>\]]$#) { return $fspec; }
+ if ($fspec =~ m#(.+)\.([^/>\]]*)$# && $2 && $2 ne '.') {
+ $fspec = $1;
+ if ($2 !~ /^dir(?:;1)?$/i) { return undef }
+ }
+
+ if ($fspec !~ m#[/>\]]#) {
+ $fspec =~ s/:$//;
+ while ($ENV{$fspec}) {
+ if ($ENV{$fspec} =~ m#[>\]]$#) { return $ENV{$fspec} }
+ else { $fspec = $ENV{$fspec} =~ s/:$// }
+ }
+ }
+
+ if ($fspec !~ m#[>\]]#) { "$fspec/"; }
+ else {
+ if ($fspec =~ /([^>\]]+)([>\]])(.+)/) { "$1.$3$2"; }
+ else { $fspec; }
+ }
+}
+
+sub vmspath {
+ pathify(vmsify($_[0]));
+}
+
+sub unixpath {
+ pathify(unixify($_[0]));
+}
+
+sub candelete {
+ my($fspec) = @_;
+ my($parent);
+
+ return '' unless -w $fspec;
+ $fspec =~ s#/$##;
+ if ($fspec =~ m#/#) {
+ ($parent = $fspec) =~ s#/[^/]+$#;
+ return (-w $parent);
+ }
+ elsif ($parent = fileify($fspec)) { # fileify() here to expand lnms
+ $parent =~ s/[>\]][^>\]]+//;
+ return (-w fileify($parent));
+ }
+ else { return (-w '[-]'); }
+}
use Config;
require Exporter;
+use VMS::Filespec;
+use File::Basename;
+
+Exporter::import('ExtUtils::MakeMaker',
+ qw(%att %skip %Recognized_Att_Keys $Verbose &neatvalue));
+
+
+sub fixpath {
+ my($path) = @_;
+ my($head,$macro,$tail);
+
+ while (($head,$macro,$tail) = ($path =~ m#(.*?)\$\((\S+?)\)/(.*)#)) {
+ ($macro = unixify($att{$macro})) =~ s#/$##;
+ $path = "$head$macro/$tail";
+ }
+ vmsify($path);
+}
+
+
+sub init_others {
+ &MM_Unix::init_others;
+ $att{NOOP} = "\tContinue";
+ $att{MAKEFILE} = '$(MAKEFILE)';
+ $att{RM_F} = '$(PERL) -e "foreach (@ARGV) { -d $_ ? rmdir $_ : unlink $_}"';
+ $att{RM_RF} = '$(PERL) -e "use File::Path; use VMS::Filespec; @dirs = map(unixify($_),@ARGV); rmtree(\@dirs,0,0)"';
+ $att{TOUCH} = '$(PERL) -e "$t=time; utime $t,$t,@ARGV"';
+ $att{CP} = 'Copy/NoConfirm';
+ $att{MV} = 'Rename/NoConfirm';
+}
+
+sub constants {
+ my(@m,$def);
+ push @m, "
+NAME = $att{NAME}
+DISTNAME = $att{DISTNAME}
+VERSION = $att{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 = ",vmspath($att{INST_LIB}),"
+INST_ARCHLIB = ",vmspath($att{INST_ARCHLIB}),"
+INST_EXE = ",vmspath($att{INST_EXE}),"
+
+# Perl library to use when building the extension
+PERL_LIB = ",vmspath($att{PERL_LIB}),"
+PERL_ARCHLIB = ",vmspath($att{PERL_ARCHLIB}),"
+LIBPERL_A = ",vmsify($att{LIBPERL_A}),"
+";
+
+# Define I_PERL_LIBS to include the required -Ipaths
+# To be cute we only include PERL_ARCHLIB if different
+# To be portable we add quotes for VMS
+my(@i_perl_libs) = qw{-I$(PERL_ARCHLIB) -I$(PERL_LIB)};
+shift(@i_perl_libs) if ($att{PERL_ARCHLIB} eq $att{PERL_LIB});
+push @m, "I_PERL_LIBS = \"".join('" "',@i_perl_libs)."\"\n";
+
+if ($att{PERL_SRC}) {
+ push @m, "
+# Where is the perl source code located?
+PERL_SRC = ",vmspath($att{PERL_SRC});
+}
+ push @m,"
+# Perl header files (will eventually be under PERL_LIB)
+PERL_INC = ",vmspath($att{PERL_INC}),"
+# Perl binaries
+PERL = $att{PERL}
+FULLPERL = $att{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 = ",vmsify($att{FULLEXT}),"
+BASEEXT = $att{BASEEXT}
+ROOTEXT = ",($att{ROOTEXT} eq '') ? '[]' : vmspath($att{ROOTEXT}),"
+
+INC = ";
+
+ if ($att{'INC'}) {
+ push @m,'/Include=(';
+ my(@includes) = split(/\s+/,$att{INC});
+ foreach (@includes) {
+ s/^-I//;
+ push @m,vmspath($_);
+ }
+ push @m, ")\n";
+ }
+
+ if ($att{DEFINE} ne '') {
+ my(@defs) = split(/\s+/,$att{DEFINE});
+ foreach $def (@defs) {
+ $def =~ s/^-D//;
+ $def = "\"$def\"" if $def =~ /=/;
+ }
+ $att{DEFINE} = join ',',@defs;
+ }
+
+ push @m,"
+DEFINE = $att{DEFINE}
+OBJECT = ",vmsify($att{OBJECT}),"
+LDFROM = ",vmsify($att{LDFROM}),"
+LINKTYPE = $att{LINKTYPE}
+
+# Handy lists of source code files:
+XS_FILES = ",join(', ', sort keys %{$att{XS}}),"
+C_FILES = ",join(', ', @{$att{C}}),"
+O_FILES = ",join(', ', @{$att{O_FILES}}),"
+H_FILES = ",join(', ', @{$att{H}}),"
+
+.SUFFIXES : .xs
+
+# This extension may link to it's own library (see SDBM_File)";
+ push @m,"
+MYEXTLIB = ",vmsify($att{MYEXTLIB}),"
+
+# Here is the Config.pm that we are using/depend on
+CONFIGDEP = \$(PERL_ARCHLIB)Config.pm, \$(PERL_INC)config.h
+
+# Where to put things:
+INST_LIBDIR = ",($att{'INST_LIBDIR'} = vmspath(unixpath($att{INST_LIB}) . unixpath($att{ROOTEXT}))),"
+INST_ARCHLIBDIR = ",($att{'INST_ARCHLIBDIR'} = vmspath(unixpath($att{INST_ARCHLIB}) . unixpath($att{ROOTEXT}))),"
+
+INST_AUTODIR = ",($att{'INST_AUTODIR'} = vmspath(unixpath($att{INST_LIB}) . 'auto/' . unixpath($att{FULLEXT}))),'
+INST_ARCHAUTODIR = ',($att{'INST_ARCHAUTODIR'} = vmspath(unixpath($att{INST_ARCHLIB}) . 'auto/' . unixpath($att{FULLEXT}))),'
+
+INST_STATIC = $(INST_ARCHAUTODIR)$(BASEEXT).olb
+INST_DYNAMIC = $(INST_ARCHAUTODIR)$(BASEEXT).$(DLEXT)
+INST_BOOT = $(INST_ARCHAUTODIR)$(BASEEXT).bs
+INST_PM = ',join(', ',map(fixpath($_),sort values %{$att{PM}})),'
+';
+
+ join('',@m);
+}
+
+
+sub const_cccmd {
+ my($cmd) = $Config{'cc'};
+ my($name,$sys,@m);
+
+ ( $name = $att{NAME} . "_cflags" ) =~ s/:/_/g ;
+ print STDOUT "Unix shell script ".$Config{"$att{'BASEEXT'}_cflags"}.
+ " required to modify CC command for $att{'BASEEXT'}\n"
+ if ($Config{$name});
+
+ # Deal with $att{DEFINE} here since some C compilers pay attention
+ # to only one /Define clause on command line, so we have to
+ # conflate the ones from $Config{'cc'} and $att{DEFINE}
+ if ($att{DEFINE} ne '') {
+ if ($cmd =~ m:/define=\(?([^\(\/\)]+)\)?:i) {
+ $cmd = $` . "/Define=(" . $1 . ",$att{DEFINE})" . $';
+ }
+ else { $cmd .= "/Define=($att{DEFINE})" }
+ }
+
+ $sys = ($cmd =~ /^gcc/i) ? 'GNU_CC_Include:[VMS]' : 'Sys$Library';
+ push @m,'
+.FIRST
+ @ If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS ',$sys,'
+
+';
+ push(@m, "CCCMD = $cmd\n");
+
+ join('',@m);
+}
+
+
+
+sub const_loadlibs{
+ my (@m);
+ push @m, "
+# $att{NAME} might depend on some other libraries.
+#
+# Dependent libraries are linked in either by the Link command
+# at build time or by the DynaLoader at bootstrap time.
+#
+# These comments may need revising:
+#
+# EXTRALIBS = Full list of libraries needed for static linking.
+# Only those libraries that actually exist are included.
+#
+# BSLOADLIBS = List of those libraries that are needed but can be
+# linked in dynamically.
+#
+# LDLOADLIBS = List of those libraries which must be statically
+# linked into the shared library.
+#
+EXTRALIBS = ",map(vmsify($_) . ' ',$att{'EXTRALIBS'}),"
+BSLOADLIBS = ",map(vmsify($_) . ' ',$att{'BSLOADLIBS'}),"
+LDLOADLIBS = ",map(vmsify($_) . ' ',$att{'LDLOADLIBS'}),"\n";
+
+ join('',@m);
+}
+
+# --- Tool Sections ---
+
+sub tool_autosplit{
+ my($self, %attribs) = @_;
+ my($asl) = "";
+ $asl = "\$AutoSplit::Maxlen=$attribs{MAXLEN};" if $attribs{MAXLEN};
+ q{
+# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
+AUTOSPLITFILE = $(PERL) $(I_PERL_LIBS) -e "use AutoSplit;}.$asl.q{ AutoSplit::autosplit($ARGV[0], $ARGV[1], 0, 1, 1) ;"
+};
+}
+
+sub tool_xsubpp{
+ my($xsdir) = unixpath($att{PERL_LIB}).'ExtUtils';
+ # drop back to old location if xsubpp is not in new location yet
+ $xsdir = unixpath($att{PERL_SRC}).'ext' unless (-f "$xsdir/xsubpp");
+ my(@tmdeps) = '$(XSUBPPDIR)typemap';
+ push(@tmdeps, "typemap") if -f "typemap";
+ my(@tmargs) = map("-typemap $_", @tmdeps);
+ "
+XSUBPPDIR = ".vmspath($xsdir)."
+XSUBPP = \$(PERL) \$(XSUBPPDIR)xsubpp
+XSUBPPDEPS = @tmdeps
+XSUBPPARGS = @tmargs
+";
+}
+
+sub tools_other {
+ "
+# Assumes \$(MMS) invokes MMS or MMK
+USEMAKEFILE = /Descrip=
+USEMACROS = /Macro=(
+MACROEND = )
+MAKEFILE = Descrip.MMS
+SHELL = Posix
+LD = $att{LD}
+TOUCH = $att{TOUCH}
+CP = $att{CP}
+RM_F = $att{RM_F}
+RM_RF = $att{RM_RF}
+MKPATH = Create/Directory
+";
+}
+
+
+# --- Translation Sections ---
+
+sub c_o {
+ '
+.c.obj :
+ $(CCCMD) $(CCCDLFLAGS) /Include=($(PERL_INC)) $(INC) $(MMS$TARGET_NAME).c
+';
+}
+
+sub xs_c {
+ '
+.xs.c :
+ $(XSUBPP) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET)
+';
+}
+
+sub xs_o { # many makes are too dumb to use xs_c then c_o
+ '
+.xs.obj :
+ $(XSUBPP) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).c
+ $(CCCMD) $(CCCDLFLAGS) /Include=($(PERL_INC)) $(INC) $(MMS$TARGET_NAME).c
+';
+}
+
+
+# --- Target Sections ---
+
+sub top_targets{
+ my(@m);
+ push @m, '
+all :: config linkext $(INST_PM)
+'.$att{NOOP}.'
+
+config :: '.$att{MAKEFILE}.'
+ @ $(MKPATH) $(INST_LIBDIR), $(INST_ARCHAUTODIR)
+';
+ push @m, '
+$(O_FILES) : $(H_FILES)
+' if @{$att{O_FILES} || []} && @{$att{H} || []};
+ join('',@m);
+}
+
+sub dlsyms {
+ my($self,%attribs) = @_;
+ my($funcs) = $attribs{DL_FUNCS} || $att{DL_FUNCS} || {};
+ my($vars) = $attribs{DL_VARS} || $att{DL_VARS} || [];
+ my(@m);
+
+ push(@m,'
+dynamic :: perlshr.opt $(BASEEXT).opt
+ ',$att{NOOP},'
+
+perlshr.opt : makefile.PL
+ $(PERL) -e "open O,\'>perlshr.opt\'; print O ""PerlShr/Share\n""; close O"
+') unless $skip{'dynamic'};
+
+ push(@m,'
+static :: $(BASEEXT).opt
+ ',$att{NOOP},'
+') unless $skip{'static'};
+
+ push(@m,'
+$(BASEEXT).opt : makefile.PL
+ $(PERL) $(I_PERL_LIBS) -e "use ExtUtils::MakeMaker; mksymlists(DL_FUNCS => ',neatvalue($att{DL_FUNCS}),', DL_VARS => ',neatvalue($att{DL_VARS}),',NAME => ',$att{NAME},')"
+ $(PERL) $(I_PERL_LIBS) -e "open OPT,\'>>$(MMS$TARGET)\'; print OPT ""$(INST_STATIC)/Include=$(BASEEXT)\n$(INST_STATIC)/Library\n"";close OPT"
+');
+
+ join('',@m);
+}
+
+
+# --- Dynamic Loading Sections ---
+
+sub dynamic_lib {
+ my($self, %attribs) = @_;
+ my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
+ my(@m);
+ push @m,"
+
+OTHERLDFLAGS = $otherldflags
+
+";
+ push @m, '
+$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt perlshr.opt $(BASEEXT).opt
+ @ $(MKPATH) $(INST_ARCHAUTODIR)
+ Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,perlshr.opt/Option,$(PERL_INC)perlshr_attr.opt/Option
+';
+
+ join('',@m);
+}
+
+sub dynamic_bs {
+ my($self, %attribs) = @_;
+ '
+BOOTSTRAP = '."$att{BASEEXT}.bs".'
+
+# As MakeMaker mkbootstrap might not write a file (if none is required)
+# we use touch to prevent make continually trying to remake it.
+# The DynaLoader only reads a non-empty file.
+$(BOOTSTRAP): '."$att{MAKEFILE} $att{BOOTDEP}".'
+ @ Write Sys$Output "Running mkbootstrap for $(NAME) ($(BSLOADLIBS))"
+ @ $(PERL) $(I_PERL_LIBS) -e "use ExtUtils::MakeMaker; &mkbootstrap(""$(BSLOADLIBS)"");" "INST_LIB=$(INST_LIB)" "INST_ARCHLIB=$(INST_ARCHLIB)" "PERL_SRC=$(PERL_SRC)" "NAME=$(NAME)"
+ @ $(TOUCH) $(BOOTSTRAP)
+
+$(INST_BOOT): $(BOOTSTRAP)
+ @ '.$att{RM_RF}.' $(INST_BOOT)
+ - '.$att{CP}.' $(BOOTSTRAP) $(INST_BOOT)
+';
+}
+# --- Static Loading Sections ---
+
+sub static_lib {
+ '
+$(INST_STATIC) : $(OBJECT), $(MYEXTLIB)
+ @ $(MKPATH) $(INST_ARCHAUTODIR)
+ If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)
+ Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)
+';
+}
+
+
+sub installpm_x { # called by installpm perl file
+ my($self, $dist, $inst, $splitlib) = @_;
+ $inst = fixpath($inst);
+ $dist = vmsify($dist);
+ my($instdir) = dirname($inst);
+ my(@m);
+
+ push(@m, "
+$inst : $dist $att{MAKEFILE}
+",' @ ',$att{RM_F},' $(MMS$TARGET);*
+ @ $(MKPATH) ',$instdir,'
+ @ ',$att{CP},' $(MMS$SOURCE) $(MMS$TARGET)
+');
+ if ($splitlib and $inst =~ /\.pm$/) {
+ my($attdir) = $splitlib;
+ $attdir =~ s/\$\((.*)\)/$1/;
+ $attdir = $att{$attdir} if $att{$attdir};
+
+ push(@m, ' $(AUTOSPLITFILE) $(MMS$TARGET) ',
+ vmspath(unixpath($attdir) . 'auto')."\n");
+ push(@m,"\n");
+ }
+
+ join('',@m);
+}
+
+
+# --- Sub-directory Sections ---
+
+sub exescan {
+ vmsify($_);
+}
+
+sub subdir_x {
+ my($self, $subdir) = @_;
+ my(@m);
+ # The intention is that the calling Makefile.PL should define the
+ # $(SUBDIR_MAKEFILE_PL_ARGS) make macro to contain whatever
+ # information needs to be passed down to the other Makefile.PL scripts.
+ # If this does not suit your needs you'll need to write your own
+ # MY::subdir_x() method to override this one.
+ push @m, '
+config :: ',vmspath($subdir) . '$(MAKEFILE)
+ $(MMS) $(USEMAKEFILE) $(MMS$SOURCE) config $(USEMACROS)(INST_LIB=$(INST_LIB),INST_ARCHLIB=$(INST_ARCHLIB), \\
+ LINKTYPE=$(LINKTYPE),INST_EXE=$(INST_EXE),LIBPERL_A=$(LIBPERL_A)$(MACROEND) $(SUBDIR_MAKEFILE_PL_ARGS)
+
+',vmspath($subdir),'$(MAKEFILE) : ',vmspath($subdir),'Makefile.PL, $(CONFIGDEP)
+ @Write Sys$Output "Rebuilding $(MMS$TARGET) ..."
+ $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::MakeMaker; MM->runsubdirpl(qw('.$subdir.'))" \\
+ $(SUBDIR_MAKEFILE_PL_ARGS) INST_LIB=$(INST_LIB) INST_ARCHLIB=$(INST_ARCHLIB) \\
+ INST_EXE=$(INST_EXE) LIBPERL_A=$(LIBPERL_A) LINKTYPE=$(LINKTYPE)
+ @Write Sys$Output "Rebuild of $(MMS$TARGET) complete."
+
+# The default clean, realclean and test targets in this Makefile
+# have automatically been given entries for $subdir.
+
+subdirs ::
+ Set Default ',vmspath($subdir),'
+ $(MMS) all $(USEMACROS)LINKTYPE=$(LINKTYPE)$(MACROEND)
+';
+ join('',@m);
+}
+
+
+# --- Cleanup and Distribution Sections ---
+
+sub clean {
+ my($self, %attribs) = @_;
+ my(@m);
+ push @m, '
+# Delete temporary files but do not touch installed files
+# We don\'t delete the Makefile here so that a
+# later make realclean still has a makefile to work from
+clean ::
+';
+ foreach (@{$att{DIR}}) { # clean subdirectories first
+ my($vmsdir) = vmspath($_);
+ push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)") Then $(MMS) $(USEMAKEFILE)'.$vmsdir.'$(MAKEFILE) clean'."\n");
+ }
+ push @m, "
+ $att{RM_F} *.Map;* *.lis;* *.cpp;* *.Obj;* *.Olb;* \$(BOOTSTRAP);* \$(BASEEXT).bso;*
+";
+
+ my(@otherfiles) = values %{$att{XS}}; # .c files from *.xs files
+ push(@otherfiles, $attribs{FILES}) if $attribs{FILES};
+ push(@otherfiles, "blib.dir");
+ push(@m, " $att{RM_F} ".join(";* ", map(fixpath($_),@otherfiles)),";*\n");
+ # See realclean and ext/utils/make_ext for usage of Makefile.old
+ push(@m, " $att{MV} $att{MAKEFILE} $att{MAKEFILE}_old");
+ push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP};
+ join('', @m);
+}
+
+
+sub realclean {
+ my($self, %attribs) = @_;
+ my(@m);
+ push(@m,'
+# Delete temporary files (via clean) and also delete installed files
+realclean :: clean
+');
+ foreach(@{$att{DIR}}){
+ my($vmsdir) = vmspath($_);
+ push(@m, ' If F$Search("'."$vmsdir$att{MAKEFILE}".'").nes."" Then $(MMS) $(USEMAKEFILE)'."$vmsdir$att{MAKEFILE}".' realclean'."\n");
+ push(@m, ' If F$Search("'."$vmsdir$att{MAKEFILE}".'_old").nes."" Then $(MMS) $(USEMAKEFILE)'."$vmsdir$att{MAKEFILE}".'_old realclean'."\n");
+ }
+ push @m,'
+ ',$att{RM_RF},' $(INST_AUTODIR) $(INST_ARCHAUTODIR)
+ ',$att{RM_F},' *.Opt;* $(INST_DYNAMIC);* $(INST_STATIC);* $(INST_BOOT);* $(INST_PM);*
+ ',$att{RM_F},' $(OBJECT);* $(MAKEFILE);* $(MAKEFILE)_old;*
+';
+ push(@m, " $att{RM_RF} ".join(";* ", map(fixpath($_),$attribs{'FILES'})),";*\n") if $attribs{'FILES'};
+ push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP};
+ join('', @m);
+}
+
+
+sub distclean {
+ my($self, %attribs) = @_;
+ my($preop) = $attribs{PREOP} || '@ !'; # e.g., update MANIFEST
+ my($zipname) = $attribs{TARNAME} || '$(DISTNAME)-$(VERSION)';
+ my($zipflags) = $attribs{ZIPFLAGS} || '-Vu';
+ my($postop) = $attribs{POSTOP} || "";
+ my($mkfiles) = join(' ', map("$_\$(MAKEFILE) $_\$(MAKEFILE)_old",map(vmspath($_),@{$att{'DIR'}})));
+
+ "
+distclean : clean
+ $preop
+ $att{RM_F} $mkfiles
+ Zip \"$zipflags\" $zipname \$(BASEEXT).* Makefile.PL
+ $postop
+";
+}
+
+
+# --- Test and Installation Sections ---
+
+sub test {
+ my($self, %attribs) = @_;
+ my($tests) = $attribs{TESTS} || ( -d 't' ? 't/*.t' : '');
+ my(@m);
+ push @m,'
+test : all
+';
+ push(@m,' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" $(I_PERL_LIBS) -e "use Test::Harness; runtests @ARGV;" '.$tests."\n")
+ if $tests;
+ push(@m,' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" $(I_PERL_LIBS) test.pl',"\n")
+ if -f 'test.pl';
+ foreach(@{$att{DIR}}){
+ my($vmsdir) = vmspath($_);
+ push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir \'',$vmsdir,
+ '\'; print `$(MMS) $(USEMAKEFILE)$(MAKEFILE) $(USEMACRO)LINKTYPE=$(LINKTYPE)$(MACROEND) test`'."\n");
+ }
+ push(@m, "\t\@echo 'No tests defined for \$(NAME) extension.'\n") unless @m > 1;
+
+ join('',@m);
+}
+
+sub install {
+ my($self, %attribs) = @_;
+ my(@m);
+ push @m, q{
+doc_install ::
+ @ $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" $(I_PERL_LIBS) \\
+ -e "use ExtUtils::MakeMaker; MM->writedoc('Module', '$(NAME)', \\
+ 'LINKTYPE=$(LINKTYPE)', 'VERSION=$(VERSION)', 'EXE_FILES=$(EXE_FILES)')"
+};
+
+ push(@m, "
+install :: pure_install doc_install
+
+pure_install :: all
+");
+ # install subdirectories first
+ foreach(@{$att{DIR}}){
+ my($vmsdir) = vmspath($_);
+ push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir \'',$vmsdir,
+ '\'; print `$(MMS) $(USEMAKEFILE)$(MAKEFILE) install`'."\n");
+ }
+
+ push(@m, "\t! perl5.000 used to autosplit into INST_ARCHLIB, we delete these old files here
+ $att{RM_F} ",fixpath(unixpath($Config{'installarchlib'}).'auto/$(FULLEXT)/*.al'),';* ',
+ fixpath(unixpath($Config{'installarchlib'}).'auto/$(FULLEXT)/*.ix'),";*
+ \$(MMS) \$(USEMACROS)INST_LIB=$Config{'installprivlib'},INST_ARCHLIB=$Config{'installarchlib'},INST_EXE=$Config{'installbin'}\$(MACROEND)
+");
+
+ join("",@m);
+}
+
+sub perldepend {
+ my(@m);
+
+ push @m, '
+$(OBJECT) : $(PERL_INC)EXTERN.h, $(PERL_INC)INTERN.h, $(PERL_INC)XSUB.h, $(PERL_INC)av.h
+$(OBJECT) : $(PERL_INC)cop.h, $(PERL_INC)cv.h, $(PERL_INC)embed.h, $(PERL_INC)form.h
+$(OBJECT) : $(PERL_INC)gv.h, $(PERL_INC)handy.h, $(PERL_INC)hv.h, $(PERL_INC)keywords.h
+$(OBJECT) : $(PERL_INC)mg.h, $(PERL_INC)op.h, $(PERL_INC)opcode.h, $(PERL_INC)patchlevel.h
+$(OBJECT) : $(PERL_INC)perl.h, $(PERL_INC)perly.h, $(PERL_INC)pp.h, $(PERL_INC)proto.h
+$(OBJECT) : $(PERL_INC)regcomp.h, $(PERL_INC)regexp.h, $(PERL_INC)scope.h, $(PERL_INC)sv.h
+$(OBJECT) : $(PERL_INC)vmsish.h, $(PERL_INC)util.h, $(PERL_INC)config.h
+
+';
+ push(@m,'
+
+$(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh
+ @ Write Sys$Error "$(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh"
+ Set Default $(PERL_SRC)
+ $(MMS) $(USEMAKEFILE)[.VMS]$(MAKEFILE) [.lib]config.pm
+');
+
+ push(@m, join(" ", map(vmsify($_),values %{$att{XS}}))." : \$(XSUBPPDEPS)\n")
+ if %{$att{XS}};
+
+ join('',@m);
+}
+
+sub makefile {
+ my(@m,@cmd);
+ push(@m,'
+
+# We take a very conservative approach here, but it\'s worth it.
+# We move $(MAKEFILE) to $(MAKEFILE)_old here to avoid gnu make looping.
+$(MAKEFILE) : Makefile.PL $(CONFIGDEP)
+ @ Write Sys$Output "',$att{MAKEFILE},' out-of-date with respect to $(MMS$SOURCE_LIST)"
+ @ Write Sys$Output "Cleaning current config before rebuilding ',$att{MAKEFILE},'...
+ - ',"$att{MV} $att{MAKEFILE} $att{MAKEFILE}_old",'
+ - $(MMS) $(USEMAKEFILE)',$att{MAKEFILE},'_old clean
+ $(PERL) $(I_PERL_LIBS) Makefile.PL
+ @ Write Sys$Output "Now you must rerun $(MMS)."
+');
+
+ join('',@m);
+}
+
+
+# --- Determine libraries to use and how to use them ---
+
+sub makeaperl {
+ my($self, %attribs) = @_;
+ my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) =
+ @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
+ my(@m);
+ my($linkcmd,@staticopts,@staticpkgs,$extralist,$target,$targdir,$libperldir);
+
+ # The front matter of the linkcommand...
+ $linkcmd = join ' ', $Config{'ld'},
+ grep($_, @Config{qw(large split ldflags ccdlflags)});
+ $linkcmd =~ s/\s+/ /g;
+
+ # Which *.olb files could we make use of...
+ local(%olbs);
+ File::Find::find(sub {
+ return unless m/\.olb$/;
+ return if m/^libperl/;
+ $olbs{$ENV{DEFAULT}} = $_;
+ }, grep( -d $_, @{$searchdirs || []}), grep( -f $_, @{$static || []}) );
+
+ $extra = [] unless $extra && ref $extra eq 'ARRAY';
+ # Sort the object libraries in inverse order of
+ # filespec length to try to insure that dependent extensions
+ # will appear before their parents, so the linker will
+ # search the parent library to resolve references.
+ # (e.g. Intuit::DWIM will precede Intuit, so unresolved
+ # references from [.intuit.dwim]dwim.obj can be found
+ # in [.intuit]intuit.olb).
+ for (sort keys %olbs) {
+ next unless $olbs{$_} =~ /\.olb$/;
+ my($dir) = vmspath($_);
+ my($extralibs) = $dir . "extralibs.ld";
+ my($extopt) = $dir . $olbs{$_};
+ $extopt =~ s/\.olb$/.opt/;
+ if (-f $extralibs ) {
+ open LIST,$extralibs or warn $!,next;
+ push @$extra, <LIST>;
+ close LIST;
+ }
+ if (-f $extopt) {
+ open OPT,$extopt or die $!;
+ while (<OPT>) {
+ next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/;
+ # ExtUtils::Miniperl expects Unix paths
+ (my($pkg) = "$2_$2.a") =~ s#_*#/#g;
+ push @staticpkgs,$pkg;
+ }
+ push @staticopts, $extopt;
+ }
+ }
+
+ $target = "Perl.Exe" unless $target;
+ ($shrtarget,$targdir) = fileparse($target);
+ $shrtarget =~ s/^([^.]*)/$1Shr/;
+ $shrtarget = $targdir . $shrtarget;
+ $target = "Perlshr$Config{'dlext'}" unless $target;
+ $tmp = "[]" unless $tmp;
+ $tmp = unixpath($tmp);
+ if (@$extra) {
+ $extralist = join(' ',@$extra);
+ $extralist =~ s/[,\s\n]+/, /g;
+ }
+ else { $extralist = ''; }
+ if ($libperl) {
+ unless (-f $libperl || -f ($libperl = unixpath($Config{'installarchlib'})."CORE/$libperl")){
+ print STDOUT "Warning: $libperl not found";
+ undef $libperl;
+ }
+ }
+ unless ($libperl) {
+ if (defined $att{PERL_SRC}) {
+ $libperl = "$att{PERL_SRC}/libperl.olb";
+ } elsif ( -f ( $libperl = unixpath($Config{'installarchlib'}).'CORE/libperl.olb' )) {
+ } else {
+ print STDOUT "Warning: $libperl not found";
+ }
+ }
+ $libperldir = vmspath((fileparse($libperl))[1]);
+
+ push @m, '
+# Fill in the target you want to produce if it\'s not perl
+MAP_TARGET = ',vmsify($target),'
+MAP_SHRTARGET = ',vmsify($shrtarget),"
+FULLPERL = $att{'FULLPERL'}
+MAP_LINKCMD = $linkcmd
+MAP_PERLINC = ", $perlinc ? map('"-I'.vmspath($_).'" ',@{$perlinc}) : '$(I_PERL_LIB)','
+# We use the linker options files created with each extension, rather than
+#specifying the object files directly on the command line.
+MAP_STATIC = ',@staticopts ? join(' ', @staticopts) : '','
+MAP_OPTS = ',@staticopts ? ','.join(',', map($_.'/Option', @staticopts)) : '',"
+MAP_EXTRA = $extralist
+MAP_LIBPERL = ",vmsify($libperl),'
+';
+
+
+ push @m,'
+$(MAP_SHRTARGET) : $(MAP_LIBPERL) $(MAP_STATIC) ',"${libperldir}Perlshr_Attr.Opt",'
+ $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_OPTS), $(MAP_EXTRA), $(MAP_LIBPERL) ',"${libperldir}Perlshr_Attr.Opt",'
+$(MAP_TARGET) : $(MAP_SHRTARGET) ',vmsify("${tmp}perlmain.obj"),' ',vmsify("${tmp}PerlShr.Opt"),'
+ $(MAP_LINKCMD) ',vmsify("${tmp}perlmain.obj"),', PerlShr.Opt/Option
+ @ Write Sys$Output "To install the new ""$(MAP_TARGET)"" binary, say"
+ @ Write Sys$Output " $(MMS)$(USEMAKEFILE)$(MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)"
+ @ Write Sys$Output "To remove the intermediate files, say
+ @ Write Sys$Output " $(MMS)$(USEMAKEFILE)$(MAKEFILE) map_clean"
+';
+ push @m,'
+',vmsify("${tmp}perlmain.c"),' : $(MAKEFILE)
+ @ $(PERL) $(MAP_PERLINC) -e "use ExtUtils::Miniperl; writemain(qw|',@staticpkgs,'|)" >$(MMS$TARGET)
+';
+
+ push @m, q{
+doc_inst_perl :
+ @ $(PERL) -e "use ExtUtils::MakeMaker; MM->writedoc('Perl binary','$(MAP_TARGET)','MAP_STATIC=$(MAP_STATIC)','MAP_EXTRA=$(MAP_EXTRA)','MAP_LIBPERL=$(MAP_LIBPERL)')"
+};
+
+ push @m, "
+inst_perl : pure_inst_perl doc_inst_perl
+
+pure_inst_perl : \$(MAP_TARGET)
+ $att{CP} \$(MAP_SHRTARGET) ",vmspath($Config{'installbin'}),"
+ $att{CP} \$(MAP_TARGET) ",vmspath($Config{'installbin'}),"
+
+map_clean :
+ $att{RM_F} ",vmsify("${tmp}perlmain.obj"),vmsify("${tmp}perlmain.c"),
+ vmsify("${tmp}PerlShr.Opt")," $makefilename
+";
+
+ join '', @m;
+}
+
+sub extliblist {
+ '','','';
+}
+
+sub old_extliblist {
+ '','',''
+}
+
+sub new_extliblist {
+ '','',''
+}
+
+# --- Write a DynaLoader bootstrap file if required
+
+# VMS doesn't require a bootstrap file as a rule
+sub mkbootstrap {
+ 1;
+}
+
+sub mksymlists {
+ my($self,%attribs) = @_;
+
+ MY->init_main() unless $att{BASEEXT};
+
+ my($vars) = $attribs{DL_VARS} || $att{DL_VARS} || [];
+ my($procs) = $attribs{DL_FUNCS} || $att{DL_FUNCS};
+ my($package,$packprefix,$sym);
+ if (!%$procs) {
+ $package = $attribs{NAME} || $att{NAME};
+ $package =~ s/\W/_/g;
+ $procs = { $package => ["boot_$package"] };
+ }
+ my($isvax) = $Config{'arch'} =~ /VAX/i;
+
+ # Options file declaring universal symbols
+ # Used when linking shareable image for dynamic extension,
+ # or when linking PerlShr into which we've added this package
+ # as a static extension
+ # We don't do anything to preserve order, so we won't relax
+ # the GSMATCH criteria for a dynamic extension
+ open OPT, ">$att{BASEEXT}.opt";
+ foreach $package (keys %$procs) {
+ ($packprefix = $package) =~ s/\W/_/g;
+ foreach $sym (@{$$procs{$package}}) {
+ $sym = "XS_${packprefix}_$sym" unless $sym =~ /^boot_/;
+ if ($isvax) { print OPT "UNIVERSAL=$sym\n" }
+ else { print OPT "SYMBOL_VECTOR=($sym=PROCEDURE)\n"; }
+ }
+ }
+ foreach $sym (@$vars) {
+ print OPT "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
+ if ($isvax) { print OPT "UNIVERSAL=$sym\n" }
+ else { print OPT "SYMBOL_VECTOR=($sym=DATA)\n"; }
+ }
+ close OPT;
+}
+
+# --- Output postprocessing section ---
+
+sub nicetext {
+ # Insure that colons marking targets are preceded by space -
+ # most Unix Makes don't need this, but it's necessary under VMS
+ # to distinguish the target delimiter from a colon appearing as
+ # part of a filespec.
+
+ my($self,$text) = @_;
+ $text =~ s/([^\s:])(:+\s)/$1 $2/gs;
+ $text;
+}
+
+1;
+
+__END__
+# MM_VMS.pm
+# MakeMaker default methods for VMS
+# This package is inserted into @ISA of MakeMaker's MM before the
+# built-in MM_Unix methods if MakeMaker.pm is run under VMS.
+#
+# Version: 4.03
+# Author: Charles Bailey bailey@genetics.upenn.edu
+# Revised: 30-Jan-1995
+
+package ExtUtils::MM_VMS;
+
+use Config;
+require Exporter;
use File::VMSspec;
use File::Basename;
--- /dev/null
+use ExtUtils::MakeMaker;
+
+WriteMakefile( 'VERSION' => '1.0' );
--- /dev/null
+# VMS::stdio - VMS extensions to Perl's stdio calls
+#
+# Author: Charles Bailey bailey@genetics.upenn.edu
+# Version: 1.0
+# Revised: 29-Nov-1994
+#
+# Revision History:
+# 1.0 29-Nov-1994 Charles Bailey bailey@genetics.upenn.edu
+# original version
+# 1.1 09-Mar-1995 Charles Bailey bailey@genetics.upenn.edu
+# changed calling sequence to return FH/undef - like POSIX::open
+# added fgetname and tmpnam
+
+=head1 NAME
+
+VMS::stdio
+
+=head1 SYNOPSIS
+
+use VMS::stdio;
+$name = fgetname(FH);
+$uniquename = &tmpnam;
+$fh = vmsfopen("my.file","rfm=var","alq=100",...) or die $!;
+
+=head1 DESCRIPTION
+
+This package gives Perl scripts access to VMS extensions to the
+C stdio routines, such as optional arguments to C<fopen()>.
+The specific routines are described below.
+
+=head2 fgetname
+
+The C<fgetname> function returns the file specification associated
+with a Perl FileHandle. If an error occurs, it returns C<undef>.
+
+=head2 tmpnam
+
+The C<tmpnam> function returns a unique string which can be used
+as a filename when creating temporary files. If, for some
+reason, it is unable to generate a name, it returns C<undef>.
+
+=head2 vmsfopen
+
+The C<vmsfopen> function provides access to the VMS CRTL
+C<fopen()> function. It is similar to the built-in Perl C<open>
+function (see L<perlfunc> for a complete description), but will
+only open normal files; it cannot open pipes or duplicate
+existing FileHandles. Up to 8 optional arguments may follow the
+file name. These arguments should be strings which specify
+optional file characteristics as allowed by the CRTL C<fopen()>
+routine. (See the CRTL reference manual for details.)
+
+You can use the FileHandle returned by C<vmsfopen> just as you
+would any other Perl FileHandle.
+
+C<vmsfopen> is a temporary solution to problems which arise in
+handling VMS-specific file formats; in the long term, we hope to
+provide more transparent access to VMS file I/O through routines
+which replace standard Perl C<open> function, or through tied
+FileHandles. When this becomes possible, C<vmsfopen> may be
+replaced.
+
+=head1 REVISION
+
+This document was last revised on 09-Mar-1995, for Perl 5.001.
+
+=cut
+
+package VMS::stdio;
+
+require DynaLoader;
+require Exporter;
+
+@ISA = qw( Exporter DynaLoader);
+@EXPORT = qw( &fgetname &tmpfile &tmpnam &vmsfopen );
+
+bootstrap VMS::stdio;
+1;
--- /dev/null
+/* VMS::stdio - VMS extensions to stdio routines
+ *
+ * Version: 1.1
+ * Author: Charles Bailey bailey@genetics.upenn.edu
+ * Revised: 09-Mar-1995
+ *
+ *
+ * Revision History:
+ *
+ * 1.0 29-Nov-1994 Charles Bailey bailey@genetics.upenn.edu
+ * original version - vmsfopen
+ * 1.1 09-Mar-1995 Charles Bailey bailey@genetics.upenn.edu
+ * changed calling sequence to return FH/undef - like POSIX::open
+ * added fgetname and tmpnam
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+/* Use type for FILE * from Perl's XSUB typemap. This is a bit
+ * of a hack, since all Perl filehandles using this type will permit
+ * both read & write operations, but it saves to write the PPCODE
+ * directly for updating the Perl filehandles.
+ */
+typedef FILE * InOutStream;
+
+MODULE = VMS::stdio PACKAGE = VMS::stdio
+
+void
+vmsfopen(name,...)
+ char * name
+ CODE:
+ char *args[8],mode[5] = {'r','\0','\0','\0','\0'}, c;
+ register int i, myargc;
+ FILE *fp;
+ if (items > 9) {
+ croak("File::VMSfopen::vmsfopen - too many args");
+ }
+ /* First, set up name and mode args from perl's string */
+ if (*name == '+') {
+ mode[1] = '+';
+ name++;
+ }
+ if (*name == '>') {
+ if (*(name+1) == '>') *mode = 'a', name += 2;
+ else *mode = 'w', name++;
+ }
+ myargc = items - 1;
+ for (i = 0; i < myargc; i++) args[i] = SvPV(ST(i+1),na);
+ /* This hack brought to you by C's opaque arglist management */
+ switch (myargc) {
+ case 0:
+ fp = fopen(name,mode);
+ break;
+ case 1:
+ fp = fopen(name,mode,args[0]);
+ break;
+ case 2:
+ fp = fopen(name,mode,args[0],args[1]);
+ break;
+ case 3:
+ fp = fopen(name,mode,args[0],args[1],args[2]);
+ break;
+ case 4:
+ fp = fopen(name,mode,args[0],args[1],args[2],args[3]);
+ break;
+ case 5:
+ fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4]);
+ break;
+ case 6:
+ fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4],args[5]);
+ break;
+ case 7:
+ fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6]);
+ break;
+ case 8:
+ fp = fopen(name,mode,args[0],args[1],args[2],args[3],args[4],args[5],args[6],args[7]);
+ break;
+ }
+ ST(0) = sv_newmortal();
+ if (fp != NULL) {
+ GV *gv = newGVgen("VMS::stdio");
+ c = mode[0]; name = mode;
+ if (mode[1]) *(name++) = '+';
+ if (c == 'r') *(name++) = '<';
+ else {
+ *(name++) = '>';
+ if (c == 'a') *(name++) = '>';
+ }
+ *(name++) = '&';
+ if (do_open(gv,mode,name - mode,fp))
+ sv_setsv(ST(0),newRV((SV*)gv));
+ }
+
+char *
+fgetname(fp)
+ FILE * fp
+ CODE:
+ char fname[257];
+ ST(0) = sv_newmortal();
+ if (fgetname(fp,fname) != NULL) sv_setpv(ST(0),fname);
+
+char *
+tmpnam()
+ CODE:
+ char fname[L_tmpnam];
+ ST(0) = sv_newmortal();
+ if (tmpnam(fname) != NULL) sv_setpv(ST(0),fname);
# Note: A rather simple-minded attempt is made to restore quotes to
# a /Define clause - use with care.
# $objsuffix - file type (including '.') used for object files.
+# $libperl - Perl object library.
+# $extnames - package names for static extensions (used to generate
+# linker options file entries for boot functions)
+# $rtlopt - name of options file specifying RTLs to which PerlShr.Exe
+# must be linked
#
# Output:
# PerlShr_Attr.Opt - linker options file which speficies that global vars
# be placed in NOSHR,WRT psects. Use when linking any object files
# against PerlShr.Exe, since cc places global vars in SHR,WRT psects
# by default.
-# PerlShr_Sym.Opt - declares universal symbols for PerlShr.Exe
+# PerlShr_Bld.Opt - declares universal symbols for PerlShr.Exe
# Perlshr_Gbl*.Mar, Perlshr_Gbl*.Obj (VAX only) - declares global symbols
# for global vars (done here because gcc can't globaldef) and creates
# transfer vectors for routines on a VAX.
# (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)?
#
# Author: Charles Bailey bailey@genetics.upenn.edu
-# Revised: 21-Sep-1994
+# Revised: 01-Mar-1995
require 5.000;
$objsuffix = shift @ARGV;
print "\$objsuffix: \\$objsuffix\\\n" if $debug;
+$dbgprefix = shift @ARGV;
+print "\$dbgprefix: \\$dbgprefix\\\n" if $debug;
+$olbsuffix = shift @ARGV;
+print "\$olbsuffix: \\$olbsuffix\\\n" if $debug;
+$libperl = "${dbgprefix}libperl$olbsuffix";
+$extnames = shift @ARGV;
+print "\$extnames: \\$extnames\\\n" if $debug;
+$rtlopt = shift @ARGV;
+print "\$rtlopt: \\$rtlopt\\\n" if $debug;
# Someday, we'll have $GetSyI built into perl . . .
$isvax = `\$ Write Sys\$Output F\$GetSyI(\"HW_MODEL\")` <= 1024;
sub scan_var {
my($line) = @_;
- print "\tchecking for global variable\n" if $debug;
+ print "\tchecking for global variable\n" if $debug > 1;
$line =~ s/INIT\(.*\)//;
$line =~ s/\[.*//;
$line =~ s/=.*//;
$line =~ s/\W*;?\s*$//;
- print "\tfiltered to \\$line\\\n" if $debug;
+ print "\tfiltered to \\$line\\\n" if $debug > 1;
if ($line =~ /(\w+)$/) {
- print "\tvar name is \\$1\\\n" if $debug;
+ print "\tvar name is \\$1\\\n" if $debug > 1;
$vars{$1}++;
}
}
sub scan_func {
my($line) = @_;
- print "\tchecking for global routine\n" if $debug;
+ print "\tchecking for global routine\n" if $debug > 1;
if ( /(\w+)\s+\(/ ) {
- print "\troutine name is \\$1\\\n" if $debug;
+ print "\troutine name is \\$1\\\n" if $debug > 1;
if ($1 eq 'main' || $1 eq 'perl_init_ext') {
- print "\tskipped\n" if $debug;
+ print "\tskipped\n" if $debug > 1;
}
else { $funcs{$1}++ }
}
LINE: while (<CPP>) {
while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) {
while (/__VMS_PROTOTYPES__/i .. /__VMS_SEPYTOTORP__/i) {
- print "vms_proto>> $_" if $debug;
+ print "vms_proto>> $_" if $debug > 2;
&scan_func($_);
if (/^EXT/) { &scan_var($_); }
last LINE unless $_ = <CPP>;
}
- print "vmsish.h>> $_" if $debug;
+ print "vmsish.h>> $_" if $debug > 2;
if (/^EXT/) { &scan_var($_); }
last LINE unless $_ = <CPP>;
}
while (/^#.*opcode\.h/i .. /^#.*perl\.h/i) {
- print "opcode.h>> $_" if $debug;
+ print "opcode.h>> $_" if $debug > 2;
if (/^OP \*\s/) { &scan_func($_); }
if (/^EXT/) { &scan_var($_); }
last LINE unless $_ = <CPP>;
}
while (/^#.*proto\.h/i .. /^#.*perl\.h/i) {
- print "proto.h>> $_" if $debug;
+ print "proto.h>> $_" if $debug > 2;
&scan_func($_);
if (/^EXT/) { &scan_var($_); }
last LINE unless $_ = <CPP>;
}
- print $_ if $debug;
+ print $_ if $debug > 3;
if (/^EXT/) { &scan_var($_); }
}
close CPP;
next if /^#/;
s/\s+#.*\n//;
($key,$array) = split('=',$_);
- print "Adding $key to \%$array list\n" if $debug;
+ print "Adding $key to \%$array list\n" if $debug > 1;
${$array}{$key}++;
}
+foreach (split /\s+/, $extnames) {
+ my($pkgname) = $_;
+ $pkgname =~ s/::/__/g;
+ $funcs{"boot_$pkgname"}++;
+ print "Adding boot_$pkgname to \%funcs (for extension $_)\n" if $debug;
+}
# Eventually, we'll check against existing copies here, so we can add new
# symbols to an existing options file in an upwardly-compatible manner.
$marord++;
-open(OPTSYM,">${dir}perlshr_sym.opt")
- or die "$0: Can't write to ${dir}perlshr_sym.opt: $!\n";
+open(OPTBLD,">${dir}${dbgprefix}perlshr_bld.opt")
+ or die "$0: Can't write to ${dir}${dbgprefix}perlshr_bld.opt: $!\n";
open(OPTATTR,">${dir}perlshr_attr.opt")
or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
if ($isvax) {
open(MAR,">${dir}perlshr_gbl${marord}.mar")
or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
+ print MAR "\t.title perlshr_gbl$marord\n";
}
print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n";
foreach $var (sort keys %vars) {
print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
- if ($isvax) { print OPTSYM "UNIVERSAL=$var\n"; }
- else { print OPTSYM "SYMBOL_VECTOR=($var=DATA)\n"; }
+ if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; }
+ else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; }
if ($isvax) {
if ($count++ > 200) { # max 254 psects/file
print MAR "\t.end\n";
$marord++;
open(MAR,">${dir}perlshr_gbl${marord}.mar")
or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
+ print MAR "\t.title perlshr_gbl$marord\n";
$count = 0;
}
# This hack brought to you by the lack of a globaldef in gcc.
print MAR "\t.mask $func\n";
print MAR "\tjmp L\^${func}+2\n";
}
- else { print OPTSYM "SYMBOL_VECTOR=($func=PROCEDURE)\n"; }
+ else { print OPTBLD "SYMBOL_VECTOR=($func=PROCEDURE)\n"; }
}
-close OPTSYM;
close OPTATTR;
+$incstr = 'perl,globals';
if ($isvax) {
print MAR "\t.end\n";
close MAR;
- open (GBLOPT,">PerlShr_Gbl.Opt") or die "$0: Can't write to PerlShr_Gbl.Opt: $!\n";
$drvrname = "Compile_shrmars.tmp_".time;
open (DRVR,">$drvrname") or die "$0: Can't write to $drvrname: $!\n";
print DRVR "\$ Set NoOn\n";
print DRVR "\$ Delete/NoLog/NoConfirm $drvrname;\n";
print DRVR "\$ old_proc_vfy = F\$Environment(\"VERIFY_PROCEDURE\")\n";
print DRVR "\$ old_img_vfy = F\$Environment(\"VERIFY_IMAGE\")\n";
+ print DRVR "\$ MCR $^X -e \"\$ENV{'LIBPERL_RDT'} = (stat('$libperl'))[9]\"\n";
print DRVR "\$ Set Verify\n";
+ print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n";
do {
- print GBLOPT "PerlShr_Gbl${marord}$objsuffix\n";
+ $incstr .= ",perlshr_gbl$marord";
print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n";
+ print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n";
} while (--$marord);
+ # We had to have a working miniperl to run this program; it's probably the
+ # one we just built. It depended on LibPerl, which will be changed when
+ # the PerlShr_Gbl* modules get inserted, so miniperl will be out of date,
+ # and so, therefore, will all of its dependents . . .
+ # We touch LibPerl here so it'll be back 'in date', and we won't rebuild
+ # miniperl etc., and therefore LibPerl, the next time we invoke MM[KS].
print DRVR "\$ old_proc_vfy = F\$Verify(old_proc_vfy,old_img_vfy)\n";
+ print DRVR "\$ MCR $^X -e \"utime 0, \$ENV{'LIBPERL_RDT'}, '$libperl'\"\n";
close DRVR;
- close GBLOPT;
- exec "\$ \@$drvrname";
}
+
+# Include object modules and RTLs in options file
+# 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";
+while (<RTLOPT>) { print OPTBLD; }
+close RTLOPT;
+close OPTBLD;
+
+exec "\$ \@$drvrname" if $isvax;
+
+
__END__
# Oddball cases, so we can keep the perl.h scan above simple
#
# Extract info from Config.VMS, and add extra data here, to generate Config.sh
# Edit the static information after __END__ to reflect your site and options
-# that went into your perl binary.
+# that went into your perl binary. In addition, values which change from run
+# to run may be supplied on the command line as key=val pairs.
#
-# Rev. 30-Sep-1994 Charles Bailey bailey@genetics.upenn.edu
+# Rev. 08-Mar-1995 Charles Bailey bailey@genetics.upenn.edu
#
unshift(@INC,'lib'); # In case someone didn't define Perl_Root
$outdir = '';
open(IN,"$infile") || die "Can't open $infile: $!\n";
open(OUT,">${outdir}Config.sh") || die "Can't open ${outdir}Config.sh: $!\n";
-select OUT;
-
$time = &ctime(time());
-print <<EndOfIntro;
+print OUT <<EndOfIntro;
# This file generated by GenConfig.pl on a VMS system.
# Input obtained from:
# $infile
EndOfIntro
+foreach (@ARGV) {
+ ($key,$val) = split('=',$_,2);
+ print OUT "$key=\'$val\'\n";
+ if ($val =~/VMS_DO_SOCKETS/) { $dosock = 1; }
+}
+
while (<IN>) { # roll through the comment header in Config.VMS
last if /^#define _config_h_/;
}
$val =~ s%/\*.*\*/\s*%%g; $val =~ s/\s*$//; # strip off trailing comment
$val =~ s/^"//; $val =~ s/"$//; # remove end quotes
$val =~ s/","/ /g; # make signal list look nice
- if ($val) { print "$token=\'$val\'\n"; }
+ if ($val) { print OUT "$token=\'$val\'\n"; }
else {
$token = "d_$token" unless $token =~ /^i_/;
- print "$token=\'$state\'\n"; }
+ print OUT "$token=\'$state\'\n";
+ }
}
close IN;
next if /^\s*#/ or /^\s*$/;
s/#.*$//; s/\s*$//;
($key,$val) = split('=',$_,2);
- print "$key=\'$val\'\n";
+ print OUT "$key='$val'\n";
+ eval "\$$key = '$val'";
+}
+# Add in some of the architecture-dependent stuff which has to be consistent
+print OUT "d_vms_do_sockets=",$dosock ? "'define'\n" : "'undef'\n";
+print OUT "d_has_sockets=",$dosock ? "'define'\n" : "'undef'\n";
+$osvers = `Write Sys\$Output F\$GetSyi("VERSION")`;
+chomp $osvers;
+$osvers =~ s/^V//;
+print OUT "osvers='$osvers'\n";
+$hw_model = `Write Sys\$Output F\$GetSyi("HW_MODEL")`;
+chomp $hw_model;
+if ($hw_model > 1024) {
+ print OUT "arch='VMS_AXP'\n";
+ print OUT "archname='VMS_AXP'\n";
+ $archsufx = "AXP";
+}
+else {
+ print OUT "arch='VMS_VAX'\n";
+ print OUT "archname='VMS_VAX'\n";
+ $archsufx = 'VAX';
}
+$archlib = &VMS::Filespec::vmspath($privlib);
+$archlib =~ s#\]#.VMS_$archsufx\]#;
+$installarchlib = &VMS::Filespec::vmspath($installprivlib);
+$installarchlib =~ s#\]#.VMS_$archsufx\]#;
+print OUT "archlib='$archlib'\n";
+print OUT "installarchlib='$installarchlib'\n";
__END__
osname=VMS # DO NOT CHANGE THIS! Tests elsewhere depend on this to identify
# VMS. Use the 'arch' item below to specify hardware version.
CONFIG=true
-PATCHLEVEL=0
+PATCHLEVEL=001
+ld=Link
+lddlflags=/Share
+ccdlflags=
+cccdlflags=
+libc=
+ranlib=
+eunicefix=:
+usedl=true
dldir=/ext/dl
dlobj=dl_vms.obj
dlsrc=dl_vms.c
timetype=long
usemymalloc=n
builddir=perl_root:[000000]
+installprivlib=perl_root:[lib]
+privlib=perl_root:[lib]
+installbin=perl_root:[000000]
# The definitions in this block are site-specific, and will probably need to
# be changed on most systems.
myhostname=nowhere.loopback.edu
-arch=VAX
-osvers=5.5-2
-cppflags=/Define=(DEBUGGING)
-d_vms_do_sockets=undef #=define if perl5 built with socket support
-d_has_sockets=undef # This should have the same value as d_vms_do_sockets
libs= # This should list RTLs other than the C RTL and IMAGELIB (e.g. socket RTL)
# we deselect any other line if $conditions[0] is 0
# I'm being very lazy - push a 1 at start, then dont need to check for
# an empty @conditions [assume nesting in descrip.mms is correct]
+# 2.1 26-Feb-1995 Charles Bailey bailey@genetics.upenn.edu
+# - handle MMS macros generated by MakeMaker
if ($#ARGV > -1 && $ARGV[0] =~ /^[\-\/]trim/i) {
$do_trim = 1;
else { $firstsrc = "\$<" }
}
+#convert macros we expect to see in MakeMaker-generated Descrip.MMSs
+ s#/Descrip=\s*\n#-f \nMMS = make\n#;
+ s#/Macro=\(# #;
+ s#MACROEND = \)#MACROEND = #;
+ if (m#\$\(USEMACROS\)(.*)(\$\(MACROEND\))?#) {
+ while (1) {
+ my($macros,$end) = ($1,$2);
+ $macros =~ s/,/ /g; # We're hosed if there're commas within a macro -
+ # someday, check for "" and skip contents
+ last if $end;
+ print OUTFIL $conditions[0] ? "#> " : "",$_;
+ $_ = <INFIL>;
+ m#(.*)(\$\(MACROEND\))?#;
+ }
+ }
+
s/^ +/\t/;
s/^\.first/\.first:/i;
s/^\.suffixes/\.suffixes:/i;
-=head1 Notes on Perl5 for VMS
+=head1 Notes on Perl 5 for VMS
-Gathered below are notes describing details of perl 5's
-behavior on VMS. They are a supplement to the regular perl 5
-documentation, so we have focussed on the ways in which perl
-5 functions differently under VMS thatn it does under Unix,
-and on teh interactions between perl and the rest of the
+Gathered below are notes describing details of Perl 5's
+behavior on VMS. They are a supplement to the regular Perl 5
+documentation, so we have focussed on the ways in which Perl
+5 functions differently under VMS than it does under Unix,
+and on the interactions between Perl and the rest of the
operating system. We haven't tried to duplicate complete
-descriptions of perl5 features from the main perl
+descriptions of Perl features from the main Perl
documentation, which can be found in the F<[.pod]>
-subdirectory of the perl 5 distribution.
+subdirectory of the Perl distribution.
We hope these notes will save you from confusion and lost
-sleep when writing perl scripts on VMS. If you find we've
+sleep when writing Perl scripts on VMS. If you find we've
missed something you think should appear here, please don't
hesitate to drop a line to vmsperl@genetics.upenn.edu.
-=head2 Installation
-
-Directions for building and installing perl 5 can be found in
+=head1 Organization of Perl
+
+=head2 Perl Images
+
+During the installation process, three Perl images are produced.
+F<Miniperl.Exe> is an executable image which contains all of
+the basic functionality of Perl, but cannot take advantage of
+Perl extensions. It is used to generate several files needed
+to build the complete Perl and various extensions. Once you've
+finished installing Perl, you can delete this image.
+
+Most of the complete Perl resides in the shareable image
+F<PerlShr.Exe>, which provides a core to which the Perl executable
+image and all Perl extensions are linked. You should place this
+image in F<Sys$Share>, or define the logical name F<PerlShr> to
+translate to the full file specification of this image. It should
+be world readable. (Remember that if a user has execute only access
+to F<PerlShr>, VMS will treat it as if it were a privileged shareable
+image, and will therefore require all downstream shareable images to be
+INSTALLed, etc.)
+
+
+Finally, F<Perl.Exe> is an executable image containing the main
+entry point for Perl, as well as some initialization code. It
+should be placed in a public directory, and made world executable.
+In order to run Perl with command line arguments, you should
+define a foreign command to invoke this image.
+
+=head2 Perl Extensions
+
+Perl extensions are packages which provide both XS and Perl code
+to add new functionality to perl. (XS is a meta-language which
+simplifies writing C code which interacts with Perl, see
+L<perlapi> for more details.) The Perl code for an
+extension is treated like any other library module - it's
+made available in your script through the appropriate
+C<use> or C<require> statement, and usually defines a Perl
+package containing the extension.
+
+The portion of the extension provided by the XS code may be
+connected to the rest of Perl in either of two ways. In the
+B<static> configuration, the object code for the extension is
+linked directly into F<PerlShr.Exe>, and is initialized whenever
+Perl is invoked. In the B<dynamic> configuration, the extension's
+machine code is placed into a separate shareable image, which is
+mapped by Perl's DynaLoader when the extension is C<use>d or
+C<require>d in your script. This allows you to maintain the
+extension as a separate entity, at the cost of keeping track of the
+additional shareable image. Most extensions can be set up as either
+static or dynamic.
+
+The source code for an extension usually resides in its own
+directory. At least three files are generally provided:
+I<Extshortname>F<.xs> (where I<Extshortname> is the portion of
+the extension's name following the last C<::>), containing
+the XS code, I<Extshortname>F<.pm>, the Perl library module
+for the extension, and F<Makefile.PL>, a Perl script which uses
+the C<MakeMaker> library modules supplied with Perl to generate
+a F<Descrip.MMS> file for the extension.
+
+=head3 Installing static extensions
+
+Since static extensions are incorporated directly into
+F<PerlShr.Exe>, you'll have to rebuild Perl to incorporate a
+new extension. You should edit the main F<Descrip.MMS> or F<Makefile>
+you use to build Perl, adding the extension's name to the C<ext>
+macro, and the extension's object file to the C<extobj> macro.
+You'll also need to build the extension's object file, either
+by adding dependencies to the main F<Descrip.MMS>, or using a
+separate F<Descrip.MMS> for the extension. Then, rebuild
+F<PerlShr.Exe> to incorporate the new code.
+
+Finally, you'll need to copy the extension's Perl library
+module to the F<[.>I<Extname>F<]> subdirectory under one
+of the directories in C<@INC>, where I<Extname> is the name
+of the extension, with all C<::> replaced by C<.> (e.g.
+the library module for extension Foo::Bar would be copied
+to a F<[.Foo.Bar]> subdirectory).
+
+=head3 Installic dynamic extensions
+
+First, you'll need to compile the XS code into a shareable image,
+either by hand or using the F<Descrip.MMS> supplied with the
+extension. If you're building the shareable image by hand, please
+note the following points:
+ - The shareable image must be linked to F<PerlShr.Exe>, so it
+ has access to Perl's global variables and routines. In
+ order to specify the correct attributes for psects in
+ F<PerlShr.Exe>, you should include the linker options file
+ F<PerlShr_Attr.Opt> in the Link command. (This file is
+ generated when F<PerlShr.Exe> is built, and is found in the
+ main Perl source directory.
+ - The entry point for the C<boot_>I<Extname> routine (where
+ I<Extname> is the name of the extension, with all C<::>
+ replaced by C<__>) must be a universal symbol. No other
+ universal symbols are required to use the shareable image
+ with Perl, though you may want to include additional
+ universal symbols if you plan to share code or data among
+ different extensions.
+The shareable image can be placed in any of several locations:
+ - the F<[.Auto.>I<Extname>F<]> subdirectory of one of
+ the directories in C<@INC>, where I<Extname> is the
+ name of the extension, with each C<::> translated to C<.>
+ (e.g. for extension Foo::Bar, you would use the
+ F<[.Auto.Foo.Bar]> subdirectory), or
+ - one of the directories in C<@INC>, or
+ - a directory which the extensions Perl library module
+ passes to the DynaLoader when asking it to map
+ the shareable image, or
+ - F<Sys$Share> or F<Sys$Library>.
+If the shareable image isn't in any of these places, you'll need
+to define a logical name I<Extshortname>, where I<Extshortname>
+is the portion of the extension's name after the last C<::>, which
+translates to the full file specification of the shareable image.
+
+Once you've got the shareable image set up, you should copy the
+extension's Perl library module to the appropriate library directory
+(see the section above on installing static extensions).
+
+=head1 Installation
+
+Directions for building and installing Perl 5 can be found in
the file F<ReadMe.VMS> in the main source directory of the
-perl5 distribution..
+Perl distribution..
-=head2 File specifications
+=head1 File specifications
-We have tried to make perl aware of both VMS-style and Unix-
+We have tried to make Perl aware of both VMS-style and Unix-
style file specifications wherever possible. You may use
either style, or both, on the command line and in scripts,
but you may not combine the two styles within a single fle
specfication. Filenames are, of course, still case-
-insensitive. For consistency, most perl5 routines return
+insensitive. For consistency, most Perl routines return
filespecs using lower case latters only, regardless of the
case used in the arguments passed to them. (This is true
-only when running under VMS; perl5 respects the case-
+only when running under VMS; Perl respects the case-
sensitivity of OSs like Unix.)
-We've tried to minimize the dependence of perl library
+We've tried to minimize the dependence of Perl library
modules on Unix syntax, but you may find that some of these,
as well as some scripts written for Unix systems, will
require that you use Unix syntax, since they will assume that
'/' is the directory separator, etc. If you find instances
-of this in the perl distribution itself, please let us know,
+of this in the Perl distribution itself, please let us know,
so we can try to work around them.
-=head2 Command line redirection
+=head1 Command line redirection
Perl for VMS supports redirection of input and output on the
command line, using a subset of Bourne shell syntax:
<F<file> reads stdin from F<file>,
>F<file> writes stdout to F<file>,
>>F<file> appends stdout to F<file>,
- 2>F<file> wrtits stderr to F<file>, and
+ 2>F<file> writes stderr to F<file>, and
2>>F<file> appends stderr to F<file>.
In addition, output may be piped to a subprocess, using the
character '|'. Anything after this character on the command
line is passed to a subprocess for execution; the subprocess
-takes the output of perl as its input.
+takes the output of Perl as its input.
Finally, if the command line ends with '&', the entire
command is run in the background as an asynchronous
subprocess.
-=head2 Pipes
+=head1 Pipes
-Input and output pipes to perl filehandles are supported; the
+Input and output pipes to Perl filehandles are supported; the
"file name" is passed to lib$spawn() for asynchronous
execution. You should be careful to close any pipes you have
-opened in a perl script, lest you leave any "orphaned"
-subprocesses around when perl exits.
+opened in a Perl script, lest you leave any "orphaned"
+subprocesses around when Perl exits.
You may also use backticks to invoke a DCL subprocess, whose
output is used as the return value of the expression. The
string between the backticks is passed directly to lib$spawn
-as the command to execute. In this case, perl will wait for
+as the command to execute. In this case, Perl will wait for
the subprocess to complete before continuing.
-=head2 Wildcard expansion
+=head1 Wildcard expansion
File specifications containing wildcards are allowed both on
-the command line and within perl globs (e.g. <C<*.c>>). If
+the command line and within Perl globs (e.g. <C<*.c>>). If
the wildcard filespec uses VMS syntax, the resultant
filespecs will follow VMS syntax; if a Unix-style filespec is
passed in, Unix-style filespecs will be returned..
Similarly, the resultant filespec will the file version only
if one was present in the input filespec.
-=head2 %ENV
+=head1 PERL5LIB and PERLLIB
+
+The PERL5LIB and PERLLIB logical names work as
+documented L<perl>, except that the element
+separator is '|' instead of ':'. The directory
+specifications may use either VMS or Unix syntax.
+
+=head1 %ENV
Reading the elements of the %ENV array returns the
translation of the logical name specified by the key,
current default device and directory specification.
Setting an element of %ENV defines a supervisor-mode logical
-name in the process logical name table. B<Undef>ing or
-B<delete>ing an element of %ENV deletes the equivalent user-
+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 B<undef>, the %ENV element remains
-empty. If you use B<delete>, another attempt is made at
+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.
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.
+specified in the Perl expression.
-=head2 Perl functions
+=head1 Perl functions
As of the time this document was last revised, the following
-perl functions were implemented in the VMS port of perl
+Perl functions were implemented in the VMS port of Perl
(functions marked with * are discussed in more detail below):
file tests*, abs, alarm, atan, binmode*, bless,
caller, chdir, chmod, chown, chomp, chop, chr,
close, closedir, cos, defined, delete, die, do,
- each, eof, eval, exec*, exists, exit, exp, fileno,
- fork*, getc, glob, goto, grep, hex, import, index,
+ each, endpwent, eof, eval, exec*, exists, exit,
+ exp, fileno, fork*, getc, getpwent*, getpwnam*,
+ getpwuid*, glob, goto, grep, hex, import, index,
int, join, keys, kill, last, lc, lcfirst, length,
local, localtime, log, m//, map, mkdir, my, next,
no, oct, open, opendir, ord, pack, pipe, pop, pos,
quotemeta, rand, read, readdir, redo, ref, rename,
require, reset, return, reverse, rewinddir, rindex,
rmdir, s///, scalar, seek, seekdir, select(internal)*,
- shift, sin, sleep, sort, splice, split, sprintf,
- sqrt, srand, stat, study, substr, sysread, system*,
- syswrite, tell, telldir, tie, time, times*, tr///,
- uc, ucfirst, umask, undef, unlink, unpack, untie,
- unshift, use, values, vec, wait, wantarray, warn,
- write, y///
+ setpwent, shift, sin, sleep, sort, splice, split,
+ sprintf, sqrt, srand, stat, study, substr, sysread,
+ system*, syswrite, tell, telldir, tie, time, times*,
+ tr///, uc, ucfirst, umask, undef, unlink, unpack,
+ untie, unshift, use, utime*, values, vec, wait,
+ waitpid*, wantarray, warn, write, y///
The following functions were not implemented in the VMS port,
and calling them produces a fatal error (usually) or
chroot, crypt, dbmclose, dbmopen, dump, fcntl,
flock, getlogin, getpgrp, getppid, getpriority,
- getpwent, getgrent, kill, getgrgid, getgrnam,
- getpwnam, getpwuid, setpwent, setgrent,
- endpwent, endgrent, gmtime, ioctl, link, lstst,
- msgctl, msgget, msgsend, msgrcv, readlink,
+ getgrent, kill, getgrgid, getgrnam, setgrent,
+ endgrent, gmtime, ioctl, link, lstst, msgctl,
+ msgget, msgsend, msgrcv, readlink,
select(system call), semctl, semget, semop,
setpgrp, setpriority, shmctl, shmget, shmread,
- shmwrite, socketpair, symlink, syscall, truncate,
- utime, waitpid
+ shmwrite, socketpair, symlink, syscall, truncate
The following functions may or may not be implemented,
depending on what type of socket support you've built into
-your copy of perl:
+your copy of Perl:
accept, bind, connect, getpeername,
gethostbyname, getnetbyname, getprotobyname,
getservbyname, gethostbyaddr, getnetbyaddr,
=item File tests
-The tests -b, -B, -c, -C, -d, -e, -f, -o, -M, -s, -S, -t, -T,
-and -z work as advertised. The return values for -r, -w, and
--x tell you whether you can actually access the file; this
-may mot reflect the UIC-based file protections. Since real
-and effective UIC don't differ under VMS, -O, -R, -W, and -X
-are equivalent to -o, -r, -w, and -x. Similarly, several
-other tests, including -A, -g, -k, -l,-p, and -u, aren't
-particularly meaningful under VMS, and the values returned by
-these tests reflect whatever your CRTL stat() routine does to
-the equivalent bits in the st_mode field.
-
-=item binmode
-
-The B<binmode> operator has no effect under VMS. It will
+The tests C<-b>, C<-B>, C<-c>, C<-C>, C<-d>, C<-e>, C<-f>,
+C<-o>, C<-M>, C<-s>, C<-S>, C<-t>, C<-T>, and C<-z> work as
+advertised. The return values for C<-r>, C<-w>, and C<-x>
+tell you whether you can actually access the file; this may
+not reflect the UIC-based file protections. Since real and
+effective UIC don't differ under VMS, C<-O>, C<-R>, C<-W>,
+and C<-X> are equivalent to C<-o>, C<-r>, C<-w>, and C<-x>.
+Similarly, several other tests, including C<-A>, C<-g>, C<-k>,
+C<-l>, C<-p>, and C<-u>, aren't particularly meaningful under
+VMS, and the values returned by these tests reflect whatever
+your CRTL C<stat()> routine does to the equivalent bits in the
+st_mode field. Finally, C<-d> returns true if passed a device
+specification without an explicit directory (e.g. C<DUA1:>), as
+well as if passed a directory.
+
+=item binmode FILEHANDLE
+
+The C<binmode> operator has no effect under VMS. It will
return TRUE whenever called, but will not affect I/O
operations on the filehandle given as its argument.
-=item exec
+=item exec LIST
-The B<exec> operator behaves in one of two different ways.
-If called after a call to B<fork>, it will invoke the CRTL
-L<execv()> routine, passing its arguments to the subprocess
-created by B<fork> for execution. In this case, it is
-subject to all limitation that affect L<execv>. (In
+The C<exec> operator behaves in one of two different ways.
+If called after a call to C<fork>, it will invoke the CRTL
+C<execv()> routine, passing its arguments to the subprocess
+created by C<fork> for execution. In this case, it is
+subject to all limitations that affect C<execv()>. (In
particular, this usually means that the command executed in
the subprocess must be an image compiled from C source code,
and that your options for passing file descriptors and signal
handlers to the subprocess are limited.)
-If the call to B<exec> does not follow a call to B<fork>, it
-will cause perl to exit, and to invoke the command given as
-an argument to B<exec> via lib$do_command. If the argument
+If the call to C<exec> does not follow a call to C<fork>, it
+will cause Perl to exit, and to invoke the command given as
+an argument to C<exec> via C<lib$do_command>. If the argument
begins with a '$' (other than as part of a filespec), then it
is executed as a DCL command. Otherwise, the first token on
the command line is treated as the filespec of an image to
run, and an attempt is made to invoke it (using F<.Exe> and
the process defaults to expand the filespec) and pass the
-rest of B<exec>'s argument to it as parameters.
+rest of C<exec>'s argument to it as parameters.
-You can use B<exec> in both ways within the same script, as
-long as you call B<fork> and B<exec> in pairs. Perl only
-keeps track of whether B<fork> has been called since the last
-call to B<exec> when figuring out what to do, so multiple
-calls to B<fork> do not generate multiple levels of "fork
-context".
+You can use C<exec> in both ways within the same script, as
+long as you call C<fork> and C<exec> in pairs. Perl
+keeps track of how many times C<fork> and C<exec> have been
+called, and will call the CRTL C<execv()> routine if there have
+previously been more calls to C<fork> than to C<exec>.
=item fork
-The B<fork> operator works in the same way as the CRTL
-L<fork()> routine, which is quite different under VMS than
-under Unix. Sepcifically, while B<fork> returns 0 after it
-is called and the subprocess PID after B<exec> is called, in
+The C<fork> operator works in the same way as the CRTL
+C<vfork()> routine, which is quite different under VMS than
+under Unix. Specifically, while C<fork> returns 0 after it
+is called and the subprocess PID after C<exec> is called, in
both cases the thread of execution is within the parent
process, so there is no opportunity to perform operations in
-the subprocess before calling B<exec>.
+the subprocess before calling C<exec>.
-In general, the use of B<fork> and B<exec> to create
+In general, the use of C<fork> and C<exec> to create
subprocess is not recommended under VMS; wherever possible,
-use the B<system> operator or piped filehandles instead.
+use the C<system> operator or piped filehandles instead.
+
+=item getpwent
+=item getpwnam
+=item getpwuid
+
+These operators obtain the information described in L<perlfunc>,
+if you have the privileges necessary to retrieve the named user's
+UAF information via C<sys$getuai>. If not, then only the C<$name>,
+C<$uid>, and C<$gid> items are returned. The C<$dir> item contains
+the login directory in VMS syntax, while the C<$comment> item
+contains the login directory in Unix syntax. The C<$gcos> item
+contains the owner field from the UAF record. The C<$quota>
+item is not used.
-=item system
+=item stat EXPR
-The B<system> operator creates a subprocess, and passes its
+Since VMS keeps track of files according to a different scheme
+than Unix, it's not really possible to represent the file's ID
+in the C<st_dev> and C<st_ino> fields of a C<struct stat>. Perl
+tries its best, though, and the values it uses are pretty unlikely
+to be the same for two different files. We can't guarantee this,
+though, so caveat scriptor.
+
+=item system LIST
+
+The C<system> operator creates a subprocess, and passes its
arguments to the subprocess for execution as a DCL command.
Since the subprocess is created directly via lib$spawn, any
-valid DCL command string may be specified. Perl waits for
-the subprocess to complete before continuing execution in the
-current process.
+valid DCL command string may be specified. If LIST consists
+of the empty string, C<system> spawns an interactive DCL subprocess,
+in the same fashion as typiing B<SPAWN> at the DCL prompt.
+Perl waits for the subprocess to complete before continuing
+execution in the current process.
=item times
-The array returned by the B<times> operator is divided up
-according to the same rules the CRTL L<times()> routine.
+The array returned by the C<times> operator is divided up
+according to the same rules the CRTL C<times()> routine.
Therefore, the "system time" elements will always be 0, since
there is no difference between "user time" and "system" time
under VMS, and the time accumulated by subprocess may or may
not appear separately in the "child time" field, depending on
-whether L<times> keeps track of subprocesses separately.
+whether L<times> keeps track of subprocesses separately. Note
+especially that the VAXCRTL (at least) keeps track only of
+subprocesses spawned using L<fork> and L<exec>; it will not
+accumulate the times of suprocesses spawned via pipes, L<system>,
+or backticks.
+
+=item utime LIST
+
+Since ODS-2, the VMS file structure for disk files, does not keep
+track of access times, this operator changes only the modification
+time of the file (VMS revision date).
+
+=item waitpid PID,FLAGS
+
+If PID is a subprocess started by a piped L<open>, C<waitpid>
+will wait for that subprocess, and return its final
+status value. If PID is a subprocess created in some other way
+(e.g. SPAWNed before Perl was invoked), or is not a subprocess of
+the current process, C<waitpid> will check once per second whether
+the process has completed, and when it has, will return 0. (If PID
+specifies a process that isn't a subprocess of the current process,
+and you invoked Perl with the C<-w> switch, a warning will be issued.)
+
+The FLAGS argument is ignored in all cases.
-=head2 Revision date
+=head1 Revision date
-This document was last updated on 16-Oct-1994, for perl 5,
+This document was last updated on 16-Dec-1994, for Perl 5,
patchlevel 0.
/* sockadapt.c
*
* Author: Charles Bailey bailey@genetics.upenn.edu
- * Last Revised: 05-Oct-1994
+ * Last Revised: 08-Feb-1995
*
* This file should contain stubs for any of the TCP/IP functions perl5
* requires which are not supported by your TCP/IP stack. These stubs
* can attempt to emulate the routine in question, or can just return
* an error status or cause perl to die.
*
- * This version is set up for perl5 with socketshr 0.9A TCP/IP support.
+ * This version is set up for perl5 with socketshr 0.9D TCP/IP support.
*/
#include "sockadapt.h"
STRINGIFY(func));\
}
-FATALSTUB(endhostent);
FATALSTUB(endnetent);
-FATALSTUB(endprotoent);
-FATALSTUB(endservent);
-FATALSTUB(gethostent);
FATALSTUB(getnetbyaddr);
FATALSTUB(getnetbyname);
FATALSTUB(getnetent);
-FATALSTUB(getprotobyname);
-FATALSTUB(getprotobynumber);
-FATALSTUB(getprotoent);
-FATALSTUB(getservent);
-FATALSTUB(sethostent);
FATALSTUB(setnetent);
-FATALSTUB(setprotoent);
-FATALSTUB(setservent);
*
* Authors: Charles Bailey bailey@genetics.upenn.edu
* David Denholm denholm@conmat.phys.soton.ac.uk
- * Last Revised: 05-Oct-1994
+ * Last Revised: 24-Feb-1995
*
* This file should include any other header files and procide any
* declarations, typedefs, and prototypes needed by perl for TCP/IP
* operations.
*
- * This version is set up for perl5 with socketshr 0.9A TCP/IP support.
+ * This version is set up for perl5 with socketshr 0.9D TCP/IP support.
*/
#include <socketshr.h>
-/* we may not have socket.h etc, so lets just do these here - div */
-/* built up from a variety of sources */
+/* we may not have netdb.h etc, so lets just do this here - div */
/* no harm doing this for all .c files - needed only by pp_sys.c */
-struct hostent {
- char *h_name;
- char *h_aliases;
- int h_addrtype;
- int h_length;
- char **h_addr_list;
+struct hostent {
+ char *h_name; /* official name of host */
+ char **h_aliases; /* alias list */
+ int h_addrtype; /* host address type */
+ int h_length; /* length of address */
+ char **h_addr_list; /* address */
};
+#ifdef h_addr
+# undef h_addr
+#endif
#define h_addr h_addr_list[0]
-struct sockaddr_in {
- short sin_family;
- unsigned short sin_port;
- unsigned long sin_addr;
- char sin_zero[8];
+struct protoent {
+ char *p_name; /* official protocol name */
+ char **p_aliases; /* alias list */
+ int p_proto; /* protocol # */
+};
+
+struct servent {
+ char *s_name; /* official service name */
+ char **s_aliases; /* alias list */
+ int s_port; /* port # */
+ char *s_proto; /* protocol to use */
+};
+
+struct in_addr {
+ unsigned long s_addr;
+};
+
+struct sockaddr {
+ unsigned short sa_family; /* address family */
+ char sa_data[14]; /* up to 14 bytes of direct address */
+};
+
+struct timeval {
+ long tv_sec;
+ long tv_usec;
};
struct netent {
int n_addrtype;
long n_net;
};
-
-struct servent {
- char *s_name; /* official service name */
- char **s_aliases; /* alias list */
- int s_port; /* port # */
- char *s_proto; /* protocol to use */
-};
-
-struct protoent {
- char *p_name; /* official protocol name */
- char **p_aliases; /* alias list */
- int p_proto; /* protocol # */
-};
$! A little basic setup
$ On Error Then Goto wrapup
$ olddef = F$Environment("Default")
-$ Set Default Perl_Root:[t]
+$ If F$TrnLNm("Perl_Root").nes.""
+$ Then
+$ Set Default Perl_Root:[t]
+$ Else
+$ Set Default [.t]
+$ EndIf
$
$! Pick up a copy of perl to use for the tests
$ Delete/Log/NoConfirm Perl.;*
.end echo
$ Link/NoTrace Echo.Obj;
$ Delete/Log/NoConfirm Echo.Obj;*
-$ echo = "$Perl_Root:[T]Echo.Exe"
+$ echo = "$" + F$Parse("Echo.Exe")
$
$! And do it
$ MCR Sys$Disk:[]Perl.
-/* VMS-specific routines for perl5
+/* vms.c
*
- * Last revised: 09-Oct-1994
+ * VMS-specific routines for perl5
+ *
+ * Last revised: 09-Mar-1995 by Charles Bailey bailey@genetics.upenn.edu
*/
#include <acedef.h>
#include <acldef.h>
#include <armdef.h>
+#include <atrdef.h>
#include <chpdef.h>
#include <descrip.h>
#include <dvidef.h>
+#include <fibdef.h>
#include <float.h>
#include <fscndef.h>
#include <iodef.h>
#include <libdef.h>
#include <lib$routines.h>
#include <lnmdef.h>
+#include <prvdef.h>
#include <psldef.h>
#include <rms.h>
#include <shrdef.h>
#include <starlet.h>
#include <stsdef.h>
#include <syidef.h>
-
+#include <uaidef.h>
+#include <uicdef.h>
#include "EXTERN.h"
#include "perl.h"
+#include "XSUB.h"
struct itmlst_3 {
unsigned short int buflen;
unsigned short int itmcode;
void *bufadr;
- unsigned long int retlen;
+ unsigned short int *retlen;
};
-static unsigned long int sts;
-
-#define _cksts(call) \
- if (!(sts=(call))&1) { \
- errno = EVMSERR; vaxc$errno = sts; \
- croak("fatal error at %s, line %d",__FILE__,__LINE__); \
- } else { 1; }
+static char *
+my_trnlnm(char *lnm, char *eqv)
+{
+ static char __my_trnlnm_eqv[LNM$C_NAMLENGTH+1];
+ unsigned short int eqvlen;
+ unsigned long int retsts, attr = LNM$M_CASE_BLIND;
+ $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
+ struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
+ struct itmlst_3 lnmlst[2] = {{LNM$C_NAMLENGTH, LNM$_STRING,0, &eqvlen},
+ {0, 0, 0, 0}};
+
+ if (!eqv) eqv = __my_trnlnm_eqv;
+ lnmlst[0].bufadr = (void *)eqv;
+ lnmdsc.dsc$a_pointer = lnm;
+ lnmdsc.dsc$w_length = strlen(lnm);
+ retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
+ if (retsts == SS$_NOLOGNAM || retsts == SS$_IVLOGNAM) return Nullch;
+ else if (retsts & 1) {
+ eqv[eqvlen] = '\0';
+ return eqv;
+ }
+ _ckvmssts(retsts); /* Must be an error */
+ return Nullch; /* Not reached, assuming _ckvmssts() bails out */
+}
/* my_getenv
* Translate a logical name. Substitute for CRTL getenv() to avoid
{
static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
- unsigned short int eqvlen;
- unsigned long int retsts, attr = LNM$M_CASE_BLIND;
- $DESCRIPTOR(sysdiskdsc,"SYS$DISK");
- $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
- struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
- eqvdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
- DSC$K_CLASS_S, __my_getenv_eqv};
- struct itmlst_3 lnmlst[2] = {sizeof __my_getenv_eqv - 1, LNM$_STRING,
- __my_getenv_eqv, &eqvlen, 0, 0, 0, 0};
for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
*cp2 = '\0';
- lnmdsc.dsc$w_length = cp1 - lnm;
- if (lnmdsc.dsc$w_length = 7 && !strncmp(uplnm,"DEFAULT",7)) {
- _cksts(sys$trnlnm(&attr,&tabdsc,&sysdiskdsc,0,lnmlst));
- eqvdsc.dsc$a_pointer += eqvlen;
- eqvdsc.dsc$w_length = sizeof __my_getenv_eqv - eqvlen - 1;
- _cksts(sys$setddir(0,&eqvlen,&eqvdsc));
- eqvdsc.dsc$a_pointer[eqvlen] = '\0';
+ if (cp1 - lnm == 7 && !strncmp(uplnm,"DEFAULT",7)) {
+ getcwd(__my_getenv_eqv,sizeof __my_getenv_eqv);
+ return __my_getenv_eqv;
+ }
+ else if (my_trnlnm(uplnm,__my_getenv_eqv) != NULL) {
return __my_getenv_eqv;
}
else {
- retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
- if (retsts != SS$_NOLOGNAM) {
- if (retsts & 1) {
- __my_getenv_eqv[eqvlen] = '\0';
- return __my_getenv_eqv;
- }
- _cksts(retsts);
- }
- else {
- retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&(eqvdsc.dsc$w_length),0);
- if (retsts != LIB$_NOSUCHSYM) {
- /* We want to return only logical names or CRTL Unix emulations */
- if (retsts & 1) return Nullch;
- _cksts(retsts);
- }
- else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */
+ unsigned long int retsts;
+ struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
+ valdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
+ DSC$K_CLASS_S, __my_getenv_eqv};
+ symdsc.dsc$w_length = cp1 - lnm;
+ symdsc.dsc$a_pointer = uplnm;
+ retsts = lib$get_symbol(&symdsc,&valdsc,&(valdsc.dsc$w_length),0);
+ if (retsts == LIB$_INVSYMNAM) return Nullch;
+ if (retsts != LIB$_NOSUCHSYM) {
+ /* We want to return only logical names or CRTL Unix emulations */
+ if (retsts & 1) return Nullch;
+ _ckvmssts(retsts);
}
+ else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */
}
- return NULL;
+ return Nullch;
} /* end of my_getenv() */
/*}}}*/
if (!eqv || !*eqv) { /* we're deleting a logical name */
retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
- if (retsts != SS$_NOLOGNAM) _cksts(retsts);
+ if (retsts == SS$_IVLOGNAM) return;
+ if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
if (!(retsts & 1)) {
retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
- if (retsts != SS$_NOLOGNAM) _cksts(retsts);
+ if (retsts != SS$_NOLOGNAM) _ckvmssts(retsts);
}
}
else {
eqvdsc.dsc$w_length = strlen(eqv);
eqvdsc.dsc$a_pointer = eqv;
- _cksts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
+ _ckvmssts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
}
} /* end of my_setenv() */
{
char dirfile[NAM$C_MAXRSS+1];
int retval;
- stat_t st;
+ struct stat st;
if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
{
char vmsname[NAM$C_MAXRSS+1];
unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
- unsigned long int uics[2] = {0,0}, cxt = 0, aclsts, fndsts, rmsts = -1;
+ unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
struct myacedef {
- unsigned char ace$b_length;
- unsigned char ace$b_type;
- unsigned short int ace$w_flags;
- unsigned long int ace$l_access;
- unsigned long int ace$l_ident;
+ unsigned char myace$b_length;
+ unsigned char myace$b_type;
+ unsigned short int myace$w_flags;
+ unsigned long int myace$l_access;
+ unsigned long int myace$l_ident;
} newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
struct itmlst_3
- findlst[3] = {sizeof oldace, ACL$C_FNDACLENT, &oldace, 0,
- sizeof oldace, ACL$C_READACE, &oldace, 0, 0, 0, 0, 0},
- addlst[2] = {sizeof newace, ACL$C_ADDACLENT, &newace, 0, 0, 0, 0, 0},
- dellst[2] = {sizeof newace, ACL$C_DELACLENT, &newace, 0, 0, 0, 0, 0},
- lcklst[2] = {sizeof newace, ACL$C_WLOCK_ACL, &newace, 0, 0, 0, 0, 0},
- ulklst[2] = {sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0, 0, 0, 0, 0};
+ findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
+ {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
+ addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
+ dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
+ lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
+ ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
if (!remove(name)) return 0; /* Can we just get rid of it? */
* and the insert an ACE at the head of the ACL which allows us
* to delete the file.
*/
- _cksts(lib$getjpi(&jpicode,0,0,&(oldace.ace$l_ident),0,0));
+ _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
fildsc.dsc$w_length = strlen(vmsname);
fildsc.dsc$a_pointer = vmsname;
cxt = 0;
- newace.ace$l_ident = oldace.ace$l_ident;
+ newace.myace$l_ident = oldace.myace$l_ident;
if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
- errno = EVMSERR;
- vaxc$errno = aclsts;
+ set_errno(EVMSERR);
+ set_vaxc_errno(aclsts);
return -1;
}
/* Grab any existing ACEs with this identifier in case we fail */
/* Add the new ACE . . . */
if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
goto yourroom;
- if (rmsts = remove(name)) {
+ if ((rmsts = remove(name))) {
/* We blew it - dir with files in it, no write priv for
* parent directory, etc. Put things back the way they were. */
if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
if (aclsts & 1) aclsts = fndsts;
}
if (!(aclsts & 1)) {
- errno = EVMSERR;
- vaxc$errno = aclsts;
+ set_errno(EVMSERR);
+ set_vaxc_errno(aclsts);
return -1;
}
} /* end of kill_file() */
/*}}}*/
+/* my_utime - update modification time of a file
+ * calling sequence is identical to POSIX utime(), but under
+ * VMS only the modification time is changed; ODS-2 does not
+ * maintain access times. Restrictions differ from the POSIX
+ * definition in that the time can be changed as long as the
+ * caller has permission to execute the necessary IO$_MODIFY $QIO;
+ * no separate checks are made to insure that the caller is the
+ * owner of the file or has special privs enabled.
+ * Code here is based on Joe Meadows' FILE utility.
+ */
+
+/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
+ * to VMS epoch (01-JAN-1858 00:00:00.00)
+ * in 100 ns intervals.
+ */
+static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
+
+/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
+int my_utime(char *file, struct utimbuf *utimes)
+{
+ register int i;
+ long int bintime[2], len = 2, lowbit, unixtime,
+ secscale = 10000000; /* seconds --> 100 ns intervals */
+ unsigned long int chan, iosb[2], retsts;
+ char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
+ struct FAB myfab = cc$rms_fab;
+ struct NAM mynam = cc$rms_nam;
+ struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
+ struct fibdef myfib;
+ struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
+ devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
+ fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
+
+ if (file == NULL || *file == '\0') {
+ set_errno(ENOENT);
+ set_vaxc_errno(LIB$_INVARG);
+ return -1;
+ }
+ if (tovmsspec(file,vmsspec) == NULL) return -1;
+
+ if (utimes != NULL) {
+ /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
+ * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
+ * Since time_t is unsigned long int, and lib$emul takes a signed long int
+ * as input, we force the sign bit to be clear by shifting unixtime right
+ * one bit, then multiplying by an extra factor of 2 in lib$emul().
+ */
+ lowbit = (utimes->modtime & 1) ? secscale : 0;
+ unixtime = (long int) utimes->modtime;
+ unixtime >> 1; secscale << 1;
+ retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
+ if (!(retsts & 1)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ return -1;
+ }
+ retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
+ if (!(retsts & 1)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ return -1;
+ }
+ }
+ else {
+ /* Just get the current time in VMS format directly */
+ retsts = sys$gettim(bintime);
+ if (!(retsts & 1)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ return -1;
+ }
+ }
+
+ myfab.fab$l_fna = vmsspec;
+ myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
+ myfab.fab$l_nam = &mynam;
+ mynam.nam$l_esa = esa;
+ mynam.nam$b_ess = (unsigned char) sizeof esa;
+ mynam.nam$l_rsa = rsa;
+ mynam.nam$b_rss = (unsigned char) sizeof rsa;
+
+ /* Look for the file to be affected, letting RMS parse the file
+ * specification for us as well. I have set errno using only
+ * values documented in the utime() man page for VMS POSIX.
+ */
+ retsts = sys$parse(&myfab,0,0);
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+ retsts = sys$search(&myfab,0,0);
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else if (retsts == RMS$_FNF) set_errno(ENOENT);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+
+ devdsc.dsc$w_length = mynam.nam$b_dev;
+ devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
+
+ retsts = sys$assign(&devdsc,&chan,0,0);
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
+ else if (retsts == SS$_NOPRIV) set_errno(EACCES);
+ else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+
+ fnmdsc.dsc$a_pointer = mynam.nam$l_name;
+ fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
+
+ memset((void *) &myfib, 0, sizeof myfib);
+#ifdef __DECC
+ for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
+ for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
+ /* This prevents the revision time of the file being reset to the current
+ * time as a reqult of our IO$_MODIFY $QIO. */
+ myfib.fib$l_acctl = FIB$M_NORECORD;
+#else
+ for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
+ for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
+ myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
+#endif
+ retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
+ if (retsts & 1) retsts = iosb[0];
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == SS$_NOPRIV) set_errno(EACCES);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+
+ return 0;
+} /* end of my_utime() */
+/*}}}*/
+
static void
create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
{
* preprocessor consant BUFSIZ from stdio.h as the size of the
* 'pipe' mailbox.
*/
- _cksts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
+ _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
}
- _cksts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
+ _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
- _cksts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
+ _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
} /* end of create_mbx() */
struct pipe_details
{
struct pipe_details *next;
- FILE *fp;
- int pid;
- unsigned long int completion;
+ FILE *fp; /* stdio file pointer to pipe mailbox */
+ int pid; /* PID of subprocess */
+ int mode; /* == 'r' if pipe open for reading */
+ int done; /* subprocess has completed */
+ unsigned long int completion; /* termination status of subprocess */
};
+struct exit_control_block
+{
+ struct exit_control_block *flink;
+ unsigned long int (*exit_routine)();
+ unsigned long int arg_count;
+ unsigned long int *status_address;
+ unsigned long int exit_status;
+};
+
static struct pipe_details *open_pipes = NULL;
static $DESCRIPTOR(nl_desc, "NL:");
static int waitpid_asleep = 0;
+static unsigned long int
+pipe_exit_routine()
+{
+ unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
+
+ while (open_pipes != NULL) {
+ if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
+ _ckvmssts(sys$forcex(&open_pipes->pid,0,&abort));
+ sleep(1);
+ }
+ if (!open_pipes->done) /* We tried to be nice . . . */
+ _ckvmssts(sys$delprc(&open_pipes->pid,0));
+ if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
+ }
+ return retsts;
+}
+
+static struct exit_control_block pipe_exitblock =
+ {(struct exit_control_block *) 0,
+ pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
+
+
static void
-popen_completion_ast(unsigned long int unused)
+popen_completion_ast(struct pipe_details *thispipe)
{
+ thispipe->done = TRUE;
if (waitpid_asleep) {
waitpid_asleep = 0;
sys$wake(0,0);
FILE *
my_popen(char *cmd, char *mode)
{
+ static int handler_set_up = FALSE;
char mbxname[64];
unsigned short int chan;
unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
New(7001,info,1,struct pipe_details);
- info->completion=0; /* I assume this will remain 0 until terminates */
-
/* create mailbox */
create_mbx(&chan,&namdsc);
info->fp=fopen(mbxname, mode);
/* give up other channel onto it */
- _cksts(sys$dassgn(chan));
+ _ckvmssts(sys$dassgn(chan));
if (!info->fp)
return Nullfp;
cmddsc.dsc$w_length=strlen(cmd);
cmddsc.dsc$a_pointer=cmd;
- if (strcmp(mode,"r")==0) {
- _cksts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
+ info->mode = *mode;
+ info->done = FALSE;
+ info->completion=0;
+
+ if (*mode == 'r') {
+ _ckvmssts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
0 /* name */, &info->pid, &info->completion,
- 0, popen_completion_ast,0,0,0,0));
+ 0, popen_completion_ast,info,0,0,0));
}
else {
- _cksts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */,
- 0 /* name */, &info->pid, &info->completion));
+ _ckvmssts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */, &flags,
+ 0 /* name */, &info->pid, &info->completion,
+ 0, popen_completion_ast,info,0,0,0));
}
+ if (!handler_set_up) {
+ _ckvmssts(sys$dclexh(&pipe_exitblock));
+ handler_set_up = TRUE;
+ }
info->next=open_pipes; /* prepend to list */
open_pipes=info;
I32 my_pclose(FILE *fp)
{
struct pipe_details *info, *last = NULL;
- unsigned long int abort = SS$_TIMEOUT, retsts;
+ unsigned long int retsts;
for (info = open_pipes; info != NULL; last = info, info = info->next)
if (info->fp == fp) break;
if (info == NULL)
/* get here => no such pipe open */
- croak("my_pclose() - no such pipe open ???");
+ croak("No such pipe open");
+
+ if (info->done) retsts = info->completion;
+ else waitpid(info->pid,(int *) &retsts,0);
- if (!info->completion) { /* Tap them gently on the shoulder . . .*/
- _cksts(sys$forcex(&info->pid,0,&abort));
- sleep(1);
- }
- if (!info->completion) /* We tried to be nice . . . */
- _cksts(sys$delprc(&info->pid));
-
fclose(info->fp);
+
/* remove from list of open pipes */
if (last) last->next = info->next;
else open_pipes = info->next;
- retsts = info->completion;
Safefree(info);
return retsts;
+
} /* end of my_pclose() */
-#ifndef HAS_WAITPID
/* sort-of waitpid; use only with popen() */
/*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
unsigned long int
waitpid(unsigned long int pid, int *statusp, int flags)
{
struct pipe_details *info;
- unsigned long int abort = SS$_TIMEOUT;
for (info = open_pipes; info != NULL; info = info->next)
if (info->pid == pid) break;
if (info != NULL) { /* we know about this child */
- while (!info->completion) {
+ while (!info->done) {
waitpid_asleep = 1;
sys$hiber();
}
else { /* we haven't heard of this child */
$DESCRIPTOR(intdsc,"0 00:00:01");
unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
- unsigned long int interval[2];
+ unsigned long int interval[2],sts;
- _cksts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
- _cksts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
- if (ownerpid != mypid)
- croak("pid %d not a child",pid);
+ if (dowarn) {
+ _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
+ _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
+ if (ownerpid != mypid)
+ warn("pid %d not a child",pid);
+ }
- _cksts(sys$bintim(&intdsc,interval));
+ _ckvmssts(sys$bintim(&intdsc,interval));
while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
- _cksts(sys$schdwk(0,0,interval,0));
- _cksts(sys$hiber());
+ _ckvmssts(sys$schdwk(0,0,interval,0));
+ _ckvmssts(sys$hiber());
}
- _cksts(sts);
+ _ckvmssts(sts);
/* There's no easy way to find the termination status a child we're
* not aware of beforehand. If we're really interested in the future,
}
} /* end of waitpid() */
-#endif
/*}}}*/
/*}}}*/
/*}}}*/
** converting among VMS-style and Unix-style directory specifications.
** All will take input specifications in either VMS or Unix syntax. On
** failure, all return NULL. If successful, the routines listed below
-** return a pointer to a static buffer containing the appropriately
+** return a pointer to a buffer containing the appropriately
** reformatted spec (and, therefore, subsequent calls to that routine
** will clobber the result), while the routines of the same names with
** a _ts suffix appended will return a pointer to a mallocd string
** tovmsspec() - convert any file spec into a VMS-style spec.
*/
+static char *do_tounixspec(char *, char *, int);
+
/*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
static char *do_fileify_dirspec(char *dir,char *buf,int ts)
{
static char __fileify_retbuf[NAM$C_MAXRSS+1];
unsigned long int dirlen, retlen, addmfd = 0;
char *retspec, *cp1, *cp2, *lastdir;
+ char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
if (dir == NULL) return NULL;
+ strcpy(trndir,dir);
+ while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir) != NULL) ;
+ dir = trndir;
dirlen = strlen(dir);
if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
+ if (dir[0] == '.') {
+ if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
+ return do_fileify_dirspec("[]",buf,ts);
+ else if (dir[1] == '.' &&
+ (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
+ return do_fileify_dirspec("[-]",buf,ts);
+ }
if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
dirlen -= 1; /* to last element */
lastdir = strrchr(dir,'/');
}
+ else if (strstr(trndir,"..") != NULL) {
+ /* If we have a relative path, let do_tovmsspec figure it out,
+ * rather than repeating the code here */
+ if (do_tovmsspec(trndir,vmsdir,0) == NULL) return NULL;
+ if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
+ return do_tounixspec(trndir,buf,ts);
+ }
else {
if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
toupper(*(cp2+3)) == 'R') {
if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
- errno = ENOTDIR; /* Bzzt. */
+ set_errno(ENOTDIR); /* Bzzt. */
+ set_vaxc_errno(RMS$_DIR);
return NULL;
}
}
dirlen = cp2 - dir;
}
else { /* There's a type, and it's not .dir. Bzzt. */
- errno = ENOTDIR;
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
return NULL;
}
}
- /* If we lead off with a device or rooted logical, add the MFD
- if we're specifying a top-level directory. */
- if (lastdir && *dir == '/') {
- addmfd = 1;
- for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
- if (*cp1 == '/') {
- addmfd = 0;
- break;
- }
+ }
+ /* If we lead off with a device or rooted logical, add the MFD
+ if we're specifying a top-level directory. */
+ if (lastdir && *dir == '/') {
+ addmfd = 1;
+ for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
+ if (*cp1 == '/') {
+ addmfd = 0;
+ break;
}
}
- retlen = dirlen + addmfd ? 13 : 6;
- if (buf) retspec = buf;
- else if (ts) New(7009,retspec,retlen+6,char);
- else retspec = __fileify_retbuf;
- if (addmfd) {
- dirlen = lastdir - dir;
- memcpy(retspec,dir,dirlen);
- strcpy(&retspec[dirlen],"/000000");
- strcpy(&retspec[dirlen+7],lastdir);
- }
- else {
- memcpy(retspec,dir,dirlen);
- retspec[dirlen] = '\0';
- }
+ }
+ retlen = dirlen + addmfd ? 13 : 6;
+ if (buf) retspec = buf;
+ else if (ts) New(7009,retspec,retlen+6,char);
+ else retspec = __fileify_retbuf;
+ if (addmfd) {
+ dirlen = lastdir - dir;
+ memcpy(retspec,dir,dirlen);
+ strcpy(&retspec[dirlen],"/000000");
+ strcpy(&retspec[dirlen+7],lastdir);
+ }
+ else {
+ memcpy(retspec,dir,dirlen);
+ retspec[dirlen] = '\0';
}
/* We've picked up everything up to the directory file name.
Now just add the type and version, and we're set. */
}
else { /* VMS-style directory spec */
char esa[NAM$C_MAXRSS+1], term;
- unsigned long int sts, cmplen;
+ unsigned long int cmplen, hasdev, hasdir, hastype, hasver;
struct FAB dirfab = cc$rms_fab;
struct NAM savnam, dirnam = cc$rms_nam;
dirfab.fab$b_fns = strlen(dir);
dirfab.fab$l_fna = dir;
dirfab.fab$l_nam = &dirnam;
+ dirfab.fab$l_dna = ".DIR;1";
+ dirfab.fab$b_dns = 6;
dirnam.nam$b_ess = NAM$C_MAXRSS;
dirnam.nam$l_esa = esa;
- dirnam.nam$b_nop = NAM$M_SYNCHK;
if (!(sys$parse(&dirfab)&1)) {
- errno = EVMSERR;
- vaxc$errno = dirfab.fab$l_sts;
+ set_errno(EVMSERR);
+ set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
}
savnam = dirnam;
}
else {
if (dirfab.fab$l_sts != RMS$_FNF) {
- errno = EVMSERR;
- vaxc$errno = dirfab.fab$l_sts;
+ set_errno(EVMSERR);
+ set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
}
dirnam = savnam; /* No; just work with potential name */
}
-
+ if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
+ cp1 = strchr(esa,']');
+ if (!cp1) cp1 = strchr(esa,'>');
+ if (cp1) { /* Should always be true */
+ dirnam.nam$b_esl -= cp1 - esa - 1;
+ memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
+ }
+ }
if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
/* Yep; check version while we're at it, if it's there. */
cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
/* Something other than .DIR[;1]. Bzzt. */
- errno = ENOTDIR;
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
return NULL;
}
- else { /* Ok, it was .DIR[;1]; copy over everything up to the */
- retlen = dirnam.nam$l_type - esa; /* file name. */
- if (buf) retspec = buf;
- else if (ts) New(7010,retspec,retlen+6,char);
- else retspec = __fileify_retbuf;
- strncpy(retspec,esa,retlen);
- retspec[retlen] = '\0';
- }
+ }
+ esa[dirnam.nam$b_esl] = '\0';
+ if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
+ /* They provided at least the name; we added the type, if necessary, */
+ if (buf) retspec = buf; /* in sys$parse() */
+ else if (ts) New(7011,retspec,dirnam.nam$b_esl,char);
+ else retspec = __fileify_retbuf;
+ strcpy(retspec,esa);
+ return retspec;
+ }
+ if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
+ if (cp1 == NULL) return NULL; /* should never happen */
+ term = *cp1;
+ *cp1 = '\0';
+ retlen = strlen(esa);
+ if ((cp1 = strrchr(esa,'.')) != NULL) {
+ /* There's more than one directory in the path. Just roll back. */
+ *cp1 = term;
+ if (buf) retspec = buf;
+ else if (ts) New(7011,retspec,retlen+6,char);
+ else retspec = __fileify_retbuf;
+ strcpy(retspec,esa);
}
else {
- /* They didn't explicitly specify the directory file. Ignore
- any file names in the input, pull off the last element of the
- directory path, and make it the file name. If you want to
- pay attention to filenames without .dir in the input, just use
- ".DIR;1" as a default filespec for the $PARSE */
- esa[dirnam.nam$b_esl] = '\0';
- if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
- if (cp1 == NULL) return NULL; /* should never happen */
- term = *cp1;
- *cp1 = '\0';
- retlen = strlen(esa);
- if ((cp1 = strrchr(esa,'.')) != NULL) {
- /* There's more than one directory in the path. Just roll back. */
- *cp1 = term;
+ if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
+ /* Go back and expand rooted logical name */
+ dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
+ if (!(sys$parse(&dirfab) & 1)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(dirfab.fab$l_sts);
+ return NULL;
+ }
+ retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
if (buf) retspec = buf;
- else if (ts) New(7011,retspec,retlen+6,char);
+ else if (ts) New(7012,retspec,retlen+7,char);
else retspec = __fileify_retbuf;
- strcpy(retspec,esa);
+ cp1 = strstr(esa,"][");
+ dirlen = cp1 - esa;
+ memcpy(retspec,esa,dirlen);
+ if (!strncmp(cp1+2,"000000]",7)) {
+ retspec[dirlen-1] = '\0';
+ for (cp1 = retspec+dirlen-1; *cp1 != '.'; cp1--) ;
+ *cp1 = ']';
+ }
+ else {
+ memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
+ retspec[retlen] = '\0';
+ /* Convert last '.' to ']' */
+ for (cp1 = retspec+retlen-1; *cp1 != '.'; cp1--) ;
+ *cp1 = ']';
+ }
}
- else { /* This is a top-level dir. Add the MFD to the path. */
+ else { /* This is a top-level dir. Add the MFD to the path. */
if (buf) retspec = buf;
else if (ts) New(7012,retspec,retlen+14,char);
else retspec = __fileify_retbuf;
cp1 += 2;
strcpy(cp2+9,cp1);
}
- }
- /* Again, we've set up the string up through the filename. Add the
+ }
+ /* We've set up the string up through the filename. Add the
type and version, and we're done. */
strcat(retspec,".DIR;1");
return retspec;
{
static char __pathify_retbuf[NAM$C_MAXRSS+1];
unsigned long int retlen;
- char *retpath, *cp1, *cp2;
+ char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
if (dir == NULL) return NULL;
+ strcpy(trndir,dir);
+ while (!strpbrk(trndir,"/]:>") && my_trnlnm(trndir,trndir) != NULL) ;
+ dir = trndir;
+
if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
- if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
- if (cp2 = strchr(cp1,'.')) {
- if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */
- toupper(*(cp2+2)) == 'I' && /* Trim it off. */
- toupper(*(cp2+3)) == 'R') {
- retlen = cp2 - dir + 1;
+ if (*dir == '.' && (*(dir+1) == '\0' ||
+ (*(dir+1) == '.' && *(dir+2) == '\0')))
+ retlen = 2 + (*(dir+1) != '\0');
+ else {
+ if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
+ if ((cp2 = strchr(cp1,'.')) && *(cp2+1) != '.') {
+ if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */
+ toupper(*(cp2+2)) == 'I' && /* Trim it off. */
+ toupper(*(cp2+3)) == 'R') {
+ retlen = cp2 - dir + 1;
+ }
+ else { /* Some other file type. Bzzt. */
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
+ return NULL;
+ }
}
- else { /* Some other file type. Bzzt. */
- errno = ENOTDIR;
- return NULL;
+ else { /* No file type present. Treat the filename as a directory. */
+ retlen = strlen(dir) + 1;
}
}
- else { /* No file type present. Treat the filename as a directory. */
- retlen = strlen(dir) + 1;
- }
if (buf) retpath = buf;
else if (ts) New(7013,retpath,retlen,char);
else retpath = __pathify_retbuf;
}
else { /* VMS-style directory spec */
char esa[NAM$C_MAXRSS+1];
- unsigned long int sts, cmplen;
+ unsigned long int cmplen;
struct FAB dirfab = cc$rms_fab;
struct NAM savnam, dirnam = cc$rms_nam;
dirfab.fab$b_fns = strlen(dir);
dirfab.fab$l_fna = dir;
+ if (dir[dirfab.fab$b_fns-1] == ']' ||
+ dir[dirfab.fab$b_fns-1] == '>' ||
+ dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
+ if (buf) retpath = buf;
+ else if (ts) New(7014,retpath,strlen(dir),char);
+ else retpath = __pathify_retbuf;
+ strcpy(retpath,dir);
+ return retpath;
+ }
+ dirfab.fab$l_dna = ".DIR;1";
+ dirfab.fab$b_dns = 6;
dirfab.fab$l_nam = &dirnam;
- dirnam.nam$b_ess = sizeof esa;
+ dirnam.nam$b_ess = (unsigned char) sizeof esa;
dirnam.nam$l_esa = esa;
- dirnam.nam$b_nop = NAM$M_SYNCHK;
if (!(sys$parse(&dirfab)&1)) {
- errno = EVMSERR;
- vaxc$errno = dirfab.fab$l_sts;
+ set_errno(EVMSERR);
+ set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
}
savnam = dirnam;
- if (sys$search(&dirfab)&1) { /* Does the file really exist? */
- /* Yes; fake the fnb bits so we'll check type below */
- dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
- }
- else {
+ if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
if (dirfab.fab$l_sts != RMS$_FNF) {
- errno = EVMSERR;
- vaxc$errno = dirfab.fab$l_sts;
+ set_errno(EVMSERR);
+ set_vaxc_errno(dirfab.fab$l_sts);
return NULL;
}
dirnam = savnam; /* No; just work with potential name */
cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
/* Something other than .DIR[;1]. Bzzt. */
- errno = ENOTDIR;
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
return NULL;
}
- /* OK, the type was fine. Now pull any file name into the
- directory path. */
- if (cp1 = strrchr(esa,']')) *dirnam.nam$l_type = ']';
- else {
- cp1 = strrchr(esa,'>');
- *dirnam.nam$l_type = '>';
- }
- *cp1 = '.';
- *(dirnam.nam$l_type + 1) = '\0';
- retlen = dirnam.nam$l_type - esa + 2;
}
+ /* OK, the type was fine. Now pull any file name into the
+ directory path. */
+ if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
else {
- /* There wasn't a type on the input, so ignore any file names as
- well. If you want to pay attention to filenames without .dir
- in the input, just use ".DIR;1" as a default filespec for
- the $PARSE and set retlen thus
- retlen = (dirnam.nam$b_rsl ? dirnam.nam$b_rsl : dirnam.nam$b_esl);
- */
- retlen = dirnam.nam$l_name - esa;
- esa[retlen] = '\0';
+ cp1 = strrchr(esa,'>');
+ *dirnam.nam$l_type = '>';
}
+ *cp1 = '.';
+ *(dirnam.nam$l_type + 1) = '\0';
+ retlen = dirnam.nam$l_type - esa + 2;
if (buf) retpath = buf;
else if (ts) New(7014,retpath,retlen,char);
else retpath = __pathify_retbuf;
char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
int devlen, dirlen;
- if (spec == NULL || *spec == '\0') return NULL;
+ if (spec == NULL) return NULL;
if (buf) rslt = buf;
else if (ts) New(7015,rslt,NAM$C_MAXRSS+1,char);
else rslt = __tounixspec_retbuf;
}
if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
if (ts) Safefree(rslt); /* filespecs like */
- errno = EVMSERR; vaxc$errno = RMS$_SYN; /* [--foo.bar] */
+ set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
return NULL;
}
cp2++;
*(cp1++) = '/';
if ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > NAM$C_MAXRSS) {
if (ts) Safefree(rslt);
- errno = ERANGE;
+ set_errno(ERANGE);
+ set_errno(RMS$_SYN);
return NULL;
}
}
}
if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
if (ts) Safefree(rslt); /* filespecs like */
- errno = EVMSERR; vaxc$errno = RMS$_SYN; /* [--foo.bar] */
+ set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [--foo.bar] */
return NULL;
}
cp2++;
/*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
static char *do_tovmsspec(char *path, char *buf, int ts) {
static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
- char *rslt, *dirend, *cp1, *cp2;
+ register char *rslt, *dirend, *cp1, *cp2;
+ register unsigned long int infront = 0;
- if (path == NULL || *path == '\0') return NULL;
+ if (path == NULL) return NULL;
if (buf) rslt = buf;
else if (ts) New(7016,rslt,strlen(path)+1,char);
else rslt = __tovmsspec_retbuf;
- if (strchr(path,']') != NULL || strchr(path,'>') != NULL ||
+ if (strpbrk(path,"]:>") ||
(dirend = strrchr(path,'/')) == NULL) {
- strcpy(rslt,path);
+ if (path[0] == '.') {
+ if (path[1] == '\0') strcpy(rslt,"[]");
+ else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
+ else strcpy(rslt,path); /* probably garbage */
+ }
+ else strcpy(rslt,path);
return rslt;
}
+ if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
+ if (!*(dirend+2)) dirend +=2;
+ if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
+ }
cp1 = rslt;
cp2 = path;
if (*cp2 == '/') {
while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
*(cp1++) = ':';
*(cp1++) = '[';
- cp2++;
- }
+ if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
+ else cp2++;
+ }
else {
*(cp1++) = '[';
- *(cp1++) = '.';
+ if (*cp2 == '.') {
+ if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
+ cp2 += 2; /* skip over "./" - it's redundant */
+ *(cp1++) = '.'; /* but it does indicate a relative dirspec */
+ }
+ else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
+ *(cp1++) = '-'; /* "../" --> "-" */
+ cp2 += 3;
+ }
+ if (cp2 > dirend) cp2 = dirend;
+ }
+ else *(cp1++) = '.';
+ }
+ for (; cp2 < dirend; cp2++) {
+ if (*cp2 == '/') {
+ if (*(cp1-1) != '.') *(cp1++) = '.';
+ infront = 0;
+ }
+ else if (!infront && *cp2 == '.') {
+ if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
+ else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
+ if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
+ else if (*(cp1-2) == '[') *(cp1-1) = '-';
+ else { /* back up over previous directory name */
+ cp1--;
+ while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
+ }
+ cp2 += 2;
+ if (cp2 == dirend) {
+ if (*(cp1-1) == '.') cp1--;
+ break;
+ }
+ }
+ else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
+ }
+ else {
+ if (*(cp1-1) == '-') *(cp1++) = '.';
+ if (*cp2 == '/') *(cp1++) = '.';
+ else if (*cp2 == '.') *(cp1++) = '_';
+ else *(cp1++) = *cp2;
+ infront = 1;
+ }
}
- for (; cp2 < dirend; cp2++) *(cp1++) = (*cp2 == '/') ? '.' : *cp2;
+ if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
*(cp1++) = ']';
- cp2++;
+ if (*cp2) cp2++; /* check in case we ended with trailing '..' */
while (*cp2) *(cp1++) = *(cp2++);
*cp1 = '\0';
int vmslen;
char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
- if (path == NULL || *path == '\0') return NULL;
+ if (path == NULL) return NULL;
if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
if (buf) return buf;
int unixlen;
char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
- if (path == NULL || *path == '\0') return NULL;
+ if (path == NULL) return NULL;
if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
if (buf) return buf;
char *errmode = "w"; /* Mode to Open Error File */
int cmargc = 0; /* Piped Command Arg Count */
char **cmargv = NULL;/* Piped Command Arg Vector */
- stat_t statbuf; /* fstat buffer */
/*
* First handle the case where the last thing on the line ends with
{
if (j+1 >= argc)
{
- errno = EINVAL;
- croak("No input file");
+ fprintf(stderr,"No input file after < on command line");
+ exit(LIB$_WRONUMARG);
}
in = argv[++j];
continue;
{
if (j+1 >= argc)
{
- errno = EINVAL;
- croak("No input file");
+ fprintf(stderr,"No output file after > on command line");
+ exit(LIB$_WRONUMARG);
}
out = argv[++j];
continue;
out = 1 + ap;
if (j >= argc)
{
- errno = EINVAL;
- croak("No output file");
+ fprintf(stderr,"No output file after > or >> on command line");
+ exit(LIB$_WRONUMARG);
}
continue;
}
if ('\0' == ap[2])
err = argv[++j];
else
- err = 1 + ap;
+ err = 2 + ap;
if (j >= argc)
{
- errno = EINVAL;
- croak("No error file");
+ fprintf(stderr,"No output file after 2> or 2>> on command line");
+ exit(LIB$_WRONUMARG);
}
continue;
}
{
if (j+1 >= argc)
{
- errno = EPIPE;
- croak("No command into which to pipe");
+ fprintf(stderr,"No command into which to pipe on command line");
+ exit(LIB$_WRONUMARG);
}
cmargc = argc-(j+1);
cmargv = &argv[j+1];
{
if (out != NULL)
{
- errno = EINVAL;
- croak("'|' and '>' may not both be specified on command line");
+ fprintf(stderr,"'|' and '>' may not both be specified on command line");
+ exit(LIB$_INVARGORD);
}
pipe_and_fork(cmargv);
}
if (in != NULL)
{
- errno = EINVAL;
- croak("'|' and '<' may not both be specified on command line");
+ fprintf(stderr,"'|' and '<' may not both be specified on command line");
+ exit(LIB$_INVARGORD);
}
- fgetname(stdin, mbxname);
+ fgetname(stdin, mbxname,1);
mbxnam.dsc$a_pointer = mbxname;
mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
dvi_item = DVI$_DEVNAM;
lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
- errno = 0;
+ set_errno(0);
+ set_vaxc_errno(1);
freopen(mbxname, "rb", stdin);
if (errno != 0)
{
- croak("Error reopening pipe (name: %s) in binary mode",mbxname);
+ fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
+ exit(vaxc$errno);
}
}
if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
{
- croak("Can't open input file %s",in);
+ fprintf(stderr,"Can't open input file %s as stdin",in);
+ exit(vaxc$errno);
}
if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
{
- croak("Can't open output file %s",out);
+ fprintf(stderr,"Can't open output file %s as stdout",out);
+ exit(vaxc$errno);
}
- if ((err != NULL) && (NULL == freopen(err, errmode, stderr, "mbc=32", "mbf=2")))
- {
- croak("Can't open error file %s",err);
+ if (err != NULL) {
+ FILE *tmperr;
+ if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
+ {
+ fprintf(stderr,"Can't open error file %s as stderr",err);
+ exit(vaxc$errno);
+ }
+ fclose(tmperr);
+ if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
+ {
+ exit(vaxc$errno);
+ }
}
#ifdef ARGPROC_DEBUG
fprintf(stderr, "Arglist:\n");
int *count)
{
int expcount = 0;
-int context = 0;
+unsigned long int context = 0;
int isunix = 0;
-int status;
int status_value;
char *had_version;
char *had_device;
char *devdir;
char vmsspec[NAM$C_MAXRSS+1];
$DESCRIPTOR(filespec, "");
-$DESCRIPTOR(defaultspec, "SYS$DISK:[]*.*;");
+$DESCRIPTOR(defaultspec, "SYS$DISK:[]");
$DESCRIPTOR(resultspec, "");
unsigned long int zero = 0;
resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
resultspec.dsc$b_class = DSC$K_CLASS_D;
resultspec.dsc$a_pointer = NULL;
- if (isunix = strchr(item,'/'))
+ if ((isunix = (int) strchr(item,'/')) != (int) NULL)
filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
if (!isunix || !filespec.dsc$a_pointer)
filespec.dsc$a_pointer = item;
static int child_st[2];/* Event Flag set when child process completes */
-static short child_chan;/* I/O Channel for Pipe Mailbox */
+static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
-static exit_handler(int *status)
+static unsigned long int exit_handler(int *status)
{
short iosb[4];
child_st[0] = 1;
}
-static struct exit_control_block
- {
- struct exit_control_block *flink;
- int (*exit_routine)();
- int arg_count;
- int *status_address;
- int exit_status;
- } exit_block =
+static struct exit_control_block exit_block =
{
0,
exit_handler,
$DESCRIPTOR(cmddsc, "");
static char mbxname[64];
$DESCRIPTOR(mbxdsc, mbxname);
- short iosb[4];
- int status;
int pid, j;
- short dvi_item = DVI$_DEVNAM;
unsigned long int zero = 0, one = 1;
strcpy(subcmd, cmargv[0]);
fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
#endif
- if (0 == (1&(vaxc$errno = lib$spawn(&cmddsc, &mbxdsc, 0, &one,
+ _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
0, &pid, child_st, &zero, sig_child,
- &child_chan))))
- {
- errno = EVMSERR;
- croak("Can't spawn subprocess");
- }
+ &child_chan));
#ifdef ARGPROC_DEBUG
fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
#endif
sys$dclexh(&exit_block);
if (NULL == freopen(mbxname, "wb", stdout))
{
- croak("Can't open pipe mailbox for output");
+ fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
}
}
char pidstring[80];
$DESCRIPTOR(pidstr, "");
int pid;
-unsigned long int flags = 17, one = 1;
+unsigned long int flags = 17, one = 1, retsts;
strcat(command, argv[0]);
while (--argc)
}
value.dsc$a_pointer = command;
value.dsc$w_length = strlen(value.dsc$a_pointer);
- if (0 == (1&(vaxc$errno = lib$set_symbol(&cmd, &value))))
- {
- errno = EVMSERR;
- croak("Can't create symbol for subprocess command");
- }
- if ((0 == (1&(vaxc$errno = lib$spawn(&cmd, &null, 0, &flags, 0, &pid)))) &&
- (vaxc$errno != 0x38250))
- {
- errno = EVMSERR;
- croak("Can't spawn subprocess");
- }
- if (vaxc$errno == 0x38250) /* We must be BATCH, so retry */
- if (0 == (1&(vaxc$errno = lib$spawn(&cmd, &null, 0, &one, 0, &pid))))
- {
- errno = EVMSERR;
- croak("Can't spawn subprocess");
- }
+ _ckvmssts(lib$set_symbol(&cmd, &value));
+ retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
+ if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
+ _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
+ }
+ else {
+ _ckvmssts(retsts);
+ }
#ifdef ARGPROC_DEBUG
fprintf(stderr, "%s\n", command);
#endif
/*}}}*/
/***** End of code taken from Mark Pizzolato's argproc.c package *****/
-/*
- * flex_stat, flex_fstat
- * basic stat, but gets it right when asked to stat
- * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
- */
-
-static char namecache[NAM$C_MAXRSS+1];
-
-static int
-is_null_device(name)
- const char *name;
-{
- /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
- The underscore prefix, controller letter, and unit number are
- independently optional; for our purposes, the colon punctuation
- is not. The colon can be trailed by optional directory and/or
- filename, but two consecutive colons indicates a nodename rather
- than a device. [pr] */
- if (*name == '_') ++name;
- if (tolower(*name++) != 'n') return 0;
- if (tolower(*name++) != 'l') return 0;
- if (tolower(*name) == 'a') ++name;
- if (*name == '0') ++name;
- return (*name++ == ':') && (*name != ':');
-}
-
-/*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
-int
-flex_fstat(int fd, struct stat *statbuf)
-{
- char fspec[NAM$C_MAXRSS+1];
-
- if (!getname(fd,fspec)) return -1;
- return flex_stat(fspec,statbuf);
-
-} /* end of flex_fstat() */
-/*}}}*/
-
-/*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
-flex_stat(char *fspec, struct stat *statbufp)
-{
- char fileified[NAM$C_MAXRSS+1];
- int retval,myretval;
- struct stat tmpbuf;
-
-
- if (statbufp == &statcache) strcpy(namecache,fspec);
- if (is_null_device(fspec)) { /* Fake a stat() for the null device */
- memset(statbufp,0,sizeof *statbufp);
- statbufp->st_dev = "_NLA0:";
- statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
- statbufp->st_uid = 0x00010001;
- statbufp->st_gid = 0x0001;
- time(&statbufp->st_mtime);
- statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
- return 0;
- }
- if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
- else {
- myretval = stat(fileified,&tmpbuf);
- }
- retval = stat(fspec,statbufp);
- if (!myretval) {
- if (retval == -1) {
- *statbufp = tmpbuf;
- retval = 0;
- }
- else if (!retval) { /* Dir with same name. Substitute it. */
- statbufp->st_mode &= ~S_IFDIR;
- statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
- strcpy(namecache,fileified);
- }
- }
- return retval;
-
-} /* end of flex_stat() */
-/*}}}*/
-
/* trim_unixpath()
* Trim Unix-style prefix off filespec, so it looks like what a shell
* glob expansion would return (i.e. from specified prefix on, not
} /* end of trim_unixpath() */
/*}}}*/
-/* Do the permissions allow some operation? Assumes statcache already set. */
-/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
- * subset of the applicable information.
- */
-/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
-I32
-cando(I32 bit, I32 effective, struct stat *statbufp)
-{
- unsigned long int objtyp = ACL$C_FILE, access, retsts;
- unsigned short int retlen;
- struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, namecache};
- static char usrname[L_cuserid];
- static struct dsc$descriptor_s usrdsc =
- {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
- struct itmlst_3 armlst[2] = {sizeof access, CHP$_ACCESS, &access, &retlen,
- 0, 0, 0, 0};
-
- if (!usrdsc.dsc$w_length) {
- cuserid(usrname);
- usrdsc.dsc$w_length = strlen(usrname);
- }
- namdsc.dsc$w_length = strlen(namecache);
- switch (bit) {
- case S_IXUSR:
- case S_IXGRP:
- case S_IXOTH:
- access = ARM$M_EXECUTE;
- break;
- case S_IRUSR:
- case S_IRGRP:
- case S_IROTH:
- access = ARM$M_READ;
- break;
- case S_IWUSR:
- case S_IWGRP:
- case S_IWOTH:
- access = ARM$M_READ;
- break;
- default:
- return FALSE;
- }
-
- retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
- if (retsts == SS$_NORMAL) return TRUE;
- if (retsts == SS$_NOPRIV) return FALSE;
- _cksts(retsts);
-
- return FALSE; /* Should never get here */
-
-} /* end of cando() */
-/*}}}*/
/*
* VMS readdir() routines.
e->vms_verscount++) {
tmpsts = lib$find_file(&pat, &res, &context);
if (tmpsts == RMS$_NMF || context == 0) break;
- _cksts(tmpsts);
+ _ckvmssts(tmpsts);
buff[sizeof buff - 1] = '\0';
- if (p = strchr(buff, ';'))
+ if ((p = strchr(buff, ';')))
e->vms_versions[e->vms_verscount] = atoi(p + 1);
else
e->vms_versions[e->vms_verscount] = -1;
}
- _cksts(lib$find_file_end(&context));
+ _ckvmssts(lib$find_file_end(&context));
Safefree(text);
} /* end of collectversions() */
{
struct dsc$descriptor_s res;
char *p, buff[sizeof dd->entry.d_name];
- int i;
unsigned long int tmpsts;
/* Set up result descriptor, and get next file. */
res.dsc$b_class = DSC$K_CLASS_S;
dd->count++;
tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
- if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
+ if ( tmpsts == RMS$_NMF || tmpsts == RMS$_FNF ||
+ dd->context == 0) return NULL; /* None left. */
/* Force the buffer to end with a NUL, and downcase name to match C convention. */
buff[sizeof buff - 1] = '\0';
*p = '\0';
/* Skip any directory component and just copy the name. */
- if (p = strchr(buff, ']')) (void)strcpy(dd->entry.d_name, p + 1);
+ if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
else (void)strcpy(dd->entry.d_name, buff);
/* Clobber the version. */
- if (p = strchr(dd->entry.d_name, ';')) *p = '\0';
+ if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
dd->entry.d_namlen = strlen(dd->entry.d_name);
dd->entry.vms_verscount = 0;
seekdir(DIR *dd, long count)
{
int vms_wantversions;
- unsigned long int tmpsts;
/* If we haven't done anything yet... */
if (dd->count == 0)
/* Remember some state, and clear it. */
vms_wantversions = dd->vms_wantversions;
dd->vms_wantversions = 0;
- _cksts(lib$find_file_end(&dd->context));
+ _ckvmssts(lib$find_file_end(&dd->context));
dd->context = 0;
/* The increment is in readdir(). */
int
my_vfork()
{
- vfork_called = 1;
+ vfork_called++;
return vfork();
}
/*}}}*/
register SV **idx;
idx = mark;
- if (really && *(tmps = SvPV(really,rlen))) {
+ tmps = SvPV(really,rlen);
+ if (really && *tmps) {
cmdlen += rlen + 1;
idx++;
}
retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
if ((retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
else {
- _cksts(retsts);
- _cksts(lib$find_file_end(&cxt));
+ _ckvmssts(retsts);
+ _ckvmssts(lib$find_file_end(&cxt));
s = resspec;
while (*s && !isspace(*s)) s++;
*s = '\0';
if (sp > mark) {
if (vfork_called) { /* this follows a vfork - act Unixish */
- vfork_called = 0;
- do_aexec(really,mark,sp);
- }
- else { /* no vfork - act VMSish */
- setup_argstr(really,mark,sp,&Argv);
- return vms_do_exec(Argv);
+ vfork_called--;
+ if (vfork_called < 0) {
+ warn("Internal inconsistency in tracking vforks");
+ vfork_called = 0;
+ }
+ else return do_aexec(really,mark,sp);
}
+
+ /* no vfork - act VMSish */
+ setup_argstr(really,mark,sp,Argv);
+ return vms_do_exec(*Argv);
}
return FALSE;
{
if (vfork_called) { /* this follows a vfork - act Unixish */
- vfork_called = 0;
- do_exec(cmd);
+ vfork_called--;
+ if (vfork_called < 0) {
+ warn("Internal inconsistency in tracking vforks");
+ vfork_called = 0;
+ }
+ else return do_exec(cmd);
}
- else { /* no vfork - act VMSish */
+
+ { /* no vfork - act VMSish */
struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ unsigned long int retsts;
- if ((vaxc$errno = setup_cmddsc(cmd,&cmddsc,1)) & 1)
- vaxc$errno = lib$do_command(&cmddsc);
+ if ((retsts = setup_cmddsc(cmd,&cmddsc,1)) & 1)
+ retsts = lib$do_command(&cmddsc);
- errno = EVMSERR;
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
if (dowarn)
warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno));
do_execfree();
{
if (sp > mark) {
- setup_argstr(really,mark,sp,&Argv);
- return do_spawn(Argv);
+ setup_argstr(really,mark,sp,Argv);
+ return do_spawn(*Argv);
}
return SS$_ABORT;
struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
unsigned long int substs;
- if ((substs = setup_cmddsc(cmd,&cmddsc,0)) & 1)
- _cksts(lib$spawn(&cmddsc,&nl_desc,0,0,0,&substs,0,0,0,0,0));
+ if (!cmd || !*cmd) {
+ _ckvmssts(lib$spawn(0,0,0,0,0,&substs,0,0,0,0,0));
+ }
+ else if ((substs = setup_cmddsc(cmd,&cmddsc,0)) & 1) {
+ _ckvmssts(lib$spawn(&cmddsc,0,0,0,0,&substs,0,0,0,0,0));
+ }
if (!(substs&1)) {
- vaxc$errno = substs;
- errno = EVMSERR;
+ set_errno(EVMSERR);
+ set_vaxc_errno(substs);
if (dowarn)
- warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno));
+ warn("Can't exec \"%s\": %s",
+ (cmd && *cmd) ? cmddsc.dsc$a_pointer : "", Strerror(errno));
}
return substs;
} /* end of my_fwrite() */
/*}}}*/
-#ifndef VMS_DO_SOCKETS
-/***** The following two routines are temporary, and should be removed,
- * along with the corresponding #defines in vmsish.h, when TCP/IP support
- * has been added to the VMS port of perl5. (The temporary hacks are
- * here now sho that pack can handle type N elements.)
- * - C. Bailey 16-Aug-1994
- *****/
-
-/*{{{ unsigned short int tmp_shortflip(unsigned short int val)*/
-unsigned short int
-tmp_shortflip(unsigned short int val)
+/*
+ * Here are replacements for the following Unix routines in the VMS environment:
+ * getpwuid Get information for a particular UIC or UID
+ * getpwnam Get information for a named user
+ * getpwent Get information for each user in the rights database
+ * setpwent Reset search to the start of the rights database
+ * endpwent Finish searching for users in the rights database
+ *
+ * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
+ * (defined in pwd.h), which contains the following fields:-
+ * struct passwd {
+ * char *pw_name; Username (in lower case)
+ * char *pw_passwd; Hashed password
+ * unsigned int pw_uid; UIC
+ * unsigned int pw_gid; UIC group number
+ * char *pw_unixdir; Default device/directory (VMS-style)
+ * char *pw_gecos; Owner name
+ * char *pw_dir; Default device/directory (Unix-style)
+ * char *pw_shell; Default CLI name (eg. DCL)
+ * };
+ * If the specified user does not exist, getpwuid and getpwnam return NULL.
+ *
+ * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
+ * not the UIC member number (eg. what's returned by getuid()),
+ * getpwuid() can accept either as input (if uid is specified, the caller's
+ * UIC group is used), though it won't recognise gid=0.
+ *
+ * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
+ * information about other users in your group or in other groups, respectively.
+ * If the required privilege is not available, then these routines fill only
+ * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
+ * string).
+ *
+ * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
+ */
+
+/* sizes of various UAF record fields */
+#define UAI$S_USERNAME 12
+#define UAI$S_IDENT 31
+#define UAI$S_OWNER 31
+#define UAI$S_DEFDEV 31
+#define UAI$S_DEFDIR 63
+#define UAI$S_DEFCLI 31
+#define UAI$S_PWD 8
+
+#define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
+ (uic).uic$v_member != UIC$K_WILD_MEMBER && \
+ (uic).uic$v_group != UIC$K_WILD_GROUP)
+
+static const char __empty[]= "";
+static const struct passwd __passwd_empty=
+ {(char *) __empty, (char *) __empty, 0, 0,
+ (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
+static int contxt= 0;
+static struct passwd __pwdcache;
+static char __pw_namecache[UAI$S_IDENT+1];
+
+static char *_mystrtolower(char *str)
+{
+ if (str) for (; *str; ++str) *str= tolower(*str);
+ return str;
+}
+
+/*
+ * This routine does most of the work extracting the user information.
+ */
+static int fillpasswd (const char *name, struct passwd *pwd)
{
- return val << 8 | val >> 8;
+ static struct {
+ unsigned char length;
+ char pw_gecos[UAI$S_OWNER+1];
+ } owner;
+ static union uicdef uic;
+ static struct {
+ unsigned char length;
+ char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
+ } defdev;
+ static struct {
+ unsigned char length;
+ char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
+ } defdir;
+ static struct {
+ unsigned char length;
+ char pw_shell[UAI$S_DEFCLI+1];
+ } defcli;
+ static char pw_passwd[UAI$S_PWD+1];
+
+ static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
+ struct dsc$descriptor_s name_desc;
+ int status;
+
+ static const struct itmlst_3 itmlst[]= {
+ {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
+ {sizeof(uic), UAI$_UIC, &uic, &luic},
+ {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
+ {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
+ {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
+ {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
+ {0, 0, NULL, NULL}};
+
+ name_desc.dsc$w_length= strlen(name);
+ name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
+ name_desc.dsc$b_class= DSC$K_CLASS_S;
+ name_desc.dsc$a_pointer= (char *) name;
+
+/* Note that sys$getuai returns many fields as counted strings. */
+ status= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
+ if (!(status&1)) return status;
+
+ if ((int) owner.length < lowner) lowner= (int) owner.length;
+ if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
+ if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
+ if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
+ memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
+ owner.pw_gecos[lowner]= '\0';
+ defdev.pw_dir[ldefdev+ldefdir]= '\0';
+ defcli.pw_shell[ldefcli]= '\0';
+ if (valid_uic(uic)) {
+ pwd->pw_uid= uic.uic$l_uic;
+ pwd->pw_gid= uic.uic$v_group;
+ }
+ else
+ warn("getpwnam returned invalid UIC %#o for user \"%s\"");
+ pwd->pw_passwd= pw_passwd;
+ pwd->pw_gecos= owner.pw_gecos;
+ pwd->pw_dir= defdev.pw_dir;
+ pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
+ pwd->pw_shell= defcli.pw_shell;
+ if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
+ int ldir;
+ ldir= strlen(pwd->pw_unixdir) - 1;
+ if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
+ }
+ else
+ strcpy(pwd->pw_unixdir, pwd->pw_dir);
+ _mystrtolower(pwd->pw_unixdir);
+ return status;
}
+
+/*
+ * Get information for a named user.
+*/
+/*{{{struct passwd *getpwnam(char *name)*/
+struct passwd *my_getpwnam(char *name)
+{
+ struct dsc$descriptor_s name_desc;
+ union uicdef uic;
+ unsigned long int status, stat;
+
+ __pwdcache = __passwd_empty;
+ if ((status = fillpasswd(name, &__pwdcache)) == SS$_NOSYSPRV
+ || status == SS$_NOGRPPRV || status == RMS$_RNF) {
+ /* We still may be able to determine pw_uid and pw_gid */
+ name_desc.dsc$w_length= strlen(name);
+ name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
+ name_desc.dsc$b_class= DSC$K_CLASS_S;
+ name_desc.dsc$a_pointer= (char *) name;
+ if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
+ __pwdcache.pw_uid= uic.uic$l_uic;
+ __pwdcache.pw_gid= uic.uic$v_group;
+ }
+ else if (stat == SS$_NOSUCHID || stat == RMS$_PRV) return NULL;
+ else { _ckvmssts(stat); }
+ }
+ else { _ckvmssts(status); }
+ strncpy(__pw_namecache, name, sizeof(__pw_namecache));
+ __pw_namecache[sizeof __pw_namecache - 1] = '\0';
+ __pwdcache.pw_name= __pw_namecache;
+ return &__pwdcache;
+} /* end of my_getpwnam() */
/*}}}*/
-/*{{{ unsigned long int tmp_longflip(unsigned long int val)*/
-unsigned long int
-tmp_longflip(unsigned long int val)
+/*
+ * Get information for a particular UIC or UID.
+ * Called by my_getpwent with uid=-1 to list all users.
+*/
+/*{{{struct passwd *my_getpwuid(Uid_t uid)*/
+struct passwd *my_getpwuid(Uid_t uid)
{
- unsigned long int scratch = val;
- unsigned char savbyte, *tmp;
+ const $DESCRIPTOR(name_desc,__pw_namecache);
+ unsigned short lname;
+ union uicdef uic;
+ unsigned long int status;
+
+ if (uid == (unsigned int) -1) {
+ do {
+ status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
+ if (status == SS$_NOSUCHID || status == RMS$_PRV) {
+ my_endpwent();
+ return NULL;
+ }
+ else { _ckvmssts(status); }
+ } while (!valid_uic (uic));
+ }
+ else {
+ uic.uic$l_uic= uid;
+ if (!uic.uic$v_group) uic.uic$v_group= getgid();
+ if (valid_uic(uic))
+ status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
+ else status = SS$_IVIDENT;
+ _ckvmssts(status);
+ }
+ __pw_namecache[lname]= '\0';
+ _mystrtolower(__pw_namecache);
+
+ __pwdcache = __passwd_empty;
+ __pwdcache.pw_name = __pw_namecache;
+
+/* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
+ The identifier's value is usually the UIC, but it doesn't have to be,
+ so if we can, we let fillpasswd update this. */
+ __pwdcache.pw_uid = uic.uic$l_uic;
+ __pwdcache.pw_gid = uic.uic$v_group;
+
+ status = fillpasswd(__pw_namecache, &__pwdcache);
+ if (status != SS$_NOSYSPRV && status != SS$_NOGRPPRV &&
+ status != RMS$_RNF) { _ckvmssts(status); }
+ return &__pwdcache;
- tmp = (unsigned char *) &scratch;
- savbyte = tmp[0]; tmp[0] = tmp[3]; tmp[3] = savbyte;
- savbyte = tmp[1]; tmp[1] = tmp[2]; tmp[2] = savbyte;
+} /* end of my_getpwuid() */
+/*}}}*/
+
+/*
+ * Get information for next user.
+*/
+/*{{{struct passwd *my_getpwent()*/
+struct passwd *my_getpwent()
+{
+ return (my_getpwuid((unsigned int) -1));
+}
+/*}}}*/
- return scratch;
+/*
+ * Finish searching rights database for users.
+*/
+/*{{{void my_endpwent()*/
+void my_endpwent()
+{
+ if (contxt) {
+ _ckvmssts(sys$finish_rdb(&contxt));
+ contxt= 0;
+ }
}
/*}}}*/
+
+/*
+ * flex_stat, flex_fstat
+ * basic stat, but gets it right when asked to stat
+ * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
+ */
+
+/* encode_dev packs a VMS device name string into an integer to allow
+ * simple comparisons. This can be used, for example, to check whether two
+ * files are located on the same device, by comparing their encoded device
+ * names. Even a string comparison would not do, because stat() reuses the
+ * device name buffer for each call; so without encode_dev, it would be
+ * necessary to save the buffer and use strcmp (this would mean a number of
+ * changes to the standard Perl code, to say nothing of what a Perl script
+ * would have to do.
+ *
+ * The device lock id, if it exists, should be unique (unless perhaps compared
+ * with lock ids transferred from other nodes). We have a lock id if the disk is
+ * mounted cluster-wide, which is when we tend to get long (host-qualified)
+ * device names. Thus we use the lock id in preference, and only if that isn't
+ * available, do we try to pack the device name into an integer (flagged by
+ * the sign bit (LOCKID_MASK) being set).
+ *
+ * Note that encode_dev cann guarantee an 1-to-1 correspondence twixt device
+ * name and its encoded form, but it seems very unlikely that we will find
+ * two files on different disks that share the same encoded device names,
+ * and even more remote that they will share the same file id (if the test
+ * is to check for the same file).
+ *
+ * A better method might be to use sys$device_scan on the first call, and to
+ * search for the device, returning an index into the cached array.
+ * The number returned would be more intelligable.
+ * This is probably not worth it, and anyway would take quite a bit longer
+ * on the first call.
+ */
+#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
+static dev_t encode_dev (const char *dev)
+{
+ int i;
+ unsigned long int f;
+ dev_t enc;
+ char c;
+ const char *q;
+
+ if (!dev || !dev[0]) return 0;
+
+#if LOCKID_MASK
+ {
+ struct dsc$descriptor_s dev_desc;
+ unsigned long int status, lockid, item = DVI$_LOCKID;
+
+ /* For cluster-mounted disks, the disk lock identifier is unique, so we
+ can try that first. */
+ dev_desc.dsc$w_length = strlen (dev);
+ dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
+ dev_desc.dsc$b_class = DSC$K_CLASS_S;
+ dev_desc.dsc$a_pointer = (char *) dev;
+ _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
+ if (lockid) return (lockid & ~LOCKID_MASK);
+ }
#endif
+
+ /* Otherwise we try to encode the device name */
+ enc = 0;
+ f = 1;
+ i = 0;
+ for (q = dev + strlen(dev); q--; q >= dev) {
+ if (isdigit (*q))
+ c= (*q) - '0';
+ else if (isalpha (toupper (*q)))
+ c= toupper (*q) - 'A' + (char)10;
+ else
+ continue; /* Skip '$'s */
+ i++;
+ if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
+ if (i>1) f *= 36;
+ enc += f * (unsigned long int) c;
+ }
+ return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
+
+} /* end of encode_dev() */
+
+static char namecache[NAM$C_MAXRSS+1];
+
+static int
+is_null_device(name)
+ const char *name;
+{
+ /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
+ The underscore prefix, controller letter, and unit number are
+ independently optional; for our purposes, the colon punctuation
+ is not. The colon can be trailed by optional directory and/or
+ filename, but two consecutive colons indicates a nodename rather
+ than a device. [pr] */
+ if (*name == '_') ++name;
+ if (tolower(*name++) != 'n') return 0;
+ if (tolower(*name++) != 'l') return 0;
+ if (tolower(*name) == 'a') ++name;
+ if (*name == '0') ++name;
+ return (*name++ == ':') && (*name != ':');
+}
+
+/* Do the permissions allow some operation? Assumes statcache already set. */
+/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
+ * subset of the applicable information.
+ */
+/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
+I32
+cando(I32 bit, I32 effective, struct stat *statbufp)
+{
+ if (statbufp == &statcache)
+ return cando_by_name(bit,effective,namecache);
+ else {
+ char fname[NAM$C_MAXRSS+1];
+ unsigned long int retsts;
+ struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
+ namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+
+ /* If the struct mystat is stale, we're OOL; stat() overwrites the
+ device name on successive calls */
+ devdsc.dsc$a_pointer = statbufp->st_devnam;
+ devdsc.dsc$w_length = strlen(statbufp->st_devnam);
+ namdsc.dsc$a_pointer = fname;
+ namdsc.dsc$w_length = sizeof fname - 1;
+
+ retsts = lib$fid_to_name(&devdsc,statbufp->st_inode_u.fid,&namdsc,
+ &namdsc.dsc$w_length,0,0);
+ if (retsts & 1) {
+ fname[namdsc.dsc$w_length] = '\0';
+ return cando_by_name(bit,effective,fname);
+ }
+ else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
+ warn("Can't get filespec - stale stat buffer?\n");
+ return FALSE;
+ }
+ _ckvmssts(retsts);
+ return FALSE; /* Should never get to here */
+ }
+}
+/*}}}*/
+
+/*{{{I32 cando_by_name(I32 bit, I32 effective, char *fname)*/
+I32
+cando_by_name(I32 bit, I32 effective, char *fname)
+{
+ static char usrname[L_cuserid];
+ static struct dsc$descriptor_s usrdsc =
+ {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
+
+ 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};
+ union prvdef curprv;
+ struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
+ {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
+ struct itmlst_3 jpilst[2] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
+ {0,0,0,0}};
+
+ if (!fname || !*fname) return FALSE;
+ 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:
+ case S_IXOTH:
+ access = ARM$M_EXECUTE;
+ break;
+ case S_IRUSR:
+ case S_IRGRP:
+ case S_IROTH:
+ access = ARM$M_READ;
+ break;
+ case S_IWUSR:
+ case S_IWGRP:
+ case S_IWOTH:
+ access = ARM$M_WRITE;
+ break;
+ case S_IDUSR:
+ case S_IDGRP:
+ case S_IDOTH:
+ access = ARM$M_DELETE;
+ break;
+ default:
+ return FALSE;
+ }
+
+ retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
+ if (retsts == SS$_NOPRIV || retsts == RMS$_FNF ||
+ retsts == RMS$_DIR || retsts == RMS$_DEV) return FALSE;
+ if (retsts == SS$_NORMAL) {
+ if (!privused) return TRUE;
+ /* We can get access, but only by using privs. Do we have the
+ necessary privs currently enabled? */
+ _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
+ if ((privused & CHP$M_BYPASS) && !curprv.prv$v_bypass) return FALSE;
+ if ((privused & CHP$M_SYSPRV) && !curprv.prv$v_sysprv
+ && !curprv.prv$v_bypass) return FALSE;
+ if ((privused & CHP$M_GRPPRV) && !curprv.prv$v_grpprv
+ && !curprv.prv$v_sysprv && !curprv.prv$v_bypass) return FALSE;
+ if ((privused & CHP$M_READALL) && !curprv.prv$v_readall) return FALSE;
+ return TRUE;
+ }
+ _ckvmssts(retsts);
+
+ return FALSE; /* Should never get here */
+
+} /* end of cando_by_name() */
+/*}}}*/
+
+
+/*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
+int
+flex_fstat(int fd, struct stat *statbuf)
+{
+ char fspec[NAM$C_MAXRSS+1];
+
+ if (!getname(fd,fspec,1)) return -1;
+ return flex_stat(fspec,statbuf);
+
+} /* end of flex_fstat() */
+/*}}}*/
+
+/*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
+int
+flex_stat(char *fspec, struct stat *statbufp)
+{
+ char fileified[NAM$C_MAXRSS+1];
+ int retval,myretval;
+ struct stat tmpbuf;
+
+
+ if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
+ if (is_null_device(fspec)) { /* Fake a stat() for the null device */
+ memset(statbufp,0,sizeof *statbufp);
+ statbufp->st_dev = encode_dev("_NLA0:");
+ statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
+ statbufp->st_uid = 0x00010001;
+ statbufp->st_gid = 0x0001;
+ time((time_t *)&statbufp->st_mtime);
+ statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
+ return 0;
+ }
+
+/* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
+ * 'struct stat' elsewhere in Perl would use our struct. We go back
+ * to the system version here, since we're actually calling their
+ * stat().
+ */
+#undef stat
+
+ if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
+ else {
+ myretval = stat(fileified,(stat_t *) &tmpbuf);
+ }
+ retval = stat(fspec,(stat_t *) statbufp);
+ if (!myretval) {
+ if (retval == -1) {
+ *statbufp = tmpbuf;
+ retval = 0;
+ }
+ else if (!retval) { /* Dir with same name. Substitute it. */
+ statbufp->st_mode &= ~S_IFDIR;
+ statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
+ strcpy(namecache,fileified);
+ }
+ }
+ if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
+ return retval;
+
+} /* end of flex_stat() */
+/*}}}*/
+
+/*** 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,
+ * that's it's nice to have them available to miniperl as well as the
+ * full Perl, so they're set up here instead of in an extension. The
+ * Perl code which handles importation of these names into a given
+ * package lives in [.VMS]Filespec.pm in @INC.
+ */
+
+void
+vmsify_fromperl(CV *cv)
+{
+ dXSARGS;
+ char *vmsified;
+
+ if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
+ vmsified = do_tovmsspec(SvPV(ST(0),na),NULL,1);
+ ST(0) = sv_newmortal();
+ if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
+ XSRETURN(1);
+}
+
+void
+unixify_fromperl(CV *cv)
+{
+ dXSARGS;
+ char *unixified;
+
+ if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
+ unixified = do_tounixspec(SvPV(ST(0),na),NULL,1);
+ ST(0) = sv_newmortal();
+ if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
+ XSRETURN(1);
+}
+
+void
+fileify_fromperl(CV *cv)
+{
+ dXSARGS;
+ char *fileified;
+
+ if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
+ fileified = do_fileify_dirspec(SvPV(ST(0),na),NULL,1);
+ ST(0) = sv_newmortal();
+ if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
+ XSRETURN(1);
+}
+
+void
+pathify_fromperl(CV *cv)
+{
+ dXSARGS;
+ char *pathified;
+
+ if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
+ pathified = do_pathify_dirspec(SvPV(ST(0),na),NULL,1);
+ ST(0) = sv_newmortal();
+ if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
+ XSRETURN(1);
+}
+
+void
+vmspath_fromperl(CV *cv)
+{
+ dXSARGS;
+ char *vmspath;
+
+ if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
+ vmspath = do_tovmspath(SvPV(ST(0),na),NULL,1);
+ ST(0) = sv_newmortal();
+ if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
+ XSRETURN(1);
+}
+
+void
+unixpath_fromperl(CV *cv)
+{
+ dXSARGS;
+ char *unixpath;
+
+ if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
+ unixpath = do_tounixpath(SvPV(ST(0),na),NULL,1);
+ ST(0) = sv_newmortal();
+ if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
+ XSRETURN(1);
+}
+
+void
+candelete_fromperl(CV *cv)
+{
+ dXSARGS;
+ char vmsspec[NAM$C_MAXRSS+1];
+
+ 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;
+ XSRETURN(1);
+}
+
+void
+init_os_extras()
+{
+ char* file = __FILE__;
+
+ newXS("VMS::Filespec::vmsify",vmsify_fromperl,file);
+ newXS("VMS::Filespec::unixify",unixify_fromperl,file);
+ newXS("VMS::Filespec::pathify",pathify_fromperl,file);
+ newXS("VMS::Filespec::fileify",fileify_fromperl,file);
+ newXS("VMS::Filespec::vmspath",vmspath_fromperl,file);
+ newXS("VMS::Filespec::unixpath",unixpath_fromperl,file);
+ newXS("VMS::Filespec::candelete",candelete_fromperl,file);
+ return;
+}
+
+/* End of vms.c */
*
* VMS-specific C header file for perl5.
*
- * Last revised: 09-Oct-1994 by Charles Bailey bailey@genetics.upenn.edu
+ * Last revised: 12-Dec-1994 by Charles Bailey bailey@genetics.upenn.edu
*/
#ifndef __vmsish_h_included
#define __vmsish_h_included
#include <descrip.h> /* for dirent struct definitions */
+#include <libdef.h> /* status codes for various places */
+#include <rmsdef.h> /* at which errno and vaxc$errno are */
+#include <ssdef.h> /* explicitly set in the perl source code */
+
+/* DEC's C compilers and gcc use incompatible definitions of _to(upp|low)er() */
+#ifdef _toupper
+# undef _toupper
+#endif
+#define _toupper(c) (((c) < 'a' || (c) > 'z') ? (c) : (c) & ~040)
+#ifdef _tolower
+# undef _tolower
+#endif
+#define _tolower(c) (((c) < 'A' || (c) > 'Z') ? (c) : (c) | 040)
/* Assorted things to look like Unix */
#ifdef __GNUC__
#ifndef _IOLBF /* gcc's stdio.h doesn't define this */
#define _IOLBF 1
#endif
-#else
+#endif
#include <processes.h> /* for vfork() */
#include <unixio.h>
-#endif
#include <unixlib.h>
#include <file.h> /* it's not <sys/file.h>, so don't use I_SYS_FILE */
-#define unlink remove
+#define unlink kill_file
+
+/* Macros to set errno using the VAX thread-safe calls, if present */
+#if (defined(__DECC) || defined(__DECCXX)) && !defined(__ALPHA)
+# define set_errno(v) (cma$tis_errno_set_value(v))
+# define set_vaxc_errno(v) (vaxc$errno = (v))
+#else
+# define set_errno(v) (errno = (v))
+# define set_vaxc_errno(v) (vaxc$errno = (v))
+#endif
+
+/* Handy way to vet calls to VMS system services and RTL routines. */
+#define _ckvmssts(call) { register unsigned long int __ckvms_sts; \
+ if (!((__ckvms_sts=(call))&1)) { \
+ set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \
+ croak("Fatal VMS error at %s, line %d",__FILE__,__LINE__); } }
#ifdef VMS_DO_SOCKETS
#include "sockadapt.h"
# include <signal.h>
#define ABORT() abort()
+/* Used with our my_utime() routine in vms.c */
+struct utimbuf {
+ time_t actime;
+ time_t modtime;
+};
+#define utime my_utime
+
/* This is what times() returns, but <times.h> calls it tbuffer_t on VMS */
struct tms {
#define rewinddir(dirp) seekdir((dirp), 0)
+/* used for our emulation of getpw* */
+struct passwd {
+ char *pw_name; /* Username */
+ char *pw_passwd;
+ Uid_t pw_uid; /* UIC member number */
+ Gid_t pw_gid; /* UIC group number */
+ char *pw_comment; /* Default device/directory (Unix-style) */
+ char *pw_gecos; /* Owner */
+ char *pw_dir; /* Default device/directory (VMS-style) */
+ char *pw_shell; /* Default CLI name (eg. DCL) */
+};
+#define pw_unixdir pw_comment /* Default device/directory (Unix-style) */
+#define getpwnam my_getpwnam
+#define getpwuid my_getpwuid
+#define getpwent my_getpwent
+#define endpwent my_endpwent
+#define setpwent my_endpwent
+
+/* Our own stat_t substitute, since we play with st_dev and st_ino -
+ * we want atomic types so Unix-bound code which compares these fields
+ * for two files will work most of the time under VMS
+ */
+/* First, grab the system types, so we don't clobber them later */
+#include <stat.h>
+/* Since we've got to match the size of the CRTL's stat_t, we need
+ * to mimic DECC's alignment settings.
+ */
+#if defined(__DECC) || defined(__DECCXX)
+# pragma __member_alignment __save
+# pragma __nomember_alignment
+#endif
+#if defined(__DECC)
+# pragma __message __save
+# pragma __message disable (__MISALGNDSTRCT)
+# pragma __message disable (__MISALGNDMEM)
+#endif
+struct mystat
+{
+ char *st_devnam; /* pointer to device name */
+ union {
+ unsigned short fid[3];
+ unsigned long st_ino_mostly;
+ } st_inode_u;
+ unsigned short st_mode; /* file "mode" i.e. prot, dir, reg, etc. */
+ int st_nlink; /* for compatibility - not really used */
+ unsigned st_uid; /* from ACP - QIO uic field */
+ unsigned short st_gid; /* group number extracted from st_uid */
+ dev_t st_rdev; /* for compatibility - always zero */
+ off_t st_size; /* file size in bytes */
+ unsigned st_atime; /* file access time; always same as st_mtime */
+ unsigned st_mtime; /* last modification time */
+ unsigned st_ctime; /* file creation time */
+ char st_fab_rfm; /* record format */
+ char st_fab_rat; /* record attributes */
+ char st_fab_fsz; /* fixed header size */
+ unsigned st_dev; /* encoded device name */
+};
+#ifdef st_ino
+# undef st_ino
+#endif
+#define st_ino st_inode_u.st_ino_mostly
+#define stat mystat
+typedef unsigned mydev_t;
+#define dev_t mydev_t
+typedef unsigned long myino_t;
+#define ino_t myino_t
+#if defined(__DECC) || defined(__DECCXX)
+# pragma __member_alignment __restore
+#endif
+#if defined(__DECC)
+# pragma __message __restore
+#endif
+/* Cons up a 'delete' bit for testing access */
+#define S_IDUSR (S_IWUSR | S_IXUSR)
+#define S_IDGRP (S_IWGRP | S_IXGRP)
+#define S_IDOTH (S_IWOTH | S_IXOTH)
/* Prototypes for functions unique to vms.c. Don't include replacements
* for routines in the mainline source files excluded by #ifndef VMS;
*/
typedef char __VMS_PROTOTYPES__; /* prototype section start marker */
char * my_getenv _((char *));
-#ifndef HAS_WAITPID /* Not a real waitpid - use only with popen from vms.c! */
unsigned long int waitpid _((unsigned long int, int *, int));
-#endif
char * my_gconvert _((double, int, int, char *));
int do_rmdir _((char *));
int kill_file _((char *));
+int my_utime _((char *, struct utimbuf *));
char * fileify_dirspec _((char *, char *));
char * fileify_dirspec_ts _((char *, char *));
char * pathify_dirspec _((char *, char *));
void closedir _((DIR *));
void vmsreaddirversions _((DIR *, int));
void getredirection _((int *, char ***));
-int flex_fstat _((int, stat_t *));
-int flex_stat _((char *, stat_t *));
+I32 cando_by_name _((I32, I32, char *));
+int flex_fstat _((int, struct stat *));
+int flex_stat _((char *, struct stat *));
int trim_unixpath _((char *, char*));
-struct sv; /* forward declaration for vms_do_aexec and do_aspawn */
- /* real declaration is in sv.h */
-#define bool char /* This must match handy.h */
-bool vms_do_aexec _((struct sv *, struct sv **, struct sv **));
+bool vms_do_aexec _((SV *, SV **, SV **));
bool vms_do_exec _((char *));
-unsigned long int do_aspawn _((struct sv *, struct sv **, struct sv **));
+unsigned long int do_aspawn _((SV *, SV **, SV **));
unsigned long int do_spawn _((char *));
int my_fwrite _((void *, size_t, size_t, FILE *));
+struct passwd * my_getpwnam _((char *name));
+struct passwd * my_getpwuid _((Uid_t uid));
+struct passwd * my_getpwent _(());
+void my_endpwent _(());
+void init_os_extras _(());
typedef char __VMS_SEPYTOTORP__; /* prototype section end marker */
#ifndef VMS_DO_SOCKETS
-/***** The following four #defines are temporary, and should be removed,
- * along with the corresponding routines in vms.c, when TCP/IP support
- * is integrated into the VMS port of perl5. (The temporary hacks are
- * here for now so pack can handle type N elements.)
- * - C. Bailey 26-Aug-1994
- *****/
-unsigned short int tmp_shortflip _((unsigned short int));
-unsigned long int tmp_longflip _((unsigned long int));
-#define htons(us) tmp_shortflip(us)
-#define ntohs(us) tmp_shortflip(us)
-#define htonl(ul) tmp_longflip(ul)
-#define ntohl(ul) tmp_longflip(ul)
+/* This relies on tricks in perl.h to pick up that these manifest constants
+ * are undefined and set up conversion routines. It will then redefine
+ * these manifest constants, so the actual values will match config.h
+ */
+#undef HAS_HTONS
+#undef HAS_NTOHS
+#undef HAS_HTONL
+#undef HAS_NTOHL
#endif
#endif /* __vmsish_h_included */
#!./miniperl
#
# Create perlmain.c from miniperlmain.c, adding code to boot the
-# extensions listed on the command line.
+# extensions listed on the command line. In addition, create a
+# linker options file which causes the bootstrap routines for
+# these extension to be universal symbols in PerlShr.Exe.
+#
+# Last modified 29-Nov-1994 by Charles Bailey bailey@genetics.upenn.edu
#
if (-f 'miniperlmain.c') { $dir = ''; }
}
-if ($#ARGV > -1) {
- print OUT " char *file = __FILE__;\n";
+if (@ARGV) {
+ # Allow for multiple names in one quoted group
+ @exts = split(/\s+/, join(' ',@ARGV));
}
-foreach $ext (@ARGV) {
- print OUT "extern void boot_${ext} _((CV* cv));\n"
-}
-
-foreach $ext (@ARGV) {
- print "Adding $ext . . .\n";
- if ($ext eq 'DynaLoader') {
- # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
- # boot_DynaLoader is called directly in DynaLoader.pm
- print OUT " newXS(\"${ext}::boot_${ext}\", boot_${ext}, file);\n"
+if (@exts) {
+ print OUT " char *file = __FILE__;\n";
+ foreach $ext (@exts) {
+ my($subname) = $ext;
+ $subname =~ s/::/__/g;
+ print OUT "extern void boot_${subname} _((CV* cv));\n"
}
- else {
- print OUT " newXS(\"${ext}::bootstrap\", boot_${ext}, file);\n"
+ foreach $ext (@exts) {
+ my($subname) = $ext;
+ $subname =~ s/::/__/g;
+ print "Adding $ext . . .\n";
+ if ($ext eq 'DynaLoader') {
+ # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
+ # boot_DynaLoader is called directly in DynaLoader.pm
+ print OUT " newXS(\"${ext}::boot_${ext}\", boot_${subname}, file);\n"
+ }
+ else {
+ print OUT " newXS(\"${ext}::bootstrap\", boot_${subname}, file);\n"
+ }
}
}
$(CCCMD) $(LARGE) a2p.c
clean:
- rm -f a2p *.o
+ rm -f a2p *.o
realclean: clean
rm -f *.orig core $(addedbyconf) all malloc.c
echo $(sh) | tr ' ' '\012' >.shlist
malloc.c: ../malloc.c
+ rm -f malloc.c
sed <../malloc.c >malloc.c \
-e 's/"perl.h"/"..\/perl.h"/' \
-e 's/my_exit/exit/'
#ifndef lint
-static char yysccsid[] = "@(#)yaccpar 1.9 (Berkeley) 02/21/93";
+static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91";
#endif
#define YYBYACC 1
-#define YYMAJOR 1
-#define YYMINOR 9
-#define yyclearin (yychar=(-1))
-#define yyerrok (yyerrflag=0)
-#define YYRECOVERING (yyerrflag!=0)
-#define YYPREFIX "yy"
#line 2 "a2p.y"
/* $RCSfile: a2p.y,v $$Revision: 4.1 $$Date: 92/08/07 18:29:12 $
*
int begins = Nullop;
int ends = Nullop;
-#line 30 "y.tab.c"
+#line 24 "y.tab.c"
#define BEGIN 257
#define END 258
#define REGEX 259
#ifndef YYSTYPE
typedef int YYSTYPE;
#endif
+#define yyclearin (yychar=(-1))
+#define yyerrok (yyerrflag=0)
#ifdef YYSTACKSIZE
-#undef YYMAXDEPTH
+#ifndef YYMAXDEPTH
#define YYMAXDEPTH YYSTACKSIZE
+#endif
#else
#ifdef YYMAXDEPTH
#define YYSTACKSIZE YYMAXDEPTH
#define yystacksize YYSTACKSIZE
#line 396 "a2p.y"
#include "a2py.c"
-#line 1948 "y.tab.c"
+#line 1945 "y.tab.c"
#define YYABORT goto yyabort
-#define YYREJECT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
int
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- printf("%sdebug: state %d, reading %d (%s)\n",
- YYPREFIX, yystate, yychar, yys);
+ printf("yydebug: state %d, reading %d (%s)\n", yystate,
+ yychar, yys);
}
#endif
}
{
#if YYDEBUG
if (yydebug)
- printf("%sdebug: state %d, shifting to state %d\n",
- YYPREFIX, yystate, yytable[yyn]);
+ printf("yydebug: state %d, shifting to state %d\n",
+ yystate, yytable[yyn]);
#endif
if (yyssp >= yyss + yystacksize - 1)
{
{
#if YYDEBUG
if (yydebug)
- printf("%sdebug: state %d, error recovery shifting\
- to state %d\n", YYPREFIX, *yyssp, yytable[yyn]);
+ printf("yydebug: state %d, error recovery shifting\
+ to state %d\n", *yyssp, yytable[yyn]);
#endif
if (yyssp >= yyss + yystacksize - 1)
{
{
#if YYDEBUG
if (yydebug)
- printf("%sdebug: error recovery discarding state %d\n",
- YYPREFIX, *yyssp);
+ printf("yydebug: error recovery discarding state %d\n",
+ *yyssp);
#endif
if (yyssp <= yyss) goto yyabort;
--yyssp;
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- printf("%sdebug: state %d, error recovery discards token %d (%s)\n",
- YYPREFIX, yystate, yychar, yys);
+ printf("yydebug: state %d, error recovery discards token %d (%s)\n",
+ yystate, yychar, yys);
}
#endif
yychar = (-1);
yyreduce:
#if YYDEBUG
if (yydebug)
- printf("%sdebug: state %d, reducing by rule %d (%s)\n",
- YYPREFIX, yystate, yyn, yyrule[yyn]);
+ printf("yydebug: state %d, reducing by rule %d (%s)\n",
+ yystate, yyn, yyrule[yyn]);
#endif
yym = yylen[yyn];
yyval = yyvsp[1-yym];
#line 392 "a2p.y"
{ yyval = oper3(OBLOCK,oper2(OJUNK,yyvsp[-3],yyvsp[-2]),Nullop,yyvsp[0]); }
break;
-#line 2615 "y.tab.c"
+#line 2611 "y.tab.c"
}
yyssp -= yym;
yystate = *yyssp;
{
#if YYDEBUG
if (yydebug)
- printf("%sdebug: after reduction, shifting from state 0 to\
- state %d\n", YYPREFIX, YYFINAL);
+ printf("yydebug: after reduction, shifting from state 0 to\
+ state %d\n", YYFINAL);
#endif
yystate = YYFINAL;
*++yyssp = YYFINAL;
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- printf("%sdebug: state %d, reading %d (%s)\n",
- YYPREFIX, YYFINAL, yychar, yys);
+ printf("yydebug: state %d, reading %d (%s)\n",
+ YYFINAL, yychar, yys);
}
#endif
}
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
- printf("%sdebug: after reduction, shifting from state %d \
-to state %d\n", YYPREFIX, *yyssp, yystate);
+ printf("yydebug: after reduction, shifting from state %d \
+to state %d\n", *yyssp, yystate);
#endif
if (yyssp >= yyss + yystacksize - 1)
{
char *myname;
int checkers = 0;
+
+int oper0();
+int oper1();
+int oper2();
+int oper3();
+int oper4();
+int oper5();
STR *walk();
#ifdef OS2
int idtype;
+int
yylex()
{
register char *s = bufptr;
return s;
}
+int
string(ptr,len)
char *ptr;
+int len;
{
int retval = mop;
return retval;
}
+int
oper0(type)
int type;
{
return retval;
}
+int
oper1(type,arg1)
int type;
int arg1;
return retval;
}
+int
oper2(type,arg1,arg2)
int type;
int arg1;
return retval;
}
+int
oper3(type,arg1,arg2,arg3)
int type;
int arg1;
return retval;
}
+int
oper4(type,arg1,arg2,arg3,arg4)
int type;
int arg1;
return retval;
}
+int
oper5(type,arg1,arg2,arg3,arg4,arg5)
int type;
int arg1;
}
}
+int
bl(arg,maybe)
int arg;
int maybe;
fputs(tokenbuf,stdout);
}
+int
numary(arg)
int arg;
{
return arg;
}
+int
rememberargs(arg)
int arg;
{
return arg;
}
+int
aryrefarg(arg)
int arg;
{
return arg;
}
+int
fixfargs(name,arg,prevargs)
int name;
int arg;
return numargs;
}
+int
fixrargs(name,arg,prevargs)
char *name;
int arg;
#include "a2p.h"
#include "util.h"
+static void tab();
+static void fixtab();
+static void addsemi();
+static void emit_split();
+static void numericize();
+
bool exitval = FALSE;
bool realexit = FALSE;
bool saw_getline = FALSE;
return str;
}
-void
+static void
tab(str,lvl)
register STR *str;
register int lvl;
str_cat(str," ");
}
-void
+static void
fixtab(str,lvl)
register STR *str;
register int lvl;
tab(str,lvl);
}
-void
+static void
addsemi(str)
register STR *str;
{
return 1;
}
-void
+static void
numericize(node)
register int node;
{
projects / p5sagit/p5-mst-13.2.git / commitdiff