diff options
| -rw-r--r-- | .dotest/last | 0 | ||||
| -rw-r--r-- | Changes | 1304 | ||||
| -rw-r--r-- | MANIFEST | 16 | ||||
| -rw-r--r-- | MANIFEST.new | 556 | ||||
| -rw-r--r-- | README | 3 | ||||
| -rw-r--r-- | README.vms | 151 | ||||
| -rw-r--r--[-rwxr-xr-x] | Todo | 8 | ||||
| -rw-r--r-- | U/Extensions.U | 186 | ||||
| -rw-r--r-- | U/Extract.U | 74 | ||||
| -rw-r--r-- | U/Guess.U | 159 | ||||
| -rw-r--r-- | U/Loc_sed.U | 26 | ||||
| -rw-r--r-- | U/Myinit.U | 45 | ||||
| -rw-r--r-- | U/README | 9 | ||||
| -rw-r--r-- | U/ccflags.U | 288 | ||||
| -rw-r--r-- | U/d_byacc.U | 26 | ||||
| -rw-r--r-- | U/d_csh.U | 48 | ||||
| -rw-r--r-- | U/d_dlsymun.U | 102 | ||||
| -rw-r--r-- | U/d_group.U | 3 | ||||
| -rw-r--r-- | U/d_passwd.U | 3 | ||||
| -rw-r--r-- | U/dist3_051.pat | 243 | ||||
| -rw-r--r-- | U/dlext.U | 48 | ||||
| -rw-r--r-- | U/dlsrc.U | 259 | ||||
| -rw-r--r-- | U/i_db.U | 132 | ||||
| -rw-r--r-- | U/i_dbm.U | 52 | ||||
| -rw-r--r-- | U/i_gdbm.U | 51 | ||||
| -rw-r--r-- | U/i_ndbm.U | 51 | ||||
| -rw-r--r-- | U/i_sysstat.U | 21 | ||||
| -rw-r--r-- | U/mallocsrc.U | 159 | ||||
| -rw-r--r-- | XSUB.h | 18 | ||||
| -rw-r--r-- | av.c | 4 | ||||
| -rwxr-xr-x | configpm | 31 | ||||
| -rw-r--r-- | cop.h | 4 | ||||
| -rw-r--r-- | cv.h | 3 | ||||
| -rw-r--r-- | doio.c | 73 | ||||
| -rw-r--r-- | doop.c | 12 | ||||
| -rw-r--r-- | dump.c | 2 | ||||
| -rw-r--r-- | embed.h | 13 | ||||
| -rwxr-xr-x | embed_h.sh | 1 | ||||
| -rw-r--r-- | ext/DB_File/DB_File.pm | 4 | ||||
| -rw-r--r-- | ext/DynaLoader/dl_vms.xs | 28 | ||||
| -rw-r--r-- | ext/Fcntl/Fcntl.pm | 4 | ||||
| -rw-r--r-- | ext/GDBM_File/GDBM_File.pm | 4 | ||||
| -rw-r--r-- | ext/GDBM_File/GDBM_File.xs | 2 | ||||
| -rw-r--r-- | ext/NDBM_File/NDBM_File.xs | 2 | ||||
| -rw-r--r-- | ext/ODBM_File/ODBM_File.xs | 2 | ||||
| -rw-r--r-- | ext/POSIX/POSIX.pm | 120 | ||||
| -rw-r--r-- | ext/POSIX/POSIX.xs | 19 | ||||
| -rw-r--r-- | ext/SDBM_File/SDBM_File.xs | 2 | ||||
| -rw-r--r-- | ext/Socket/Socket.pm | 14 | ||||
| -rw-r--r-- | global.sym | 3 | ||||
| -rw-r--r-- | gv.c | 149 | ||||
| -rw-r--r-- | gv.h | 4 | ||||
| -rwxr-xr-x | h2ph.SH | 11 | ||||
| -rwxr-xr-x | h2xs.SH | 10 | ||||
| -rw-r--r-- | hints/powerunix.sh (renamed from hints/PowerUNIX.sh) | 0 | ||||
| -rw-r--r-- | hv.c | 8 | ||||
| -rwxr-xr-x | installperl | 13 | ||||
| -rw-r--r-- | interp.sym | 5 | ||||
| -rw-r--r-- | lib/AutoLoader.pm | 3 | ||||
| -rw-r--r-- | lib/Carp.pm | 21 | ||||
| -rw-r--r-- | lib/Cwd.pm | 17 | ||||
| -rw-r--r-- | lib/English.pm | 206 | ||||
| -rw-r--r-- | lib/Exporter.pm | 123 | ||||
| -rw-r--r-- | lib/ExtUtils/MakeMaker.pm | 16 | ||||
| -rwxr-xr-x | lib/ExtUtils/xsubpp | 27 | ||||
| -rw-r--r-- | lib/File/Basename.pm | 24 | ||||
| -rw-r--r-- | lib/File/CheckTree.pm | 4 | ||||
| -rw-r--r-- | lib/File/Find.pm | 31 | ||||
| -rw-r--r-- | lib/File/Path.pm | 33 | ||||
| -rw-r--r-- | lib/Math/BigInt.pm | 24 | ||||
| -rw-r--r-- | lib/SubstrHash.pm | 140 | ||||
| -rw-r--r-- | lib/Sys/Syslog.pm | 2 | ||||
| -rw-r--r-- | lib/Term/Cap.pm | 251 | ||||
| -rw-r--r-- | lib/TieHash.pm | 16 | ||||
| -rw-r--r-- | lib/assert.pl | 15 | ||||
| -rw-r--r-- | lib/bigrat.pl | 1 | ||||
| -rw-r--r-- | lib/perl5db.pl | 17 | ||||
| -rw-r--r-- | lib/pwd.pl | 1 | ||||
| -rw-r--r-- | mg.c | 158 | ||||
| -rw-r--r-- | mg.h | 3 | ||||
| -rw-r--r-- | miniperlmain.c | 5 | ||||
| -rw-r--r-- | op.c | 491 | ||||
| -rw-r--r-- | op.h | 2 | ||||
| -rw-r--r-- | opcode.h | 15 | ||||
| -rwxr-xr-x | opcode.pl | 19 | ||||
| -rw-r--r-- | patchlevel.h | 2 | ||||
| -rw-r--r-- | perl.c | 126 | ||||
| -rw-r--r-- | perl.h | 108 | ||||
| -rw-r--r-- | perly.c | 290 | ||||
| -rw-r--r-- | perly.c.diff | 20 | ||||
| -rwxr-xr-x | pl2pm | 1 | ||||
| -rw-r--r-- | pod/modpods/AnyDBMFile.pod | 17 | ||||
| -rw-r--r-- | pod/modpods/Basename.pod | 2 | ||||
| -rw-r--r-- | pod/modpods/Benchmark.pod | 2 | ||||
| -rw-r--r-- | pod/modpods/Cwd.pod | 4 | ||||
| -rw-r--r-- | pod/modpods/Dynaloader.pod | 4 | ||||
| -rw-r--r-- | pod/modpods/Exporter.pod | 6 | ||||
| -rw-r--r-- | pod/modpods/Find.pod | 4 | ||||
| -rw-r--r-- | pod/modpods/Finddepth.pod | 8 | ||||
| -rw-r--r-- | pod/modpods/Getopt.pod | 3 | ||||
| -rw-r--r-- | pod/modpods/MakeMaker.pod | 2 | ||||
| -rw-r--r-- | pod/modpods/Open2.pod | 12 | ||||
| -rw-r--r-- | pod/modpods/POSIX.pod | 6 | ||||
| -rw-r--r-- | pod/modpods/Ping.pod | 2 | ||||
| -rw-r--r-- | pod/modpods/less.pod | 2 | ||||
| -rw-r--r-- | pod/modpods/strict.pod | 8 | ||||
| -rw-r--r-- | pod/perl.pod | 2 | ||||
| -rw-r--r-- | pod/perlapi.pod | 2 | ||||
| -rw-r--r-- | pod/perlbook.pod | 4 | ||||
| -rw-r--r-- | pod/perldata.pod | 23 | ||||
| -rw-r--r-- | pod/perldiag.pod | 252 | ||||
| -rw-r--r-- | pod/perlform.pod | 29 | ||||
| -rw-r--r-- | pod/perlfunc.pod | 152 | ||||
| -rw-r--r-- | pod/perlipc.pod | 10 | ||||
| -rw-r--r-- | pod/perlmod.pod | 30 | ||||
| -rw-r--r-- | pod/perlobj.pod | 24 | ||||
| -rw-r--r-- | pod/perlop.pod | 29 | ||||
| -rw-r--r-- | pod/perlovl.pod | 16 | ||||
| -rw-r--r-- | pod/perlre.pod | 12 | ||||
| -rw-r--r-- | pod/perlref.pod | 125 | ||||
| -rw-r--r-- | pod/perlrun.pod | 7 | ||||
| -rw-r--r-- | pod/perlsec.pod | 2 | ||||
| -rw-r--r-- | pod/perlsub.pod | 19 | ||||
| -rw-r--r-- | pod/perlsyn.pod | 20 | ||||
| -rw-r--r-- | pod/perltrap.pod | 21 | ||||
| -rw-r--r-- | pod/perlvar.pod | 27 | ||||
| -rwxr-xr-x[-rw-r--r--] | pod/pod2html | 600 | ||||
| -rwxr-xr-x | pod/pod2latex | 632 | ||||
| -rwxr-xr-x | pod/pod2man | 38 | ||||
| -rw-r--r-- | pp.c | 224 | ||||
| -rw-r--r-- | pp.h | 2 | ||||
| -rw-r--r-- | pp_ctl.c | 168 | ||||
| -rw-r--r-- | pp_hot.c | 166 | ||||
| -rw-r--r-- | pp_sys.c | 259 | ||||
| -rw-r--r-- | proto.h | 15 | ||||
| -rw-r--r-- | regcomp.c | 28 | ||||
| -rw-r--r-- | regexec.c | 6 | ||||
| -rw-r--r-- | scope.c | 49 | ||||
| -rw-r--r-- | sv.c | 155 | ||||
| -rw-r--r-- | sv.h | 9 | ||||
| -rwxr-xr-x | t/TEST | 2 | ||||
| -rwxr-xr-x | t/lib/bigintpm.t | 310 | ||||
| -rwxr-xr-x | t/lib/posix.t | 2 | ||||
| -rwxr-xr-x | t/op/overload.t | 259 | ||||
| -rwxr-xr-x | t/op/rand.t | 57 | ||||
| -rwxr-xr-x | t/op/ref.t | 2 | ||||
| -rwxr-xr-x | t/op/write.t | 4 | ||||
| -rw-r--r-- | t/re_tests | 271 | ||||
| -rw-r--r-- | taint.c | 12 | ||||
| -rw-r--r-- | toke.c | 435 | ||||
| -rw-r--r-- | util.c | 124 | ||||
| -rw-r--r-- | vms/Makefile (renamed from vms/makefile.) | 395 | ||||
| -rw-r--r-- | vms/config.vms | 31 | ||||
| -rw-r--r-- | vms/descrip.mms | 435 | ||||
| -rw-r--r-- | vms/ext/Filespec.pm | 323 | ||||
| -rw-r--r-- | vms/ext/MM_VMS.pm | 812 | ||||
| -rw-r--r-- | vms/ext/VMS/stdio/Makefile.PL | 3 | ||||
| -rw-r--r-- | vms/ext/VMS/stdio/stdio.pm | 78 | ||||
| -rw-r--r-- | vms/ext/VMS/stdio/stdio.xs | 109 | ||||
| -rw-r--r-- | vms/gen_shrfls.pl | 90 | ||||
| -rw-r--r-- | vms/genconfig.pl | 66 | ||||
| -rw-r--r-- | vms/mms2make.pl | 18 | ||||
| -rw-r--r-- | vms/perlvms.pod | 373 | ||||
| -rw-r--r-- | vms/sockadapt.c | 15 | ||||
| -rw-r--r-- | vms/sockadapt.h | 65 | ||||
| -rw-r--r-- | vms/test.com | 9 | ||||
| -rw-r--r-- | vms/vms.c | 1732 | ||||
| -rw-r--r-- | vms/vmsish.h | 158 | ||||
| -rw-r--r-- | vms/writemain.pl | 41 | ||||
| -rwxr-xr-x | x2p/Makefile.SH | 3 | ||||
| -rw-r--r-- | x2p/a2p.c | 56 | ||||
| -rw-r--r-- | x2p/a2py.c | 22 | ||||
| -rw-r--r-- | x2p/walk.c | 14 |
173 files changed, 10547 insertions, 5818 deletions
diff --git a/.dotest/last b/.dotest/last deleted file mode 100644 index e69de29bb2..0000000000 --- a/.dotest/last +++ /dev/null @@ -1,3 +1,1307 @@ +------------- +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. @@ -175,7 +175,6 @@ 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 @@ -210,6 +209,7 @@ 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/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 @@ -273,6 +273,7 @@ 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/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 @@ -402,6 +403,7 @@ pod/perlsyn.pod Syntax info 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 @@ -448,6 +450,7 @@ 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/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 @@ -485,6 +488,7 @@ 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/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 @@ -516,13 +520,17 @@ toke.c The tokener 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 @@ -536,7 +544,7 @@ 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.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 diff --git a/MANIFEST.new b/MANIFEST.new deleted file mode 100644 index 9df21550a1..0000000000 --- a/MANIFEST.new +++ /dev/null @@ -1,556 +0,0 @@ -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 @@ -1,4 +1,3 @@ -[This is an unsupported, pre-release version of Perl 5.0.] Perl Kit, Version 5.0 @@ -30,7 +29,7 @@ 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 diff --git a/README.vms b/README.vms index dbf6251311..960d98fefe 100644 --- a/README.vms +++ b/README.vms @@ -1,21 +1,31 @@ -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 @@ -29,20 +39,20 @@ on your system. See the topic "Socket support" for more information. * 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 @@ -52,72 +62,75 @@ changes: 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. @@ -129,52 +142,60 @@ the macro DECC_PIPES_BROKEN when you invoke MMS or MMK. 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. @@ -182,13 +203,13 @@ 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). @@ -200,7 +221,7 @@ operation at the moment). And, as always, we welcome any help or code you'd 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. @@ -208,8 +229,10 @@ 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> @@ -217,7 +240,7 @@ missed someone. That said, special thanks are due to the following: 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. @@ -1,7 +1,3 @@ -Modules needed - X/Motif/Tk etc. - Curses - Tie Modules VecArray Implement array using vec() SubstrArray Implement array using substr() @@ -24,12 +20,12 @@ Would be nice to have -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 @@ -57,7 +53,6 @@ Vague possibilities 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 @@ -71,5 +66,4 @@ Vague possibilities autocroak? Modifiable $1 et al substr EXPR,OFFSET,LENGTH,STRING - locally capture warnings into an array diff --git a/U/Extensions.U b/U/Extensions.U deleted file mode 100644 index 2cba199929..0000000000 --- a/U/Extensions.U +++ /dev/null @@ -1,186 +0,0 @@ -?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="$*" - diff --git a/U/Extract.U b/U/Extract.U deleted file mode 100644 index 606aaa3e68..0000000000 --- a/U/Extract.U +++ /dev/null @@ -1,74 +0,0 @@ -?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 - diff --git a/U/Guess.U b/U/Guess.U deleted file mode 100644 index cb6354ae3d..0000000000 --- a/U/Guess.U +++ /dev/null @@ -1,159 +0,0 @@ -?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 - diff --git a/U/Loc_sed.U b/U/Loc_sed.U deleted file mode 100644 index 88cec902dc..0000000000 --- a/U/Loc_sed.U +++ /dev/null @@ -1,26 +0,0 @@ -?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 - diff --git a/U/Myinit.U b/U/Myinit.U deleted file mode 100644 index 2f69835dbe..0000000000 --- a/U/Myinit.U +++ /dev/null @@ -1,45 +0,0 @@ -?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 - diff --git a/U/README b/U/README deleted file mode 100644 index 579c0ade1c..0000000000 --- a/U/README +++ /dev/null @@ -1,9 +0,0 @@ -?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 diff --git a/U/ccflags.U b/U/ccflags.U deleted file mode 100644 index c935281c3d..0000000000 --- a/U/ccflags.U +++ /dev/null @@ -1,288 +0,0 @@ -?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 diff --git a/U/d_byacc.U b/U/d_byacc.U deleted file mode 100644 index a4498c85dd..0000000000 --- a/U/d_byacc.U +++ /dev/null @@ -1,26 +0,0 @@ -?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 - diff --git a/U/d_csh.U b/U/d_csh.U deleted file mode 100644 index eb737b80b2..0000000000 --- a/U/d_csh.U +++ /dev/null @@ -1,48 +0,0 @@ -?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 - diff --git a/U/d_dlsymun.U b/U/d_dlsymun.U deleted file mode 100644 index 7831c4ac48..0000000000 --- a/U/d_dlsymun.U +++ /dev/null @@ -1,102 +0,0 @@ -?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 - diff --git a/U/d_group.U b/U/d_group.U deleted file mode 100644 index 52a48eac0c..0000000000 --- a/U/d_group.U +++ /dev/null @@ -1,3 +0,0 @@ -?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 $ diff --git a/U/d_passwd.U b/U/d_passwd.U deleted file mode 100644 index 7bb5b3091d..0000000000 --- a/U/d_passwd.U +++ /dev/null @@ -1,3 +0,0 @@ -?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 $ diff --git a/U/dist3_051.pat b/U/dist3_051.pat deleted file mode 100644 index c1c877db7c..0000000000 --- a/U/dist3_051.pat +++ /dev/null @@ -1,243 +0,0 @@ -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 - '') ;; diff --git a/U/dlext.U b/U/dlext.U deleted file mode 100644 index 8483197a3b..0000000000 --- a/U/dlext.U +++ /dev/null @@ -1,48 +0,0 @@ -?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 - diff --git a/U/dlsrc.U b/U/dlsrc.U deleted file mode 100644 index 64317cfbb7..0000000000 --- a/U/dlsrc.U +++ /dev/null @@ -1,259 +0,0 @@ -?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 - diff --git a/U/i_db.U b/U/i_db.U deleted file mode 100644 index 5c961e0d8d..0000000000 --- a/U/i_db.U +++ /dev/null @@ -1,132 +0,0 @@ -?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 - diff --git a/U/i_dbm.U b/U/i_dbm.U deleted file mode 100644 index 99bd346276..0000000000 --- a/U/i_dbm.U +++ /dev/null @@ -1,52 +0,0 @@ -?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 - diff --git a/U/i_gdbm.U b/U/i_gdbm.U deleted file mode 100644 index d9ca1bc16d..0000000000 --- a/U/i_gdbm.U +++ /dev/null @@ -1,51 +0,0 @@ -?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 - diff --git a/U/i_ndbm.U b/U/i_ndbm.U deleted file mode 100644 index 62bcb7c38b..0000000000 --- a/U/i_ndbm.U +++ /dev/null @@ -1,51 +0,0 @@ -?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 - diff --git a/U/i_sysstat.U b/U/i_sysstat.U deleted file mode 100644 index e607898ed8..0000000000 --- a/U/i_sysstat.U +++ /dev/null @@ -1,21 +0,0 @@ -?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 - diff --git a/U/mallocsrc.U b/U/mallocsrc.U deleted file mode 100644 index 6762f9090c..0000000000 --- a/U/mallocsrc.U +++ /dev/null @@ -1,159 +0,0 @@ -?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 @@ -17,6 +17,18 @@ #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) @@ -305,6 +305,10 @@ register AV *av; AvALLOC(av) = 0; SvPVX(av) = 0; AvMAX(av) = AvFILL(av) = -1; + if (AvARYLEN(av)) { + SvREFCNT_dec(AvARYLEN(av)); + AvARYLEN(av) = 0; + } } void @@ -95,6 +95,37 @@ sub EXISTS{ 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 } @@ -64,13 +64,15 @@ struct block_eval { 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; \ @@ -25,8 +25,10 @@ struct xpvcv { 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 @@ -37,5 +39,6 @@ struct xpvcv { #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 @@ -43,12 +43,6 @@ #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; @@ -153,7 +147,7 @@ FILE *supplied_fp; thatio = GvIO(gv); if (!thatio) { #ifdef EINVAL - errno = EINVAL; + SETERRNO(EINVAL,SS$_IVCHAN); #endif goto say_false; } @@ -412,7 +406,7 @@ register GV *gv; 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) ); @@ -513,7 +507,7 @@ do_close(GV *gv, bool explicit) if (!gv) gv = argvgv; if (!gv || SvTYPE(gv) != SVt_PVGV) { - errno = EBADF; + SETERRNO(EBADF,SS$_IVCHAN); return FALSE; } io = GvIO(gv); @@ -526,7 +520,7 @@ do_close(GV *gv, bool explicit) 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; @@ -610,7 +604,7 @@ GV *gv; phooey: if (dowarn) warn("tell() on unopened file"); - errno = EBADF; + SETERRNO(EBADF,RMS$_IFI); return -1L; } @@ -639,7 +633,7 @@ int whence; nuts: if (dowarn) warn("seek() on unopened file"); - errno = EBADF; + SETERRNO(EBADF,RMS$_IFI); return FALSE; } @@ -797,30 +791,42 @@ dARGS { 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; @@ -915,6 +921,9 @@ char *cmd; register char *s; char flags[10]; + while (*cmd && isSPACE(*cmd)) + cmd++; + /* save an extra exec if possible */ #ifdef CSH @@ -946,10 +955,16 @@ char *cmd; /* 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]) { @@ -961,6 +976,7 @@ char *cmd; return FALSE; } } + New(402,Argv, (s - cmd) / 2 + 2, char*); Cmd = savepvn(cmd, s-cmd); a = Argv; @@ -1000,7 +1016,8 @@ register SV **sp; 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; @@ -1091,7 +1108,7 @@ register SV **sp; case OP_UTIME: TAINT_PROPER("utime"); if (sp - mark > 2) { -#ifdef I_UTIME +#if defined(I_UTIME) || defined(VMS) struct utimbuf utbuf; #else struct { @@ -1212,7 +1229,7 @@ SV **sp; 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 @@ -1310,7 +1327,7 @@ SV **sp; I32 i = SvIV(astr); a = (char *)i; /* ouch */ } - errno = 0; + SETERRNO(0,0); switch (optype) { #ifdef HAS_MSG @@ -1354,7 +1371,7 @@ SV **sp; 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"); @@ -1387,7 +1404,7 @@ SV **sp; 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); @@ -1415,10 +1432,10 @@ SV **sp; 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"); @@ -1442,11 +1459,11 @@ SV **sp; 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); @@ -203,6 +203,9 @@ register SV **sarg; 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 ' ': @@ -417,7 +420,7 @@ register SV *sv; return; } s = SvPV(sv, len); - if (len && !SvPOKp(sv)) + if (len && !SvPOK(sv)) s = SvPV_force(sv, len); if (s && len) { s += --len; @@ -527,6 +530,7 @@ SV *right; (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 && @@ -619,6 +623,9 @@ dARGS if (!hv) RETURN; + + (void)hv_iterinit(hv); /* always reset iterator regardless */ + if (GIMME != G_ARRAY) { dTARGET; @@ -626,7 +633,6 @@ dARGS i = HvKEYS(hv); else { i = 0; - (void)hv_iterinit(hv); /*SUPPRESS 560*/ while (entry = hv_iternext(hv)) { i++; @@ -639,8 +645,6 @@ dARGS /* 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; @@ -126,7 +126,7 @@ register OP *op; 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) { @@ -29,6 +29,7 @@ #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 @@ -38,6 +39,7 @@ #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 @@ -395,6 +397,7 @@ #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 @@ -1021,6 +1024,7 @@ #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) @@ -1056,6 +1060,7 @@ #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) @@ -1088,8 +1093,10 @@ #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) @@ -1133,6 +1140,7 @@ #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... */ @@ -1172,6 +1180,7 @@ #define Idefoutgv defoutgv #define Idefstash defstash #define Idelaymagic delaymagic +#define Idiehook diehook #define Idirty dirty #define Idlevel dlevel #define Idlmax dlmax @@ -1207,6 +1216,7 @@ #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 @@ -1239,8 +1249,10 @@ #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 @@ -1284,5 +1296,6 @@ #define Itop_env top_env #define Itoptarget toptarget #define Iunsafe unsafe +#define Iwarnhook warnhook #endif /* MULTIPLICITY */ diff --git a/embed_h.sh b/embed_h.sh index 159ab0ed81..e098c1ed82 100755 --- a/embed_h.sh +++ b/embed_h.sh @@ -1,5 +1,6 @@ #!/bin/sh +rm -f embed.h cat <<'END' >embed.h /* This file is derived from global.sym and interp.sym */ diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index 4cff8da4a9..1a75f155b4 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -213,10 +213,6 @@ require DynaLoader; ); sub AUTOLOAD { - if (@_ > 1) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } local($constname); ($constname = $AUTOLOAD) =~ s/.*:://; $val = constant($constname, @_ ? $_[0] : 0); diff --git a/ext/DynaLoader/dl_vms.xs b/ext/DynaLoader/dl_vms.xs index 8486ae260c..c6e58fb33c 100644 --- a/ext/DynaLoader/dl_vms.xs +++ b/ext/DynaLoader/dl_vms.xs @@ -2,7 +2,7 @@ * * 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 @@ -60,6 +60,7 @@ #include <lib$routines.h> #include <rms.h> #include <ssdef.h> +#include <starlet.h> typedef unsigned long int vmssts; @@ -82,7 +83,7 @@ copy_errmsg(msg,unused) 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); @@ -105,12 +106,11 @@ dl_set_error(sts,stv) 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 @@ -131,7 +131,7 @@ MODULE = DynaLoader PACKAGE = DynaLoader BOOT: (void)dl_private_init(); -SV * +void dl_expandspec(filespec) char * filespec CODE: @@ -155,14 +155,14 @@ dl_expandspec(filespec) } 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; @@ -190,7 +190,7 @@ dl_expandspec(filespec) } } -void * +void dl_load_file(filespec) char * filespec CODE: @@ -205,7 +205,7 @@ dl_load_file(filespec) 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; @@ -215,7 +215,7 @@ dl_load_file(filespec) 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); @@ -266,11 +266,11 @@ dl_load_file(filespec) 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 @@ -293,7 +293,7 @@ dl_find_symbol(librefptr,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 diff --git a/ext/Fcntl/Fcntl.pm b/ext/Fcntl/Fcntl.pm index b18d1365e5..d3f73c4cd7 100644 --- a/ext/Fcntl/Fcntl.pm +++ b/ext/Fcntl/Fcntl.pm @@ -20,10 +20,6 @@ require DynaLoader; ); sub AUTOLOAD { - if (@_ > 1) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } local($constname); ($constname = $AUTOLOAD) =~ s/.*:://; $val = constant($constname, @_ ? $_[0] : 0); diff --git a/ext/GDBM_File/GDBM_File.pm b/ext/GDBM_File/GDBM_File.pm index cf260b51fa..646d7490ec 100644 --- a/ext/GDBM_File/GDBM_File.pm +++ b/ext/GDBM_File/GDBM_File.pm @@ -18,10 +18,6 @@ require DynaLoader; ); sub AUTOLOAD { - if (@_ > 1) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } local($constname); ($constname = $AUTOLOAD) =~ s/.*:://; $val = constant($constname, @_ ? $_[0] : 0); diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs index c6dc484fa1..8c7276dd2f 100644 --- a/ext/GDBM_File/GDBM_File.xs +++ b/ext/GDBM_File/GDBM_File.xs @@ -193,7 +193,7 @@ gdbm_STORE(db, key, value, flags = GDBM_REPLACE) 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); */ } diff --git a/ext/NDBM_File/NDBM_File.xs b/ext/NDBM_File/NDBM_File.xs index 52c08ebe76..d129a9c490 100644 --- a/ext/NDBM_File/NDBM_File.xs +++ b/ext/NDBM_File/NDBM_File.xs @@ -41,7 +41,7 @@ dbm_STORE(db, key, value, flags = DBM_REPLACE) 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); } diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs index 15737a0de8..2272474dcc 100644 --- a/ext/ODBM_File/ODBM_File.xs +++ b/ext/ODBM_File/ODBM_File.xs @@ -75,7 +75,7 @@ odbm_STORE(db, key, value, flags = DBM_REPLACE) 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); } diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm index 24e09fc3eb..b343200971 100644 --- a/ext/POSIX/POSIX.pm +++ b/ext/POSIX/POSIX.pm @@ -7,20 +7,22 @@ require DynaLoader; 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 @@ -28,9 +30,9 @@ $H{fcntl_h} = [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK 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 @@ -39,11 +41,11 @@ $H{float_h} = [qw(DBL_DIG DBL_EPSILON DBL_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 @@ -52,30 +54,30 @@ $H{limits_h} = [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX _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 @@ -83,33 +85,33 @@ $H{stdio_h} = [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid 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 @@ -119,12 +121,12 @@ $H{termios_h} = [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400 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 @@ -138,28 +140,13 @@ $H{unistd_h} = [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET 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 @@ -179,9 +166,10 @@ sub expand { 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); } @@ -237,7 +225,7 @@ sub gensym { sub ungensym { local($x) = shift; $x =~ s/.*:://; - delete $::_POSIX{$x}; + delete $POSIX::{$x}; } ############################ @@ -257,7 +245,7 @@ sub new { $mode =~ s/a.*/>>/ || $mode =~ s/w.*/>/ || ($mode = '<'); - open($glob, "$mode $filename"); + open($glob, "$mode $filename") and bless \$glob; } @@ -268,7 +256,7 @@ sub new_from_fd { $mode =~ s/a.*/>>/ || $mode =~ s/w.*/>/ || ($mode = '<'); - open($glob, "$mode&=$fd"); + open($glob, "$mode&=$fd") and bless \$glob; } @@ -280,6 +268,10 @@ sub clearerr { sub close { POSIX::usage "close(filehandle)" if @_ != 1; close($_[0]); +} + +sub DESTROY { + close($_[0]); ungensym($_[0]); } diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index fbd21c894b..5c2fe2400e 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -2412,7 +2412,8 @@ ungetc(handle, c) RETVAL OutputStream -new_tmpfile() +new_tmpfile(packname = "FileHandle") + char * packname CODE: RETVAL = tmpfile(); OUTPUT: @@ -2582,6 +2583,13 @@ open(filename, flags = O_RDONLY, mode = 0666) 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() @@ -2972,7 +2980,7 @@ strxfrm(src) 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++; @@ -2988,6 +2996,11 @@ SysRet mkfifo(filename, mode) char * filename Mode_t mode + CODE: + TAINT_PROPER("mkfifo"); + RETVAL = mkfifo(filename, mode); + OUTPUT: + RETVAL SysRet tcdrain(fd) @@ -3043,7 +3056,7 @@ clock() char * ctime(time) - Time_t * time + Time_t &time double difftime(time1, time2) diff --git a/ext/SDBM_File/SDBM_File.xs b/ext/SDBM_File/SDBM_File.xs index 97f9c1f9f4..38eaebf5c5 100644 --- a/ext/SDBM_File/SDBM_File.xs +++ b/ext/SDBM_File/SDBM_File.xs @@ -42,7 +42,7 @@ sdbm_STORE(db, key, value, flags = DBM_REPLACE) 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); } diff --git a/ext/Socket/Socket.pm b/ext/Socket/Socket.pm index 8e6e097c0c..6c63fb5fe3 100644 --- a/ext/Socket/Socket.pm +++ b/ext/Socket/Socket.pm @@ -86,10 +86,6 @@ require DynaLoader; ); sub AUTOLOAD { - if (@_ > 1) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } local($constname); ($constname = $AUTOLOAD) =~ s/.*:://; $val = constant($constname, @_ ? $_[0] : 0); @@ -107,6 +103,16 @@ sub AUTOLOAD { 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 diff --git a/global.sym b/global.sym index 54217de072..880829c2db 100644 --- a/global.sym +++ b/global.sym @@ -26,6 +26,7 @@ check coeff compiling compl_amg +compcv comppad comppad_name comppad_name_fill @@ -35,6 +36,7 @@ cop_seqmax cos_amg cryptseen cryptswitch_add +cryptswitch_fp cshlen cshname curcop @@ -395,6 +397,7 @@ hv_stashpv hv_iterinit hv_iterkey hv_iternext +hv_iternextsv hv_iterval hv_magic hv_store @@ -129,6 +129,7 @@ I32 level; GV* gv; GV** gvp; HV* lastchance; + CV* cv; if (!stash) return 0; @@ -142,10 +143,21 @@ I32 level; 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))) { @@ -162,6 +174,11 @@ I32 level; } 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; @@ -172,6 +189,11 @@ I32 level; 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; @@ -215,8 +237,7 @@ char* name; 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); @@ -350,8 +371,11 @@ I32 sv_type; 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; } } @@ -508,13 +532,14 @@ I32 sv_type; 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; @@ -579,10 +604,14 @@ SV *sv; 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); @@ -673,8 +702,11 @@ GV* gv; 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); @@ -685,6 +717,8 @@ GV* gv; } if ((cv = gp->gp_cv) && !GvCVGEN(gv)) SvREFCNT_dec(cv); + SvREFCNT_dec(gp->gp_form); + Safefree(gp); GvGP(gv) = 0; } @@ -725,12 +759,20 @@ HV* stash; 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)) ); @@ -771,7 +813,7 @@ HV* 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; } @@ -793,13 +835,13 @@ HV* stash; } 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) { @@ -828,17 +870,15 @@ int flags; 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) { @@ -847,13 +887,13 @@ int flags; /* 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; } @@ -867,24 +907,40 @@ int flags; 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 { @@ -909,7 +965,8 @@ int flags; && (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 @@ -948,7 +1005,8 @@ int flags; 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 ": @@ -972,15 +1030,25 @@ int flags; } } 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; @@ -1047,6 +1115,11 @@ int flags; 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; } @@ -70,10 +70,10 @@ HV *GvHVn(); #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*) @@ -43,6 +43,7 @@ chdir '/usr/include' || die "Can't cd /usr/include"; END @isatype{@isatype} = (1) x @isatype; +$inif = 0; @ARGV = ('-') unless @ARGV; @@ -136,14 +137,18 @@ foreach $file (@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"; @@ -221,7 +226,11 @@ sub expr { } } else { - $new .= ' &' . $id; + if ($inif && $new !~ /defined\($/) { + $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)'; + } else { + $new .= ' &' . $id; + } } next; }; @@ -250,10 +250,6 @@ print PM<<"END"; \@EXPORT = qw( @const_names ); -# Other items we are prepared to export if requested -\@EXPORT_OK = qw( -); - END print PM <<"END" unless $opt_c; @@ -262,12 +258,6 @@ sub AUTOLOAD { # 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); diff --git a/hints/PowerUNIX.sh b/hints/powerunix.sh index f21e6ae8b8..f21e6ae8b8 100644 --- a/hints/PowerUNIX.sh +++ b/hints/powerunix.sh @@ -162,10 +162,11 @@ register U32 hash; } 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; @@ -207,7 +208,10 @@ U32 klen; *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 diff --git a/installperl b/installperl index ed8912ca26..da6f739d05 100755 --- a/installperl +++ b/installperl @@ -28,9 +28,12 @@ while (<CONFIG>) { } 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. @@ -321,8 +324,12 @@ sub installlib { } # 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"); diff --git a/interp.sym b/interp.sym index ef880908ca..8747e0490f 100644 --- a/interp.sym +++ b/interp.sym @@ -34,6 +34,7 @@ defgv defoutgv defstash delaymagic +diehook dirty dlevel dlmax @@ -69,6 +70,7 @@ laststype leftgv lineary localizing +main_cv main_root main_start mainstack @@ -101,8 +103,10 @@ ors orslen pad padname +parsehook patchlevel perldb +perl_destruct_level pidstatus preambled preprocess @@ -146,3 +150,4 @@ tmps_stack top_env toptarget unsafe +warnhook diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm index 3f5eef2375..92109a3681 100644 --- a/lib/AutoLoader.pm +++ b/lib/AutoLoader.pm @@ -14,6 +14,9 @@ AUTOLOAD { 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 $@; diff --git a/lib/Carp.pm b/lib/Carp.pm index 5daba5c289..c847b77b36 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -3,6 +3,8 @@ package Carp; # 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); @@ -10,7 +12,7 @@ require Exporter; 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"; @@ -20,18 +22,27 @@ sub longmess { $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; diff --git a/lib/Cwd.pm b/lib/Cwd.pm index b27e088847..20b175c81d 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -1,18 +1,30 @@ 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('.')) @@ -79,6 +91,8 @@ sub getcwd # 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); @@ -143,8 +157,11 @@ sub chdir_init{ 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{ diff --git a/lib/English.pm b/lib/English.pm index b203721a52..d40d28af7d 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -3,59 +3,65 @@ package English; 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. @@ -64,79 +70,79 @@ local($^W) = 0; # 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; diff --git a/lib/Exporter.pm b/lib/Exporter.pm index dce6909b18..add5657fac 100644 --- a/lib/Exporter.pm +++ b/lib/Exporter.pm @@ -1,29 +1,109 @@ 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; @@ -35,23 +115,32 @@ sub export { 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; diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index f619108341..e09b438e75 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -304,7 +304,10 @@ sub check_hints { $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: @@ -672,8 +675,8 @@ Exporter::import('ExtUtils::MakeMaker', @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'; } @@ -752,7 +755,8 @@ sub init_main { } $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 @@ -981,7 +985,7 @@ sub find_perl{ 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"; } @@ -1986,7 +1990,7 @@ sub extliblist{ 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")){ diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index bc0852303f..21bbc4edee 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -68,6 +68,8 @@ SWITCH: while ($ARGV[0] =~ s/^-//) { } @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]); @@ -77,7 +79,9 @@ $typemap = shift @ARGV; 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; @@ -321,11 +325,17 @@ EOF $_ = 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; @@ -523,7 +533,7 @@ sub generate_init { 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$//; @@ -563,7 +573,7 @@ sub generate_output { 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; @@ -613,4 +623,7 @@ sub map_type { } } -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; diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 9e2e25e889..5e09ae4977 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -4,7 +4,7 @@ require 5.000; 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 @@ -13,7 +13,9 @@ require Exporter; # 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 @@ -46,7 +48,7 @@ sub fileparse_set_fstype { # ($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','\..*'); @@ -66,7 +68,7 @@ sub fileparse { 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) { @@ -76,7 +78,7 @@ sub fileparse { 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; } @@ -90,7 +92,7 @@ sub fileparse { } } - ($basename,$dirpath,$tail); + wantarray ? ($basename,$dirpath,$tail) : $basename; } @@ -98,13 +100,15 @@ sub fileparse { # 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. @@ -113,14 +117,14 @@ sub dirname { 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 { diff --git a/lib/File/CheckTree.pm b/lib/File/CheckTree.pm index d3dfa70084..a440bda71e 100644 --- a/lib/File/CheckTree.pm +++ b/lib/File/CheckTree.pm @@ -98,11 +98,11 @@ sub valmess { $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; diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 612f14525a..c7b0051ce2 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -1,9 +1,12 @@ 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; @@ -38,7 +41,7 @@ require Exporter; 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); @@ -48,6 +51,7 @@ sub find { $name = $topdir; &$wanted; ($fixtopdir = $topdir) =~ s,/$,, ; + $fixtopdir =~ s/\.dir$// if $Is_VMS; ; &finddir($wanted,$fixtopdir,$topnlink); } else { @@ -55,7 +59,7 @@ sub find { } } else { - unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) { + unless (($dir,$_) = fileparse($topdir)) { ($dir,$_) = ('.', $topdir); } $name = $topdir; @@ -97,13 +101,15 @@ sub finddir { # 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 '..'; } @@ -145,13 +151,14 @@ sub finddir { 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; @@ -162,7 +169,7 @@ sub finddepth { } } else { - unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) { + unless (($dir,$_) = fileparse($topdir)) { ($dir,$_) = ('.', $topdir); } chdir $dir && &$wanted; @@ -182,7 +189,7 @@ sub finddepthdir { 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 '..'; @@ -198,17 +205,18 @@ sub finddepthdir { 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 '..'; } @@ -220,5 +228,10 @@ sub finddepthdir { } } +if ($Config{'osname'} eq 'VMS') { + $Is_VMS = 1; + $dont_use_nlink = 1; +} + 1; diff --git a/lib/File/Path.pm b/lib/File/Path.pm index 30f550d7f4..ec117b8de9 100644 --- a/lib/File/Path.pm +++ b/lib/File/Path.pm @@ -58,17 +58,19 @@ Unix file specification syntax. =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 @@ -81,7 +83,7 @@ Charles Bailey <bailey@genetics.upenn.edu> =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 @@ -92,6 +94,8 @@ require Exporter; @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 @@ -102,7 +106,7 @@ sub mkpath{ $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, $_); @@ -124,15 +128,24 @@ sub rmtree { $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: $!"; } diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm index 3e0fc17ff6..8c0ca4e6d4 100644 --- a/lib/Math/BigInt.pm +++ b/lib/Math/BigInt.pm @@ -2,32 +2,34 @@ package Math::BigInt; %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]}" } diff --git a/lib/SubstrHash.pm b/lib/SubstrHash.pm new file mode 100644 index 0000000000..6250e73848 --- /dev/null +++ b/lib/SubstrHash.pm @@ -0,0 +1,140 @@ +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; diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm index 0f7859e226..0a0d25eb9b 100644 --- a/lib/Sys/Syslog.pm +++ b/lib/Sys/Syslog.pm @@ -139,7 +139,7 @@ sub xlate { local($name) = @_; $name =~ y/a-z/A-Z/; $name = "LOG_$name" unless $name =~ /^LOG_/; - $name = "syslog'$name"; + $name = "Sys::Syslog::$name"; eval(&$name) || -1; } diff --git a/lib/Term/Cap.pm b/lib/Term/Cap.pm index e1476a3411..061ca704b7 100644 --- a/lib/Term/Cap.pm +++ b/lib/Term/Cap.pm @@ -1,74 +1,138 @@ +# 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; @@ -82,40 +146,77 @@ sub Tgetent { 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; @@ -127,10 +228,10 @@ sub Tgoto { $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); @@ -168,7 +269,19 @@ sub Tgoto { 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; diff --git a/lib/TieHash.pm b/lib/TieHash.pm index 0cb4afa20d..2d5c2f41f0 100644 --- a/lib/TieHash.pm +++ b/lib/TieHash.pm @@ -39,4 +39,20 @@ sub CLEAR { } } +# 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; diff --git a/lib/assert.pl b/lib/assert.pl index 0661d70af5..4c9ebf20a0 100644 --- a/lib/assert.pl +++ b/lib/assert.pl @@ -16,6 +16,8 @@ sub assert { } sub panic { + package DB; + select(STDERR); print "\npanic: @_\n"; @@ -24,10 +26,11 @@ sub panic { # 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",$_); @@ -41,10 +44,10 @@ sub panic { } $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; } diff --git a/lib/bigrat.pl b/lib/bigrat.pl index 5bd127a9ae..fb436ce570 100644 --- a/lib/bigrat.pl +++ b/lib/bigrat.pl @@ -55,6 +55,7 @@ sub norm { #(bint, bint) return rat_num 'NaN'; } else { local($gcd) = &'bgcd($num,$dom); + $gcd =~ s/^-/+/; if ($gcd ne '+1') { $num = &'bdiv($num,$gcd); $dom = &'bdiv($dom,$gcd); diff --git a/lib/perl5db.pl b/lib/perl5db.pl index ac03c098fe..358b548a3c 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -50,11 +50,13 @@ print OUT ("Emacs support ", ".\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})) { @@ -70,7 +72,7 @@ sub DB { 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]; @@ -167,9 +169,9 @@ command Execute as a perl statement in current package. 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; @@ -288,7 +290,7 @@ command Execute as a perl statement in current package. $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 "::"; @@ -492,7 +494,8 @@ command Execute as a perl statement in current package. $evalarg = $post; &eval; } } - ($@, $!, $,, $/, $\) = @saved; + ($@, $!, $,, $/, $\, $^W) = @saved; + (); } sub save { diff --git a/lib/pwd.pl b/lib/pwd.pl index 0cc3d4e96e..beb591679e 100644 --- a/lib/pwd.pl +++ b/lib/pwd.pl @@ -34,6 +34,7 @@ sub main'initpwd { sub main'chdir { local($newdir) = shift; + $newdir =~ s|/{2,}|/|g; if (chdir $newdir) { if ($newdir =~ m#^/#) { $ENV{'PWD'} = $newdir; @@ -108,7 +108,7 @@ mg_len(sv) SV* sv; { MAGIC* mg; - char *s; + char *junk; STRLEN len; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { @@ -130,7 +130,7 @@ SV* sv; } } - s = SvPV(sv, len); + junk = SvPV(sv, len); return len; } @@ -223,6 +223,7 @@ MAGIC *mg; register I32 paren; register char *s; register I32 i; + char *t; switch (*mg->mg_ptr) { case '1': case '2': case '3': case '4': @@ -232,16 +233,14 @@ MAGIC *mg; 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) { @@ -250,6 +249,7 @@ MAGIC *mg; return 0; goto getparen; } + return 0; break; case '`': if (curpm) { @@ -258,23 +258,17 @@ MAGIC *mg; 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 '\\': @@ -296,8 +290,12 @@ MAGIC *mg; 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; @@ -330,49 +328,49 @@ MAGIC *mg; 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 @@ -538,29 +536,57 @@ MAGIC* mg; { 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; } @@ -852,7 +878,10 @@ magic_gettaint(sv,mg) 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; } @@ -861,11 +890,16 @@ magic_settaint(sv,mg) 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; } @@ -918,6 +952,9 @@ MAGIC* mg; 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()); @@ -953,8 +990,10 @@ MAGIC* mg; 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; @@ -1023,10 +1062,10 @@ MAGIC* mg; 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); @@ -1039,6 +1078,7 @@ MAGIC* mg; #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 @@ -1051,7 +1091,7 @@ MAGIC* mg; #endif #endif #endif - uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); + uid = (I32)getuid(); tainting |= (euid != uid || egid != gid); break; case '>': @@ -1098,8 +1138,10 @@ MAGIC* mg; #else if (gid == egid) /* special case $( = $) */ (void)setgid(gid); - else + else { + gid = (I32)getgid(); croak("setrgid() not implemented"); + } #endif #endif #endif @@ -1123,8 +1165,10 @@ MAGIC* mg; #else if (egid == gid) /* special case $) = $( */ (void)setgid(egid); - else + else { + egid = (I32)getegid(); croak("setegid() not implemented"); + } #endif #endif #endif @@ -29,5 +29,8 @@ struct magic { #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) diff --git a/miniperlmain.c b/miniperlmain.c index a17eb7f07a..ba74c4d4f9 100644 --- a/miniperlmain.c +++ b/miniperlmain.c @@ -8,9 +8,6 @@ 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; @@ -36,7 +33,7 @@ char **env; exitstatus = perl_run( my_perl ); - perl_destruct( my_perl, perl_destruct_level ); + perl_destruct( my_perl ); perl_free( my_perl ); exit( exitstatus ); @@ -26,6 +26,8 @@ static OP *scalarboolean _((OP *op)); 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) @@ -74,11 +76,11 @@ OP *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 ? '%' : '&'); } } @@ -102,7 +104,7 @@ char *name; 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; @@ -115,30 +117,53 @@ char *name; 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; + } } } @@ -148,73 +173,62 @@ char *name; */ 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; } @@ -233,7 +247,7 @@ I32 fill; } /* "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; } } @@ -331,11 +345,13 @@ pad_reset() 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; } @@ -357,7 +373,6 @@ OP *op; } } - switch (op->op_type) { case OP_NULL: op->op_targ = 0; /* Was holding old type, if any. */ @@ -376,14 +391,23 @@ OP *op; 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; @@ -501,9 +525,11 @@ OP *op; 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) { @@ -626,7 +652,7 @@ OP *op; case OP_NEXTSTATE: case OP_DBSTATE: - curcop = ((COP*)op); /* for warning above */ + curcop = ((COP*)op); /* for warning below */ break; case OP_CONST: @@ -668,6 +694,8 @@ OP *op; 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: @@ -691,6 +719,9 @@ OP *op; 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); @@ -745,9 +776,11 @@ OP *op; 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) @@ -818,7 +851,7 @@ I32 type; 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); @@ -826,6 +859,7 @@ I32 type; } else if (!type) { SAVEI32(compiling.cop_arybase); + compiling.cop_arybase = 0; } else if (type == OP_REFGEN) goto nomod; @@ -885,11 +919,14 @@ I32 type; 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: @@ -902,7 +939,6 @@ I32 type; case OP_RV2SV: ref(cUNOP->op_first, op->op_type); /* FALL THROUGH */ - case OP_PADSV: case OP_UNDEF: case OP_GV: case OP_AV2ARYLEN: @@ -911,9 +947,19 @@ I32 type; 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 = '.'; @@ -1153,11 +1199,13 @@ OP *o; 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; @@ -1218,6 +1266,8 @@ OP *op; main_start = LINKLIST(main_root); main_root->op_next = 0; peep(main_start); + main_cv = compcv; + compcv = 0; } } @@ -1263,6 +1313,7 @@ register OP *o; { register OP *curop; I32 type = o->op_type; + SV *sv; if (opargs[type] & OA_RETSCALAR) scalar(o); @@ -1292,17 +1343,26 @@ register OP *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)) @@ -1367,6 +1427,8 @@ OP* op; 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); @@ -1630,7 +1692,6 @@ OP *repl; register char *r = SvPV(rstr, rlen); register I32 i; register I32 j; - I32 squash; I32 delete; I32 complement; register short *tbl; @@ -1638,7 +1699,7 @@ OP *repl; 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); @@ -1729,11 +1790,6 @@ OP *repl; 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; @@ -1767,12 +1823,12 @@ OP *repl; } 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) { @@ -1790,32 +1846,38 @@ OP *repl; 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; } } @@ -2041,9 +2103,11 @@ OP *right; 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; @@ -2076,7 +2140,7 @@ OP *right; 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++; @@ -2088,6 +2152,16 @@ OP *right; 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 || @@ -2114,10 +2188,12 @@ OP *right; 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; } @@ -2141,6 +2217,7 @@ OP *op; 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 */ @@ -2391,9 +2468,12 @@ OP *block; 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; } @@ -2412,8 +2492,10 @@ OP *cont; 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); @@ -2483,11 +2565,8 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont 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; @@ -2544,7 +2623,8 @@ CV *cv; 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)); @@ -2554,13 +2634,89 @@ CV *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; @@ -2578,8 +2734,8 @@ OP *block; 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; @@ -2591,12 +2747,16 @@ OP *block; } } 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; @@ -2622,14 +2782,8 @@ OP *block; 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)); @@ -2684,8 +2838,10 @@ OP *block; 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; } @@ -2719,7 +2875,7 @@ char *filename; 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; @@ -2761,8 +2917,10 @@ char *filename; 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; } @@ -2794,8 +2952,7 @@ OP *block; } 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; @@ -2931,7 +3088,7 @@ OP *o; { 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 * @@ -3114,15 +3271,23 @@ ck_rvconst(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 @@ -3428,7 +3593,7 @@ OP *op; 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; @@ -3548,13 +3713,17 @@ OP *op; 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); @@ -3690,6 +3859,7 @@ register OP* o; case OP_NEXTSTATE: case OP_DBSTATE: curcop = ((COP*)o); /* for warnings */ + o->op_seq = ++op_seqmax; break; case OP_CONCAT: @@ -3709,11 +3879,15 @@ register OP* o; 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; @@ -3743,6 +3917,7 @@ register OP* o; <= 255 && i >= 0) { + SvREFCNT_dec(((SVOP*)pop)->op_sv); null(o->op_next); null(pop->op_next); null(pop); @@ -88,6 +88,8 @@ typedef U16 PADOFFSET; #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 */ @@ -1,3 +1,8 @@ +#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 */ @@ -1592,7 +1597,7 @@ EXT OP * (*check[])() = { ck_null, /* iter */ ck_null, /* enterloop */ ck_null, /* leaveloop */ - ck_fun, /* return */ + ck_null, /* return */ ck_null, /* last */ ck_null, /* next */ ck_null, /* redo */ @@ -1767,10 +1772,10 @@ EXT U32 opargs[] = { 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 */ @@ -21,7 +21,14 @@ while (<DATA>) { # 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"; } @@ -169,10 +176,10 @@ const constant item ck_svconst s 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 @@ -398,7 +405,7 @@ enteriter foreach loop entry ck_null d 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 diff --git a/patchlevel.h b/patchlevel.h index 935ec354b7..110c86f392 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 0 +#define PATCHLEVEL 1 @@ -37,6 +37,7 @@ char rcsid[] = "perl.c\nPatch level: ###\n"; 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)); @@ -61,8 +62,6 @@ void perl_construct( sv_interp ) register PerlInterpreter *sv_interp; { - char* s; - if (!(curinterp = sv_interp)) return; @@ -116,15 +115,7 @@ register PerlInterpreter *sv_interp; 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 */ @@ -135,15 +126,17 @@ register PerlInterpreter *sv_interp; } 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; @@ -228,6 +221,7 @@ char **env; char *scriptname; VOL bool dosearch = FALSE; char *validarg = ""; + AV* comppadlist; #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef IAMSUID @@ -253,6 +247,7 @@ setuid perl scripts securely.\n"); origfilename = savepv(argv[0]); do_undump = FALSE; cxstack_ix = -1; /* start label stack again */ + init_ids(); init_postdump_symbols(argc,argv,env); return 0; } @@ -263,7 +258,11 @@ setuid perl scripts securely.\n"); switch (setjmp(top_env)) { case 1: +#ifdef VMS statusvalue = 255; +#else + statusvalue = 1; +#endif case 2: curstash = defstash; if (endav) @@ -393,6 +392,9 @@ setuid perl scripts securely.\n"); if (doextract) find_beginning(); + compcv = (CV*)NEWSV(1104,0); + sv_upgrade((SV *)compcv, SVt_PVCV); + pad = newAV(); comppad = pad; av_push(comppad, Nullsv); @@ -403,8 +405,17 @@ setuid perl scripts securely.\n"); 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) @@ -511,13 +522,13 @@ PerlInterpreter *sv_interp; 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); @@ -668,7 +679,11 @@ I32 flags; /* See G_* flags in cop.h */ 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 */ @@ -816,10 +831,12 @@ I32 namlen; 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 @@ -925,7 +942,11 @@ char *s; 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"); @@ -1404,11 +1425,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); 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 */ } @@ -1461,19 +1478,31 @@ find_beginning() } 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; } @@ -1593,8 +1622,7 @@ register char **env; 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; @@ -1675,7 +1703,6 @@ calllist(list) AV* list; { jmp_buf oldtop; - char *mess; STRLEN len; line_t oldline = curcop->cop_line; @@ -1687,22 +1714,29 @@ AV* list; 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 */ @@ -259,6 +259,15 @@ EXT char Error[1]; # 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 @@ -448,6 +457,10 @@ EXT char Error[1]; # define HAS_QUAD #endif +#ifdef UV +#undef UV +#endif + #ifdef HAS_QUAD # ifdef cray # define Quad_t int @@ -458,30 +471,11 @@ EXT char Error[1]; # 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; @@ -531,14 +525,32 @@ typedef struct xpvio XPVIO; 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 { @@ -656,7 +668,7 @@ struct Outrec { #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 @@ -898,7 +910,7 @@ EXT char warn_nl[] 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[] @@ -917,6 +929,8 @@ EXT char no_dir_func[] 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; @@ -1073,6 +1087,7 @@ EXT char * oldoldbufptr; 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 */ @@ -1084,6 +1099,7 @@ EXT I32 error_count; /* how many errors so far, max 10 */ 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 */ @@ -1091,7 +1107,7 @@ EXT I32 min_intro_pending;/* start of vars to introduce */ 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() */ @@ -1157,6 +1173,9 @@ IEXT GV * Ienvgv; IEXT GV * Isiggv; IEXT GV * Iincgv; IEXT char * Iorigfilename; +IEXT SV * Idiehook; +IEXT SV * Iwarnhook; +IEXT SV * Iparsehook; /* switches */ IEXT char * Icddir; @@ -1186,6 +1205,8 @@ IEXT char * Ie_tmpname; 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 */ @@ -1202,7 +1223,7 @@ IEXT STRLEN Iorslen; 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; @@ -1270,7 +1291,7 @@ IEXT VOL int Iin_eval; /* trap "fatal" errors? */ 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 */ @@ -1281,6 +1302,7 @@ IEXT char * Idebname; IEXT char * Idebdelim; /* current interpreter roots */ +IEXT CV * Imain_cv; IEXT OP * Imain_root; IEXT OP * Imain_start; IEXT OP * Ieval_root; @@ -1424,9 +1446,9 @@ MGVTBL vtbl_uvar = {magic_getuvar, #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 @@ -1460,7 +1482,7 @@ EXT MGVTBL vtbl_amagicelem; #ifdef OVERLOAD EXT long amagic_generation; -#define NofAMmeth 27 +#define NofAMmeth 29 #ifdef DOINIT EXT char * AMG_names[NofAMmeth][2] = { {"fallback","abs"}, @@ -1474,6 +1496,9 @@ EXT char * AMG_names[NofAMmeth][2] = { {"**", "**="}, {"<<", "<<="}, {">>", ">>="}, + {"&", "&="}, + {"|", "|="}, + {"^", "^="}, {"<", "<="}, {">", ">="}, {"==", "!="}, @@ -1481,15 +1506,14 @@ EXT char * AMG_names[NofAMmeth][2] = { {"lt", "le"}, {"gt", "ge"}, {"eq", "ne"}, - {"&", "^"}, - {"|", "neg"}, {"!", "~"}, {"++", "--"}, {"atan2", "cos"}, {"sin", "exp"}, {"log", "sqrt"}, {"x","x="}, - {".",".="} + {".",".="}, + {"=","neg"} }; #else EXT char * AMG_names[NofAMmeth][2]; @@ -1519,6 +1543,9 @@ enum { 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, @@ -1526,15 +1553,14 @@ enum { 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 */ @@ -2,7 +2,7 @@ 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" @@ -1274,7 +1274,7 @@ int yyerrflag; int yychar; YYSTYPE yyval; YYSTYPE yylval; -#line 546 "perly.y" +#line 545 "perly.y" /* PROGRAM */ #line 1347 "y.tab.c" #define YYABORT goto yyabort @@ -1501,7 +1501,7 @@ yyreduce: switch (yyn) { case 1: -#line 84 "perly.y" +#line 83 "perly.y" { #if defined(YYDEBUG) && defined(DEBUGGING) yydebug = (debug & 1); @@ -1510,38 +1510,38 @@ case 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)); } @@ -1552,119 +1552,119 @@ case 10: 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)), @@ -1673,325 +1673,325 @@ case 33: 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, @@ -1999,7 +1999,7 @@ case 113: 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, @@ -2008,166 +2008,166 @@ case 114: 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" diff --git a/perly.c.diff b/perly.c.diff index a6e9389306..2f7fb7021b 100644 --- a/perly.c.diff +++ b/perly.c.diff @@ -1,11 +1,11 @@ -*** 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; @@ -83,7 +83,7 @@ - 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 ---- @@ -324,7 +324,7 @@ #endif yym = yylen[yyn]; *************** -*** 2161,2168 **** +*** 2163,2170 **** { #if YYDEBUG if (yydebug) @@ -333,7 +333,7 @@ #endif yystate = YYFINAL; *++yyssp = YYFINAL; ---- 2178,2186 ---- +--- 2180,2188 ---- { #if YYDEBUG if (yydebug) @@ -344,7 +344,7 @@ yystate = YYFINAL; *++yyssp = YYFINAL; *************** -*** 2176,2182 **** +*** 2178,2184 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -352,7 +352,7 @@ YYFINAL, yychar, yys); } #endif ---- 2194,2200 ---- +--- 2196,2202 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; @@ -361,7 +361,7 @@ } #endif *************** -*** 2191,2210 **** +*** 2193,2212 **** yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) @@ -382,7 +382,7 @@ yyaccept: ! return (0); } ---- 2209,2243 ---- +--- 2211,2245 ---- yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) @@ -20,6 +20,7 @@ while (<>) { @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; diff --git a/pod/modpods/AnyDBMFile.pod b/pod/modpods/AnyDBMFile.pod index 7b579ca34c..5692144586 100644 --- a/pod/modpods/AnyDBMFile.pod +++ b/pod/modpods/AnyDBMFile.pod @@ -10,16 +10,23 @@ NDBM_File, ODBM_File, SDBM_File, GDBM_File - various DBM implementations =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; diff --git a/pod/modpods/Basename.pod b/pod/modpods/Basename.pod index 11cb15ee77..b0f8229e3b 100644 --- a/pod/modpods/Basename.pod +++ b/pod/modpods/Basename.pod @@ -25,7 +25,7 @@ dirname - extract just the directory from a path =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 diff --git a/pod/modpods/Benchmark.pod b/pod/modpods/Benchmark.pod index bdb3f05700..6b7d949336 100644 --- a/pod/modpods/Benchmark.pod +++ b/pod/modpods/Benchmark.pod @@ -8,7 +8,7 @@ timethese - run several chunks of code several times timeit - run a chunk of code and see how long it goes -=head1 SYNOPSYS +=head1 SYNOPSIS timethis ($count, "code"); diff --git a/pod/modpods/Cwd.pod b/pod/modpods/Cwd.pod index ac4e24f74d..042db8112e 100644 --- a/pod/modpods/Cwd.pod +++ b/pod/modpods/Cwd.pod @@ -5,10 +5,10 @@ getcwd - get pathname of current working directory =head1 SYNOPSIS require Cwd; - $dir = Cwd::getcwd()' + $dir = Cwd::getcwd(); use Cwd; - $dir = getcwd()' + $dir = getcwd(); use Cwd 'chdir'; chdir "/tmp"; diff --git a/pod/modpods/Dynaloader.pod b/pod/modpods/Dynaloader.pod index 9810dad205..344fb6944a 100644 --- a/pod/modpods/Dynaloader.pod +++ b/pod/modpods/Dynaloader.pod @@ -59,7 +59,7 @@ search for libraries etc. Directories are searched in order: $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 @@ -172,7 +172,7 @@ order to deal with symbolic names for files (i.e., VMS's Logical Names). 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() diff --git a/pod/modpods/Exporter.pod b/pod/modpods/Exporter.pod index 03e6a1c92d..050fafa4ba 100644 --- a/pod/modpods/Exporter.pod +++ b/pod/modpods/Exporter.pod @@ -4,7 +4,7 @@ Exporter - module to control namespace manipulations import - import functions into callers namespace -=head1 SYNOPSYS +=head1 SYNOPSIS package WhatEver; require Exporter; @@ -12,7 +12,7 @@ import - import functions into callers namespace @EXPORT = qw(func1, $foo, %tabs); @EXPORT_OK = qw(sin cos); ... - use Whatever; + use WhatEver; use WhatEver 'sin'; =head1 DESCRIPTION @@ -22,7 +22,7 @@ control what they will export into their user's namespace. 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(). diff --git a/pod/modpods/Find.pod b/pod/modpods/Find.pod index 81b46a9879..40a2aed300 100644 --- a/pod/modpods/Find.pod +++ b/pod/modpods/Find.pod @@ -2,7 +2,7 @@ find - traverse a file tree -=head1 SYNOPSYS +=head1 SYNOPSIS use File::Find; find(\&wanted, '/foo','/bar'); @@ -10,7 +10,7 @@ find - traverse a file tree =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. diff --git a/pod/modpods/Finddepth.pod b/pod/modpods/Finddepth.pod index 022ddaf9f4..c6512655d1 100644 --- a/pod/modpods/Finddepth.pod +++ b/pod/modpods/Finddepth.pod @@ -2,7 +2,7 @@ finddepth - traverse a directory structure depth-first -=head1 SYNOPSYS +=head1 SYNOPSIS use File::Finddepth; finddepth(\&wanted, '/foo','/bar'); @@ -10,7 +10,5 @@ finddepth - traverse a directory structure depth-first =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(). diff --git a/pod/modpods/Getopt.pod b/pod/modpods/Getopt.pod index 2f607257ba..9cda9ec03f 100644 --- a/pod/modpods/Getopt.pod +++ b/pod/modpods/Getopt.pod @@ -10,7 +10,8 @@ GetOptions - extended getopt processing 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...); diff --git a/pod/modpods/MakeMaker.pod b/pod/modpods/MakeMaker.pod index 4db758fb20..0655729598 100644 --- a/pod/modpods/MakeMaker.pod +++ b/pod/modpods/MakeMaker.pod @@ -10,7 +10,7 @@ MakeMaker - generate a Makefile for Perl extension 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 diff --git a/pod/modpods/Open2.pod b/pod/modpods/Open2.pod index 19f0369cfd..942f68446d 100644 --- a/pod/modpods/Open2.pod +++ b/pod/modpods/Open2.pod @@ -30,4 +30,14 @@ It assumes it's going to talk to something like B<bc>, both writing to 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. + diff --git a/pod/modpods/POSIX.pod b/pod/modpods/POSIX.pod index 30539ad36f..110e46b21b 100644 --- a/pod/modpods/POSIX.pod +++ b/pod/modpods/POSIX.pod @@ -21,7 +21,7 @@ F<POSIX.pm> module. =head1 EXAMPLES - printf "EENTR is %d\n", EINTR; + printf "EINTR is %d\n", EINTR; POSIX::setsid(0); @@ -39,8 +39,8 @@ source of wisdom. 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 diff --git a/pod/modpods/Ping.pod b/pod/modpods/Ping.pod index 01bc25c64f..fc52925118 100644 --- a/pod/modpods/Ping.pod +++ b/pod/modpods/Ping.pod @@ -12,7 +12,7 @@ Net::Ping, pingecho - check a host for upness 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. diff --git a/pod/modpods/less.pod b/pod/modpods/less.pod index bccc5341d1..37c962e90b 100644 --- a/pod/modpods/less.pod +++ b/pod/modpods/less.pod @@ -5,7 +5,7 @@ less - Perl pragma to request less of something from the compiler =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'; diff --git a/pod/modpods/strict.pod b/pod/modpods/strict.pod index e994ed2bc5..34a9c86934 100644 --- a/pod/modpods/strict.pod +++ b/pod/modpods/strict.pod @@ -16,9 +16,9 @@ strict - Perl pragma to restrict unsafe constructs =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 @@ -53,7 +53,7 @@ name without fully qualifying it. 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 diff --git a/pod/perl.pod b/pod/perl.pod index 9306d5c9c7..d0d15b157a 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -249,7 +249,7 @@ The B<-w> switch is not mandatory. 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().) diff --git a/pod/perlapi.pod b/pod/perlapi.pod index f76d877f9b..7519e875e0 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -947,5 +947,5 @@ File C<rpctest.pl>: Perl test program for the RPC extension. =head1 AUTHOR -Dean Roehrich <roehrich@cray.com> +Dean Roehrich C<roehrich@cray.com> September 27, 1994 diff --git a/pod/perlbook.pod b/pod/perlbook.pod index 441c43aabf..16f74df403 100644 --- a/pod/perlbook.pod +++ b/pod/perlbook.pod @@ -5,8 +5,8 @@ perlbook - Perl book information =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. diff --git a/pod/perldata.pod b/pod/perldata.pod index 6b4f7a4053..4042ecf74e 100644 --- a/pod/perldata.pod +++ b/pod/perldata.pod @@ -40,7 +40,7 @@ Every variable type has its own namespace. You can, without fear of 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 '%', @@ -203,9 +203,22 @@ price is $100." 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 @@ -218,7 +231,7 @@ filehandle may read data only from the main script, but not from any 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 @@ -311,7 +324,7 @@ List values are denoted by separating individual values by commas (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, diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 43b0f3f5b8..8cc2945336 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -14,8 +14,11 @@ desperation): (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! @@ -128,6 +131,12 @@ the return value of your socket() call? See L<perlfunc/accept>. (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 @@ -343,7 +352,8 @@ but then $foo no longer contains a glob. =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 @@ -439,13 +449,32 @@ levels, the following is missing its final parenthesis: (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 @@ -454,6 +483,13 @@ call for another. It can't manufacture one out of whole cloth. In general 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 @@ -505,6 +541,28 @@ try any of several modules in the Perl library to do this, such as "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. @@ -514,6 +572,11 @@ and then read it in under a different file handle. (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 @@ -568,14 +631,6 @@ message indicates that such a conversion was attempted. 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. @@ -586,7 +641,15 @@ the intervening arrow. 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>. @@ -609,6 +672,12 @@ the global variable) and it would be incredibly confusing to have 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 @@ -664,9 +733,22 @@ times than it has returned. This probably indicates an infinite 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' @@ -686,6 +768,14 @@ been freed. (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. @@ -705,9 +795,12 @@ a goto, or a loop control statement. (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 @@ -789,6 +882,12 @@ on the Internet. (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 @@ -838,6 +937,11 @@ don't take to this kindly. (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. @@ -861,6 +965,16 @@ setgid script if $ENV{PATH} is derived from data supplied (or 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. @@ -942,6 +1056,11 @@ one line to the next. (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. @@ -1024,6 +1143,12 @@ See L<perlsec>. 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, @@ -1045,6 +1170,30 @@ but for some reason the perl5db.pl file (or some facsimile thereof) 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 @@ -1065,6 +1214,12 @@ your system. (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. @@ -1173,6 +1328,14 @@ since hash lists come in key/value pairs. (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, @@ -1350,6 +1513,12 @@ anyway? See L<perlfunc/require>. (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 @@ -1458,6 +1627,11 @@ assigning to it and when evaluating its argument, while @foo[&bar] behaves like a list when you assign to it, and provides a list context to its subscript, which can do weird things if you're 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 @@ -1884,6 +2058,11 @@ you and for any luckless subroutine that you happen to call. You should 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 @@ -1917,6 +2096,22 @@ when you meant to say ($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 @@ -1998,5 +2193,26 @@ substitution, but stylistically it's better to use the variable form 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 diff --git a/pod/perlform.pod b/pod/perlform.pod index 38d7153e8b..99e0746c1a 100644 --- a/pod/perlform.pod +++ b/pod/perlform.pod @@ -8,9 +8,9 @@ Perl has a mechanism to help you generate simple reports and charts. To 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, @@ -90,7 +90,7 @@ characters are legal to break on by changing the variable C<$:> (that's $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 @@ -156,7 +156,7 @@ The current format name is stored in the variable C<$~> ($FORMAT_NAME), 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 @@ -198,8 +198,8 @@ Much better! =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 = @@ -291,13 +291,13 @@ For example: 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); @@ -308,7 +308,6 @@ is to printf(), do this: =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.) diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index d5aa3aa0b3..42ec30fb55 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -234,12 +234,19 @@ Returns the context of the current subroutine call. In a scalar context, 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 @@ -310,6 +317,9 @@ You can actually chop anything that's an lvalue, including an assignment: 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 @@ -371,7 +381,7 @@ Closes a directory opened by opendir(). 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 @@ -404,7 +414,7 @@ their own password: } 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 @@ -492,8 +502,8 @@ a hash key lookup: 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: @@ -611,29 +621,33 @@ Returns 1 if the next read on FILEHANDLE will return end of file, or if 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. @@ -693,7 +707,7 @@ reader wonder what else might be happening (nothing is).) Cases 3 and 4 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 @@ -852,10 +866,14 @@ accumulator, C<$^A>. Eventually, when a write() is done, the contents of 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 @@ -1018,7 +1036,7 @@ operator. =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: @@ -1031,6 +1049,8 @@ the range 0..6. If EXPR is omitted, does C<gmtime(time())>. =item goto LABEL +=item goto EXPR + =item goto &NAME The goto-LABEL form finds the statement labeled with LABEL and resumes @@ -1042,6 +1062,12 @@ including out of subroutines, but it's usually better to use some other 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 @@ -1081,7 +1107,7 @@ omitted, uses $_. 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 @@ -1228,8 +1254,8 @@ it succeeded, FALSE otherwise. See example in L<perlipc>. =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. @@ -1277,11 +1303,12 @@ parameters to a subroutine. Examples: } 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 @@ -1435,17 +1462,37 @@ used to name the parameters to a subroutine. Examples: } # 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, @@ -1947,8 +1994,8 @@ If EXPR is a bare word, the require assumes a "F<.pm>" extension for you, 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 @@ -2020,7 +2067,7 @@ call of stdio. FILEHANDLE may be an expression whose value gives the name 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 @@ -2146,7 +2193,7 @@ implement setpgrp(2). =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 @@ -2330,7 +2377,8 @@ using C<??> as the pattern delimiters, but it still returns the array 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 @@ -2340,7 +2388,7 @@ If LIMIT is negative, it is treated as if an arbitrarily large LIMIT 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: @@ -2369,17 +2417,22 @@ produces the list value 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(/:/); ... } @@ -2495,7 +2548,10 @@ out the names of those files that contain a match: 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 @@ -2580,15 +2636,15 @@ the corresponding system library routine. =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); diff --git a/pod/perlipc.pod b/pod/perlipc.pod index a2f3f8b16d..5a43660fb2 100644 --- a/pod/perlipc.pod +++ b/pod/perlipc.pod @@ -34,10 +34,10 @@ Here's a sample TCP client. 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: $!"; @@ -69,11 +69,11 @@ And here's a server: ($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: $!"; diff --git a/pod/perlmod.pod b/pod/perlmod.pod index d804b1e4ed..dc825d6386 100644 --- a/pod/perlmod.pod +++ b/pod/perlmod.pod @@ -6,8 +6,10 @@ perlmod - Perl modules (packages) =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 @@ -34,11 +36,11 @@ It would treat package C<INNER> as a totally separate global package. 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 @@ -47,7 +49,7 @@ to use leading underscore to indicate private variables and method names.) 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 @@ -111,7 +113,7 @@ i.e., *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: @@ -139,7 +141,7 @@ An C<END> subroutine is executed as late as possible, that is, when the 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> @@ -244,7 +246,7 @@ you're redefining the world and willing to take the consequences. 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 @@ -255,7 +257,7 @@ conversion, but it's just a mechanical process, so is far from bullet proof. 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; @@ -291,7 +293,7 @@ Perl pragma to predeclare sub names =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. @@ -316,7 +318,7 @@ split a package for autoloading =item C<Basename> -parse file anme and path from a specification +parse file name and path from a specification =item C<Benchmark> @@ -411,11 +413,11 @@ dynamically loaded into Perl if and when you need them. Supported 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! @@ -454,7 +456,7 @@ where. =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 diff --git a/pod/perlobj.pod b/pod/perlobj.pod index e4f34ba48d..6bbaab4704 100644 --- a/pod/perlobj.pod +++ b/pod/perlobj.pod @@ -69,7 +69,7 @@ reference as an ordinary reference. Outside the class package, 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 @@ -224,6 +224,13 @@ name with the package like this: $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 @@ -240,6 +247,21 @@ applies to reblessed objects--an object reference that is merely 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 diff --git a/pod/perlop.pod b/pod/perlop.pod index d33ce931c2..574e9238d8 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -454,7 +454,7 @@ is equivalent to $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 @@ -463,6 +463,9 @@ argument and returns that value. This is just like C's comma operator. 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, @@ -874,6 +877,12 @@ Examples: 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 @@ -905,20 +914,20 @@ To pass a $ through to the shell you need to hide it with a backslash. 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 diff --git a/pod/perlovl.pod b/pod/perlovl.pod index db00f4dbf1..cdb3ba66c5 100644 --- a/pod/perlovl.pod +++ b/pod/perlovl.pod @@ -114,7 +114,7 @@ arrays, C<cmp> is used to compare values subject to %OVERLOAD. =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. @@ -206,10 +206,7 @@ C<$OVERLOAD{"nomethod"}>, and if this is missing, raises an exception. =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 @@ -287,7 +284,8 @@ value is scalar but not a reference. =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 @@ -351,12 +349,6 @@ induces diagnostic messages. 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. diff --git a/pod/perlre.pod b/pod/perlre.pod index 1324642f71..295b6bd518 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -297,11 +297,9 @@ first alternative includes everything from the last pattern delimiter 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 @@ -309,7 +307,7 @@ subpattern later in the pattern using the metacharacter \I<n>. 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. diff --git a/pod/perlref.pod b/pod/perlref.pod index 0ad25dfe66..f12cad4554 100644 --- a/pod/perlref.pod +++ b/pod/perlref.pod @@ -108,29 +108,54 @@ matter how many times you execute that line (unless you're in an 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 @@ -217,7 +242,7 @@ cumbersome to use method 2. As a form of syntactic sugar, the two 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 @@ -325,6 +350,70 @@ invisible to this mechanism. For example: 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. diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 5179abccd4..37be506d62 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -123,7 +123,8 @@ An alternate delimiter may be specified using B<-F>. =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> @@ -361,8 +362,8 @@ scalar variables that are used before being set. Also warns about 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> diff --git a/pod/perlsec.pod b/pod/perlsec.pod index 0be4f52798..2bd659ebb1 100644 --- a/pod/perlsec.pod +++ b/pod/perlsec.pod @@ -108,7 +108,7 @@ so you must be careful with your patterns. This is the I<ONLY> mechanism 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 diff --git a/pod/perlsub.pod b/pod/perlsub.pod index cfc8b5611f..1f5201a4c7 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -9,6 +9,10 @@ To declare subroutines: 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); @@ -26,12 +30,12 @@ Any arguments passed to the routine come in as array @_, that is ($_[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 @@ -97,6 +101,17 @@ visible to subroutine instead. &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 diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod index 3ddb493c8b..252e679b72 100644 --- a/pod/perlsyn.pod +++ b/pod/perlsyn.pod @@ -55,7 +55,7 @@ The only kind of simple statement is an expression evaluated for its 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 @@ -106,7 +106,7 @@ The following compound statements may be used to control flow: 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, @@ -164,13 +164,15 @@ is the same as 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/; } diff --git a/pod/perltrap.pod b/pod/perltrap.pod index 51dac4770f..fa68a753c2 100644 --- a/pod/perltrap.pod +++ b/pod/perltrap.pod @@ -292,12 +292,22 @@ unary ones.) See L<perlop>. =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: @@ -332,12 +342,13 @@ C<@> now always interpolates an array in double-quotish strings. Some programs 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. @@ -442,6 +453,12 @@ since this capability may be onerous for some modules to implement. =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 * diff --git a/pod/perlvar.pod b/pod/perlvar.pod index bdf24f6c89..bfd04f74d4 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -38,9 +38,9 @@ new value for the FileHandle attribute in question. If not supplied, 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 @@ -379,6 +379,9 @@ last eval() parsed and executed correctly (although the operations you 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 @@ -602,7 +605,23 @@ the Perl script. Here are some other examples: 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 diff --git a/pod/pod2html b/pod/pod2html index 1bfc8f6a6a..a2cde18ce4 100644..100755 --- a/pod/pod2html +++ b/pod/pod2html @@ -1,209 +1,459 @@ -#!../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?$//; + } +} + + diff --git a/pod/pod2latex b/pod/pod2latex new file mode 100755 index 0000000000..9dbb2cd27b --- /dev/null +++ b/pod/pod2latex @@ -0,0 +1,632 @@ +#!/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 +); +} diff --git a/pod/pod2man b/pod/pod2man index 5b577738e3..b375b0184e 100755 --- a/pod/pod2man +++ b/pod/pod2man @@ -95,10 +95,10 @@ END 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 @@ -113,7 +113,7 @@ print <<'END'; . 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 #[ \& @@ -132,26 +132,26 @@ print <<'END'; . 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 @@ -159,8 +159,8 @@ print <<'END'; .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 \ \{\ @@ -246,7 +246,7 @@ while (<>) { } {I<$1>\\|$2}gx; # convert simple variable references - s/([\$\@%][\w:]+)/C<$1>/g; + s/(\s+)([\$\@%][\w:]+)/${1}C<$2>/g; if (m{ ( [\-\w]+ @@ -103,6 +103,8 @@ PP(pp_rv2gv) } else { if (SvTYPE(sv) != SVt_PVGV) { + char *sym; + if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) @@ -114,9 +116,10 @@ PP(pp_rv2gv) 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) { @@ -169,6 +172,8 @@ PP(pp_rv2sv) } else { GV *gv = sv; + char *sym; + if (SvTYPE(gv) != SVt_PVGV) { if (SvGMAGICAL(sv)) { mg_get(sv); @@ -181,9 +186,10 @@ PP(pp_rv2sv) 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); } @@ -260,7 +266,14 @@ PP(pp_rv2cv) 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; } @@ -539,7 +552,12 @@ PP(pp_undef) 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; } @@ -548,7 +566,12 @@ PP(pp_postinc) { 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); @@ -560,7 +583,12 @@ PP(pp_postdec) { 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; @@ -642,7 +670,8 @@ PP(pp_modulo) PP(pp_repeat) { - dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); + { register I32 count = POPi; if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) { dMARK; @@ -691,6 +720,7 @@ PP(pp_repeat) PUSHTARG; } RETURN; + } } PP(pp_subtract) @@ -707,9 +737,9 @@ PP(pp_left_shift) { dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { - dPOPTOPiirl; - SETi( left << right ); - RETURN; + dPOPTOPiirl; + SETi( left << right ); + RETURN; } } @@ -947,7 +977,11 @@ PP(pp_complement) 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; @@ -976,84 +1010,6 @@ PP(pp_complement) /* 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); @@ -1408,7 +1364,7 @@ PP(pp_substr) if (MAXARG < 3) len = curlen; else if (len < 0) { - len += curlen; + len += curlen - pos; if (len < 0) len = 0; } @@ -1418,6 +1374,7 @@ PP(pp_substr) 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); @@ -1466,20 +1423,24 @@ PP(pp_vec) 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); } } } @@ -1605,13 +1566,12 @@ PP(pp_chr) 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; @@ -1757,11 +1717,25 @@ PP(pp_aslice) 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) @@ -1772,7 +1746,7 @@ PP(pp_aslice) *MARK = svp ? *svp : &sv_undef; } } - else if (GIMME != G_ARRAY) { + if (GIMME != G_ARRAY) { MARK = ORIGMARK; *++MARK = *SP; SP = MARK; @@ -1829,7 +1803,8 @@ PP(pp_delete) 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); @@ -1911,7 +1886,11 @@ PP(pp_lslice) 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 @@ -1926,7 +1905,7 @@ PP(pp_lslice) } for (lelem = firstlelem; lelem <= lastlelem; lelem++) { - ix = SvIVx(*lelem) - arybase; + ix = SvIVx(*lelem); if (ix < 0) { ix += max; if (ix < 0) @@ -1934,8 +1913,11 @@ PP(pp_lslice) 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; @@ -2300,7 +2282,7 @@ PP(pp_unpack) 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++; @@ -3428,8 +3410,12 @@ PP(pp_split) 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); @@ -181,7 +181,7 @@ #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 @@ -80,15 +80,9 @@ PP(pp_regcomp) { 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; } @@ -119,7 +113,13 @@ PP(pp_substcont) { 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))); @@ -161,8 +161,6 @@ PP(pp_formline) bool chopspace = (strchr(chopset, ' ') != Nullch); char *chophere; char *linemark; - char *formmark; - SV **markmark; double value; bool gotsome; STRLEN len; @@ -212,8 +210,6 @@ PP(pp_formline) switch (*fpc++) { case FF_LINEMARK: linemark = t; - formmark = f; - markmark = MARK; lines++; gotsome = FALSE; break; @@ -895,6 +891,9 @@ die(pat, va_alist) char *message; int oldrunlevel = runlevel; int was_in_eval = in_eval; + HV *stash; + GV *gv; + CV *cv; #ifdef I_STDARG va_start(args, pat); @@ -903,6 +902,15 @@ die(pat, va_alist) #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); @@ -918,8 +926,12 @@ char *message; 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; @@ -939,6 +951,8 @@ char *message; 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(); @@ -948,8 +962,12 @@ char *message; (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; } @@ -1048,6 +1066,9 @@ PP(pp_caller) 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); @@ -1075,6 +1096,7 @@ const void *b; { SV **str1 = (SV **) a; SV **str2 = (SV **) b; + I32 oldsaveix = savestack_ix; I32 oldscopeix = scopestack_ix; I32 result; GvSV(firstgv) = *str1; @@ -1084,12 +1106,13 @@ const void *b; 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; } @@ -1149,28 +1172,29 @@ PP(pp_dbstate) 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); @@ -1292,6 +1316,13 @@ PP(pp_return) 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"); @@ -1303,12 +1334,8 @@ PP(pp_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); } @@ -1330,7 +1357,6 @@ PP(pp_last) 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); @@ -1562,21 +1588,29 @@ PP(pp_goto) 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); } } @@ -1694,9 +1728,9 @@ PP(pp_goto) /* 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)(); } @@ -1714,6 +1748,11 @@ PP(pp_goto) do_undump = FALSE; } + if (stack == signalstack) { + restartop = retop; + longjmp(top_env, 3); + } + RETURNOP(retop); } @@ -1806,6 +1845,7 @@ int gimme; dSP; OP *saveop = op; HV *newstash; + AV* comppadlist; in_eval = 1; @@ -1818,6 +1858,11 @@ int gimme; 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; @@ -1826,6 +1871,12 @@ int gimme; 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; @@ -1877,8 +1928,7 @@ int gimme; 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); @@ -1924,7 +1974,12 @@ PP(pp_require) 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"); } @@ -1933,8 +1988,15 @@ PP(pp_require) 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; @@ -2005,13 +2067,15 @@ PP(pp_entereval) 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; @@ -2077,7 +2141,7 @@ PP(pp_leaveeval) 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); @@ -2091,22 +2155,6 @@ PP(pp_leaveeval) 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; @@ -90,12 +90,15 @@ PP(pp_and) 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); @@ -136,17 +139,22 @@ PP(pp_seq) 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) @@ -177,7 +185,12 @@ PP(pp_eq) 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; } @@ -243,19 +256,25 @@ PP(pp_print) 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 { @@ -330,6 +349,8 @@ PP(pp_rv2av) } else { if (SvTYPE(sv) != SVt_PVGV) { + char *sym; + if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) @@ -341,9 +362,10 @@ PP(pp_rv2av) 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) @@ -398,6 +420,8 @@ PP(pp_rv2hv) } else { if (SvTYPE(sv) != SVt_PVGV) { + char *sym; + if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) @@ -409,9 +433,10 @@ PP(pp_rv2hv) 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) @@ -481,7 +506,7 @@ PP(pp_aassign) switch (SvTYPE(sv)) { case SVt_PVAV: ary = (AV*)sv; - magic = SvSMAGICAL(ary) != 0; + magic = SvMAGICAL(ary) != 0; av_clear(ary); i = 0; @@ -500,7 +525,7 @@ PP(pp_aassign) SV *tmpstr; hash = (HV*)sv; - magic = SvSMAGICAL(hash) != 0; + magic = SvMAGICAL(hash) != 0; hv_clear(hash); while (relem < lastrelem) { /* gobble up all the rest */ @@ -553,14 +578,14 @@ PP(pp_aassign) #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) { @@ -583,7 +608,7 @@ PP(pp_aassign) #ifdef HAS_SETRGID if ((delaymagic & DM_GID) == DM_RGID) { (void)setrgid(gid); - delaymagic =~ DM_RGID; + delaymagic &= ~DM_RGID; } #endif /* HAS_SETRGID */ #ifdef HAS_SETRESGID @@ -592,7 +617,7 @@ PP(pp_aassign) #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) { @@ -642,6 +667,7 @@ PP(pp_match) register REGEXP *rx = pm->op_pmregexp; I32 gimme = GIMME; STRLEN len; + I32 minmatch = 0; if (op->op_flags & OPf_STACKED) TARG = POPs; @@ -669,10 +695,14 @@ PP(pp_match) 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); @@ -684,6 +714,7 @@ play_it_again: 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) { @@ -725,11 +756,7 @@ play_it_again: 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; @@ -776,7 +803,15 @@ play_it_again: 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; } @@ -894,7 +929,7 @@ do_readline() if (cp[i] == '/') { hasdir = isunix = 1; break; - } + } if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') { hasdir = 1; break; @@ -921,7 +956,8 @@ do_readline() 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; } @@ -963,7 +999,7 @@ do_readline() 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); @@ -1218,7 +1254,7 @@ PP(pp_subst) EXTEND(SP,1); } s = SvPV(TARG, len); - if (!SvPOKp(TARG)) + if (!SvPOKp(TARG) || SvREADONLY(TARG)) force_on_match = 1; force_it: @@ -1414,7 +1450,13 @@ PP(pp_subst) } 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))); @@ -1527,17 +1569,16 @@ PP(pp_entersub) 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); @@ -1583,8 +1624,12 @@ PP(pp_entersub) 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"); @@ -1607,8 +1652,19 @@ PP(pp_entersub) 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; @@ -1632,21 +1688,28 @@ PP(pp_entersub) 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); } } @@ -1704,10 +1767,12 @@ PP(pp_aelem) { 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); @@ -1774,6 +1839,7 @@ DIE("Can't call method \"%s\" without a package or object reference", name); SETs(gv); RETURN; } + *(stack_base + TOPMARK + 1) = iogv; } if (!ob || !SvOBJECT(ob)) { @@ -752,12 +752,13 @@ PP(pp_enterwrite) 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); } @@ -787,7 +788,7 @@ PP(pp_leavewrite) 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 @@ -800,11 +801,27 @@ PP(pp_leavewrite) } 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); } @@ -834,6 +851,7 @@ PP(pp_leavewrite) else { FmLINES(formtarget) = 0; SvCUR_set(formtarget, 0); + *SvEND(formtarget) = '\0'; if (IoFLAGS(io) & IOf_FLUSH) (void)fflush(fp); PUSHs(&sv_yes); @@ -857,19 +875,22 @@ PP(pp_prtf) 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 { @@ -902,18 +923,18 @@ PP(pp_sysread) 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 @@ -924,17 +945,17 @@ PP(pp_sysread) #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); @@ -944,7 +965,7 @@ PP(pp_sysread) 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); } @@ -960,12 +981,12 @@ PP(pp_sysread) 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; @@ -986,7 +1007,7 @@ PP(pp_send) GV *gv; IO *io; int offset; - SV *bufstr; + SV *bufsv; char *buffer; int length; STRLEN blen; @@ -994,12 +1015,12 @@ PP(pp_send) 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; @@ -1094,7 +1115,7 @@ PP(pp_truncate) 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) { @@ -1128,7 +1149,7 @@ PP(pp_truncate) if (result) RETPUSHYES; if (!errno) - errno = EBADF; + SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; #else DIE("truncate not implemented"); @@ -1143,7 +1164,7 @@ PP(pp_fcntl) PP(pp_ioctl) { dSP; dTARGET; - SV *argstr = POPs; + SV *argsv = POPs; unsigned int func = U_I(POPn); int optype = op->op_type; char *s; @@ -1151,24 +1172,24 @@ PP(pp_ioctl) 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 @@ -1195,12 +1216,12 @@ PP(pp_ioctl) # 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) @@ -1263,7 +1284,7 @@ PP(pp_socket) gv = (GV*)POPs; if (!gv) { - errno = EBADF; + SETERRNO(EBADF,LIB$_INVARG); RETPUSHUNDEF; } @@ -1345,7 +1366,7 @@ PP(pp_bind) { dSP; #ifdef HAS_SOCKET - SV *addrstr = POPs; + SV *addrsv = POPs; char *addr; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -1354,7 +1375,7 @@ PP(pp_bind) 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; @@ -1364,7 +1385,7 @@ PP(pp_bind) nuts: if (dowarn) warn("bind() on closed fd"); - errno = EBADF; + SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else DIE(no_sock_func, "bind"); @@ -1375,7 +1396,7 @@ PP(pp_connect) { dSP; #ifdef HAS_SOCKET - SV *addrstr = POPs; + SV *addrsv = POPs; char *addr; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -1384,7 +1405,7 @@ PP(pp_connect) 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; @@ -1394,7 +1415,7 @@ PP(pp_connect) nuts: if (dowarn) warn("connect() on closed fd"); - errno = EBADF; + SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else DIE(no_sock_func, "connect"); @@ -1420,7 +1441,7 @@ PP(pp_listen) nuts: if (dowarn) warn("listen() on closed fd"); - errno = EBADF; + SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else DIE(no_sock_func, "listen"); @@ -1429,13 +1450,14 @@ nuts: 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; @@ -1454,7 +1476,7 @@ PP(pp_accept) 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"); @@ -1467,13 +1489,13 @@ PP(pp_accept) 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; @@ -1500,7 +1522,7 @@ PP(pp_shutdown) nuts: if (dowarn) warn("shutdown() on closed fd"); - errno = EBADF; + SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else DIE(no_sock_func, "shutdown"); @@ -1527,6 +1549,7 @@ PP(pp_ssockopt) unsigned int lvl; GV *gv; register IO *io; + int aint; if (optype == OP_GSOCKOPT) sv = sv_2mortal(NEWSV(22, 257)); @@ -1543,14 +1566,18 @@ PP(pp_ssockopt) 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)) @@ -1571,7 +1598,7 @@ PP(pp_ssockopt) nuts: if (dowarn) warn("[gs]etsockopt() on closed fd"); - errno = EBADF; + SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; @@ -1598,31 +1625,36 @@ PP(pp_getpeername) 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; @@ -1646,6 +1678,7 @@ PP(pp_stat) if (op->op_flags & OPf_REF) { tmpgv = cGVOP->op_gv; + do_fstat: if (tmpgv != defgv) { laststype = OP_STAT; statgv = tmpgv; @@ -1660,7 +1693,16 @@ PP(pp_stat) 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; @@ -2055,7 +2097,7 @@ PP(pp_fttext) if (dowarn) warn("Test on unopened file <%s>", GvENAME(cGVOP->op_gv)); - errno = EBADF; + SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; } } @@ -2135,6 +2177,11 @@ PP(pp_chdir) } 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; } @@ -2303,26 +2350,26 @@ char *filename; 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 */ @@ -2330,9 +2377,9 @@ char *filename; 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; } @@ -2398,7 +2445,7 @@ PP(pp_open_dir) RETPUSHYES; nope: if (!errno) - errno = EBADF; + SETERRNO(EBADF,RMS$_DIR); RETPUSHUNDEF; #else DIE(no_dir_func, "opendir"); @@ -2442,7 +2489,7 @@ PP(pp_readdir) nope: if (!errno) - errno = EBADF; + SETERRNO(EBADF,RMS$_ISI); if (GIMME == G_ARRAY) RETURN; else @@ -2469,7 +2516,7 @@ PP(pp_telldir) RETURN; nope: if (!errno) - errno = EBADF; + SETERRNO(EBADF,RMS$_ISI); RETPUSHUNDEF; #else DIE(no_dir_func, "telldir"); @@ -2492,7 +2539,7 @@ PP(pp_seekdir) RETPUSHYES; nope: if (!errno) - errno = EBADF; + SETERRNO(EBADF,RMS$_ISI); RETPUSHUNDEF; #else DIE(no_dir_func, "seekdir"); @@ -2513,7 +2560,7 @@ PP(pp_rewinddir) RETPUSHYES; nope: if (!errno) - errno = EBADF; + SETERRNO(EBADF,RMS$_ISI); RETPUSHUNDEF; #else DIE(no_dir_func, "rewinddir"); @@ -2533,15 +2580,17 @@ PP(pp_closedir) #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"); @@ -2587,7 +2636,7 @@ PP(pp_wait) if (childpid > 0) pidgone(childpid, argflags); value = (I32)childpid; - statusvalue = (U16)argflags; + statusvalue = FIXSTATUS(argflags); PUSHi(value); RETURN; #else @@ -2608,7 +2657,7 @@ PP(pp_waitpid) childpid = TOPi; childpid = wait4pid(childpid, &argflags, optype); value = (I32)childpid; - statusvalue = (U16)argflags; + statusvalue = FIXSTATUS(argflags); SETi(value); RETURN; #else @@ -2646,10 +2695,12 @@ PP(pp_system) 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 { @@ -2988,7 +3039,7 @@ PP(pp_shmwrite) PUSHi(value); RETURN; #else - pp_semget(ARGS); + return pp_semget(ARGS); #endif } @@ -3013,7 +3064,7 @@ PP(pp_msgsnd) PUSHi(value); RETURN; #else - pp_semget(ARGS); + return pp_semget(ARGS); #endif } @@ -3026,7 +3077,7 @@ PP(pp_msgrcv) PUSHi(value); RETURN; #else - pp_semget(ARGS); + return pp_semget(ARGS); #endif } @@ -3063,7 +3114,7 @@ PP(pp_semctl) } RETURN; #else - pp_semget(ARGS); + return pp_semget(ARGS); #endif } @@ -3076,7 +3127,7 @@ PP(pp_semop) PUSHi(value); RETURN; #else - pp_semget(ARGS); + return pp_semget(ARGS); #endif } @@ -3121,9 +3172,9 @@ PP(pp_ghostent) } 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); } @@ -3136,7 +3187,7 @@ PP(pp_ghostent) #ifdef HOST_NOT_FOUND if (!hent) - statusvalue = (U16)h_errno & 0xffff; + statusvalue = FIXSTATUS(h_errno); #endif if (GIMME != G_ARRAY) { @@ -3731,10 +3782,12 @@ PP(pp_syscall) 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; @@ -3748,8 +3801,10 @@ PP(pp_syscall) 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; } @@ -8,6 +8,7 @@ #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)); @@ -42,6 +43,7 @@ OP * ck_retarget _((OP *op)); 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)); @@ -93,7 +95,7 @@ void do_vecset _((SV* sv)); 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)); @@ -127,7 +129,7 @@ void he_delayfree _((HE* hent)); 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)); @@ -208,7 +210,7 @@ char* my_bcopy _((char* from, char* to, I32 len)); #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 @@ -222,6 +224,8 @@ void my_setenv _((char* nam, char* val)); 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)); @@ -302,7 +306,7 @@ I32 perl_callpv _((char* subname, I32 sp, I32 gimme, I32 hasargs, I32 numargs)); 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)); @@ -381,9 +385,6 @@ OP* scalarvoid _((OP* op)); 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 @@ -268,10 +268,12 @@ PMOP* pm; } 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; @@ -399,7 +401,7 @@ I32 *flagp; if (paren) { if (*regparse == '?') { regparse++; - paren = *nextchar(); + paren = *regparse++; ret = NULL; switch (paren) { case ':': @@ -414,7 +416,7 @@ I32 *flagp; while (*regparse && *regparse != ')') regparse++; if (*regparse != ')') - croak("Sequence (?#... not terminated", *regparse); + croak("Sequence (?#... not terminated"); nextchar(); *flagp = TRYAGAIN; return NULL; @@ -1153,8 +1155,26 @@ nextchar() 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; } @@ -852,10 +852,15 @@ char *prog; 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)) @@ -908,6 +913,7 @@ char *prog; if (regmatch(next)) return 1; /* Couldn't or didn't -- back up. */ + reginput = locinput + ln; if (regrepeat(scan, 1)) { ln++; reginput = locinput + ln; @@ -23,11 +23,6 @@ int n; { 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; } @@ -128,15 +123,22 @@ GV *gv; 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; } @@ -179,15 +181,22 @@ SV **sptr; 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; } @@ -421,15 +430,17 @@ I32 base; 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); @@ -438,15 +449,17 @@ I32 base; } 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); @@ -455,9 +468,9 @@ I32 base; } 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; @@ -572,7 +585,7 @@ I32 base; 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: @@ -61,7 +61,6 @@ static void sv_unglob _((SV* sv)); } \ else \ sv = more_sv(); -#endif static SV* new_sv() @@ -136,6 +135,7 @@ more_sv() sv_arenaroot = sv_root; return new_sv(); } +#endif void sv_report_used() @@ -490,6 +490,10 @@ U32 mt; 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; @@ -623,6 +627,7 @@ U32 mt; break; case SVt_PVCV: SvANY(sv) = new_XPVCV(); + Zero(SvANY(sv), 1, XPVCV); SvPVX(sv) = pv; SvCUR(sv) = cur; SvLEN(sv) = len; @@ -630,15 +635,6 @@ U32 mt; 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(); @@ -669,6 +665,7 @@ U32 mt; break; case SVt_PVFM: SvANY(sv) = new_XPVFM(); + Zero(SvANY(sv), 1, XPVFM); SvPVX(sv) = pv; SvCUR(sv) = cur; SvLEN(sv) = len; @@ -676,10 +673,10 @@ U32 mt; 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; @@ -687,22 +684,7 @@ U32 mt; 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; @@ -1052,8 +1034,12 @@ register SV *sv; 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); @@ -1071,9 +1057,13 @@ register SV *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)); @@ -1094,9 +1084,13 @@ register SV *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)); @@ -1123,7 +1117,7 @@ register SV *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)); } @@ -1141,12 +1135,12 @@ register SV *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); @@ -1162,13 +1156,13 @@ register SV *sv; } 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)); } @@ -1252,11 +1246,11 @@ STRLEN *lp; 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; } @@ -1268,7 +1262,7 @@ STRLEN *lp; } 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); @@ -1291,7 +1285,7 @@ STRLEN *lp; s--; #endif } - else if (SvIOK(sv)) { + else if (SvIOKp(sv)) { if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); SvGROW(sv, 11); @@ -1479,6 +1473,7 @@ register SV *sstr; GvGP(dstr) = gp_ref(GvGP(sstr)); SvTAINT(dstr); GvFLAGS(dstr) &= ~GVf_INTRO; /* one-shot flag */ + SvMULTI_on(dstr); return; } /* FALL THROUGH */ @@ -1529,8 +1524,14 @@ register SV *sstr; 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; @@ -1638,6 +1639,7 @@ register SV *sv; register char *ptr; register STRLEN len; { + assert(len >= 0); if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv) && curcop != &compiling) croak(no_modify); @@ -1751,9 +1753,9 @@ register char *ptr; 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; @@ -1782,11 +1784,11 @@ register char *ptr; { 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); @@ -1830,8 +1832,11 @@ I32 namlen; 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)) @@ -1841,7 +1846,7 @@ I32 namlen; 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); @@ -1906,6 +1911,7 @@ I32 namlen; break; case 't': mg->mg_virtual = &vtbl_taint; + mg->mg_len = 1; break; case 'U': mg->mg_virtual = &vtbl_uvar; @@ -2112,6 +2118,7 @@ register SV *sv; PUSHs(&ref); PUTBACK; perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL); + del_XRV(SvANY(&ref)); } LEAVE; } @@ -2129,10 +2136,10 @@ register SV *sv; 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: @@ -2261,7 +2268,7 @@ STRLEN sv_len(sv) register SV *sv; { - char *s; + char *junk; STRLEN len; if (!sv) @@ -2270,7 +2277,7 @@ register SV *sv; if (SvGMAGICAL(sv)) len = mg_len(sv); else - s = SvPV(sv, len); + junk = SvPV(sv, len); return len; } @@ -2355,12 +2362,14 @@ register FILE *fp; 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) @@ -2383,7 +2392,7 @@ I32 append; } } 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 */ @@ -2409,7 +2418,7 @@ I32 append; } } - if (shortbuffered) { /* oh well, must extend */ + if (shortbuffered) { /* oh well, must extend */ cnt = shortbuffered; shortbuffered = 0; bpx = bp - SvPVX(sv); /* prepare for possible relocation */ @@ -2425,23 +2434,24 @@ I32 append; 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; @@ -2530,8 +2540,7 @@ register SV *sv; 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; @@ -2600,8 +2609,7 @@ register SV *sv; 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; @@ -2876,11 +2884,13 @@ I32 lref; *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); } @@ -2969,7 +2979,7 @@ STRLEN *lp; *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 @@ -3144,6 +3154,7 @@ HV* stash; SvSTASH(ref) = (HV*)SvREFCNT_inc(stash); #ifdef OVERLOAD + SvAMAGIC_off(sv); if (Gv_AMG(stash)) { SvAMAGIC_on(sv); } @@ -100,7 +100,7 @@ struct io { #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 */ @@ -131,6 +131,10 @@ struct io { #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 */ @@ -233,6 +237,7 @@ struct xpvfm { GV * xcv_filegv; long xcv_depth; /* >= 2 indicates recursive call */ AV * xcv_padlist; + CV * xcv_outside; I32 xfm_lines; }; @@ -266,10 +271,12 @@ struct xpvio { #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)) @@ -14,6 +14,8 @@ if ($ARGV[0] eq '-v') { 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`); diff --git a/t/lib/bigintpm.t b/t/lib/bigintpm.t new file mode 100755 index 0000000000..b229d7c67b --- /dev/null +++ b/t/lib/bigintpm.t @@ -0,0 +1,310 @@ +#!./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 diff --git a/t/lib/posix.t b/t/lib/posix.t index bde6e0bbac..8d54df5846 100755 --- a/t/lib/posix.t +++ b/t/lib/posix.t @@ -26,7 +26,7 @@ read($testfd, $buffer, 9) if $testfd > 2; 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"; diff --git a/t/op/overload.t b/t/op/overload.t new file mode 100755 index 0000000000..ab76492141 --- /dev/null +++ b/t/op/overload.t @@ -0,0 +1,259 @@ +#!./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} diff --git a/t/op/rand.t b/t/op/rand.t index 14e6ccfbed..5c0eccf15f 100755 --- a/t/op/rand.t +++ b/t/op/rand.t @@ -1,25 +1,52 @@ #!./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"} + diff --git a/t/op/ref.t b/t/op/ref.t index 73a54ff3c8..38e34f002b 100755 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -177,7 +177,7 @@ print $foo eq foo ? "ok 37\n" : "not ok 37\n"; sub BASEOBJ'doit { local $ref = shift; die "Not an OBJ" unless ref $ref eq OBJ; - $ref->{shift}; + $ref->{shift()}; } package UNIVERSAL; diff --git a/t/op/write.t b/t/op/write.t index bfb4785155..d14cef3cd6 100755 --- a/t/op/write.t +++ b/t/op/write.t @@ -47,6 +47,9 @@ if (`cat Op_write.tmp` eq $right) else { print "not ok 1\n"; } +$fox = 'wolfishness'; +my $fox = 'foxiness'; # Test a lexical variable. + format OUT2 = the quick brown @<< $fox @@ -61,7 +64,6 @@ now @<<the@>>>> for all@|||||men to come @<<<< 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'; diff --git a/t/re_tests b/t/re_tests index b1a5ef28cf..2ac666ab38 100644 --- a/t/re_tests +++ b/t/re_tests @@ -1,274 +1,3 @@ -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 @@ -50,16 +50,20 @@ taint_env() 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}"); } } @@ -116,8 +116,6 @@ static int uni _((I32 f, char *s)); /* 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; @@ -139,13 +137,24 @@ char *what; 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 @@ -478,15 +487,18 @@ register char *s; 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 ); + } } } @@ -503,6 +515,8 @@ SV *sv; return sv; s = SvPV_force(sv, len); + if (SvIVX(sv) == -1) + return sv; send = s + len; while (s < send && *s != '\\') s++; @@ -645,12 +659,11 @@ char *start; 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) ? "" : ""; @@ -675,6 +688,15 @@ char *start; 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 == '$') { @@ -685,12 +707,6 @@ char *start; } if (*s == '\\' && s+1 < send) { s++; -#ifdef NOTDEF - if (*s == delim) { - *d++ = *s++; - continue; - } -#endif if (*s && strchr(leave, *s)) { *d++ = '\\'; *d++ = *s++; @@ -978,8 +994,10 @@ cryptswitch_add(funcp) } -static char* exp_name[] = +#ifdef DEBUGGING + static char* exp_name[] = { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" }; +#endif extern int yychar; /* last token */ @@ -1219,9 +1237,13 @@ yylex() 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: @@ -1275,8 +1297,14 @@ yylex() 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; @@ -1303,24 +1331,28 @@ yylex() 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; + } } } } @@ -1357,9 +1389,22 @@ yylex() 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); @@ -1388,7 +1433,7 @@ yylex() 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; } } @@ -1407,8 +1452,10 @@ yylex() 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); @@ -1459,7 +1506,7 @@ yylex() 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); @@ -1549,8 +1596,24 @@ yylex() 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; @@ -1614,6 +1677,11 @@ yylex() lex_state = LEX_INTERPEND; } } + if (lex_brackets < lex_fakebrack) { + bufptr = s; + lex_fakebrack = 0; + return yylex(); /* ignore fake brackets */ + } force_next('}'); TOKEN(';'); case '&': @@ -1659,7 +1727,9 @@ yylex() 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; @@ -1718,7 +1788,7 @@ yylex() 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) { @@ -1760,8 +1830,9 @@ yylex() /* 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] = '$'; @@ -1779,12 +1850,13 @@ yylex() 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; @@ -1808,13 +1880,13 @@ yylex() } 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 == '{') @@ -1825,8 +1897,15 @@ yylex() 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); @@ -1849,7 +1928,7 @@ yylex() 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); @@ -1914,7 +1993,8 @@ yylex() 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; @@ -1987,6 +2067,8 @@ yylex() 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); @@ -2027,10 +2109,25 @@ yylex() 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 && @@ -2051,6 +2148,7 @@ yylex() 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 */ @@ -2100,6 +2198,8 @@ yylex() (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); @@ -2111,12 +2211,10 @@ yylex() /* 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; } } @@ -2154,13 +2252,18 @@ yylex() 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 && @@ -2174,9 +2277,20 @@ yylex() /* 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); } @@ -2195,7 +2309,7 @@ yylex() /*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(); @@ -2230,6 +2344,7 @@ yylex() 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) @@ -2292,9 +2407,11 @@ yylex() 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: @@ -2725,8 +2842,11 @@ yylex() 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); @@ -3003,9 +3123,11 @@ yylex() 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: @@ -3751,10 +3873,10 @@ I32 ck_uni; { 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; @@ -3786,11 +3908,10 @@ I32 ck_uni; 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++; } @@ -3799,19 +3920,27 @@ I32 ck_uni; 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; @@ -3821,6 +3950,12 @@ I32 ck_uni; 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 */ @@ -3832,99 +3967,6 @@ I32 ck_uni; 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; @@ -4045,6 +4087,7 @@ register PMOP *pm; 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 && @@ -4065,6 +4108,7 @@ register PMOP *pm; (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; } @@ -4164,17 +4208,21 @@ register char *s; 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; @@ -4582,6 +4630,8 @@ int start_subparse() { int oldsavestack_ix = savestack_ix; + CV* outsidecv = compcv; + AV* comppadlist; save_I32(&subline); save_item(subname); @@ -4589,9 +4639,15 @@ start_subparse() 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(); @@ -4601,8 +4657,16 @@ start_subparse() 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; } @@ -4611,7 +4675,10 @@ yywarn(s) char *s; { --error_count; - return yyerror(s); + in_eval |= 2; + yyerror(s); + in_eval &= ~2; + return 0; } int @@ -4656,7 +4723,9 @@ char *s; 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); @@ -361,6 +361,8 @@ I32 iflag; 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; @@ -746,8 +748,20 @@ long a1, a2, a3, a4; { 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); @@ -756,8 +770,12 @@ long a1, a2, a3, a4; (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*/ @@ -766,13 +784,28 @@ char *pat; 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) */ @@ -854,6 +887,9 @@ croak(pat, va_alist) { va_list args; char *message; + HV *stash; + GV *gv; + CV *cv; #ifdef I_STDARG va_start(args, pat); @@ -862,6 +898,15 @@ croak(pat, va_alist) #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); @@ -870,8 +915,12 @@ croak(pat, va_alist) (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 @@ -886,6 +935,9 @@ warn(pat,va_alist) { va_list args; char *message; + HV *stash; + GV *gv; + CV *cv; #ifdef I_STDARG va_start(args, pat); @@ -895,11 +947,22 @@ warn(pat,va_alist) 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) */ @@ -1069,19 +1132,15 @@ char *pat, *args; #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; @@ -1094,8 +1153,12 @@ short s; } long -htonl(l) +#ifndef CAN_PROTOTYPE +my_htonl(l) register long l; +#else +my_htonl(long l) +#endif { union { long result; @@ -1124,8 +1187,12 @@ register long l; } long -ntohl(l) +#ifndef CAN_PROTOTYPE +my_ntohl(l) register long l; +#else +my_ntohl(long l) +#endif { union { long l; @@ -1305,7 +1372,7 @@ char *mode; #endif /* !DOSISH */ -#ifdef NOTDEF +#ifdef DUMP_FDS dump_fds(s) char *s; { @@ -1361,7 +1428,7 @@ FILE *ptr; int pid; svp = av_fetch(fdpid,fileno(ptr),TRUE); - pid = SvIVX(*svp); + pid = (int)SvIVX(*svp); SvREFCNT_dec(*svp); *svp = &sv_undef; fclose(ptr); @@ -1371,7 +1438,9 @@ FILE *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); @@ -1395,7 +1464,7 @@ int flags; 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; } } @@ -1408,7 +1477,7 @@ int flags; 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; } } @@ -1589,10 +1658,13 @@ I32 *retlen; 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; } diff --git a/vms/makefile. b/vms/Makefile index bc5a58c46f..9a953106a6 100644 --- a/vms/makefile. +++ b/vms/Makefile @@ -3,7 +3,7 @@ #> 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 @@ -15,20 +15,24 @@ #### 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 = @@ -38,11 +42,11 @@ XTRACCFLAGS = /Include=[]/Object=$(O) 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. @@ -54,20 +58,26 @@ SOCKCLIS = 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. #### @@ -78,87 +88,113 @@ h3 = opcode.h, patchlevel.h, perl.h, perly.h, pp.h, proto.h, regcomp.h 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; ; @@ -180,8 +216,103 @@ perly$(O) : perly.c, perly.h, $(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 @@ -336,28 +467,6 @@ hv$(O) : scope.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 @@ -380,6 +489,28 @@ mg$(O) : scope.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 @@ -424,6 +555,72 @@ pp$(O) : scope.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 @@ -710,6 +907,7 @@ $(CRTL) : $(MAKEFILE) 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 @@ -724,11 +922,17 @@ 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;* @@ -741,24 +945,31 @@ clean : tidy - 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;* diff --git a/vms/config.vms b/vms/config.vms index 0c2c4f494c..74afb23dc7 100644 --- a/vms/config.vms +++ b/vms/config.vms @@ -39,7 +39,11 @@ * 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. @@ -538,6 +542,14 @@ */ #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. @@ -570,7 +582,7 @@ * 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 @@ -663,7 +675,7 @@ #undef PWCHANGE /**/ #undef PWCLASS /**/ #undef PWEXPIRE /**/ -#undef PWCOMMENT /**/ +#define PWCOMMENT /**/ /* I_STDDEF: * This symbol, if defined, indicates that <stddef.h> exists and should @@ -789,7 +801,7 @@ * 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 @@ -1030,7 +1042,7 @@ * 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 @@ -1161,6 +1173,13 @@ */ #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 @@ -1251,7 +1270,7 @@ /* 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 diff --git a/vms/descrip.mms b/vms/descrip.mms index bd30a87095..1af44baa6c 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -1,5 +1,5 @@ # 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 @@ -39,37 +39,43 @@ #### 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 = @@ -83,7 +89,7 @@ LIBS1 = $(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) @@ -92,6 +98,9 @@ LIBS2 = Sys$Share:VAXCRTL.Exe/Shareable .endif .endif + +#: >>>>> Configuration options <<<<< +#: __DEBUG__: builds images with full VMS debugger support .ifdef __DEBUG__ DBGCCFLAGS = /List/Debug/NoOpt$(DBGSPECFLAGS) DBGLINKFLAGS = /Debug/Map/Full/Cross @@ -102,7 +111,9 @@ DBGLINKFLAGS = /NoMap 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 @@ -124,20 +135,26 @@ SOCKHLIS = 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. #### @@ -148,96 +165,122 @@ h3 = opcode.h, patchlevel.h, perl.h, perly.h, pp.h, proto.h, regcomp.h 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) @@ -251,8 +294,8 @@ $(SOCKH) : [.vms]$(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; ; @@ -274,8 +317,108 @@ perly$(O) : perly.c, perly.h, $(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 @@ -430,28 +573,6 @@ hv$(O) : scope.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 @@ -474,6 +595,28 @@ mg$(O) : scope.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 @@ -518,6 +661,72 @@ pp$(O) : scope.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 @@ -804,6 +1013,7 @@ $(CRTL) : $(MAKEFILE) 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 @@ -818,11 +1028,17 @@ 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;* @@ -835,24 +1051,31 @@ clean : tidy - 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;* diff --git a/vms/ext/Filespec.pm b/vms/ext/Filespec.pm new file mode 100644 index 0000000000..35c8365c4c --- /dev/null +++ b/vms/ext/Filespec.pm @@ -0,0 +1,323 @@ +# 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 '[-]'); } +} diff --git a/vms/ext/MM_VMS.pm b/vms/ext/MM_VMS.pm index 3ef0233d9a..f861d83021 100644 --- a/vms/ext/MM_VMS.pm +++ b/vms/ext/MM_VMS.pm @@ -11,6 +11,818 @@ package ExtUtils::MM_VMS; 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; diff --git a/vms/ext/VMS/stdio/Makefile.PL b/vms/ext/VMS/stdio/Makefile.PL new file mode 100644 index 0000000000..d6683b4af6 --- /dev/null +++ b/vms/ext/VMS/stdio/Makefile.PL @@ -0,0 +1,3 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( 'VERSION' => '1.0' ); diff --git a/vms/ext/VMS/stdio/stdio.pm b/vms/ext/VMS/stdio/stdio.pm new file mode 100644 index 0000000000..d8b4ec21ec --- /dev/null +++ b/vms/ext/VMS/stdio/stdio.pm @@ -0,0 +1,78 @@ +# 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; diff --git a/vms/ext/VMS/stdio/stdio.xs b/vms/ext/VMS/stdio/stdio.xs new file mode 100644 index 0000000000..367f489bf5 --- /dev/null +++ b/vms/ext/VMS/stdio/stdio.xs @@ -0,0 +1,109 @@ +/* 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); diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl index 120c355cd7..043faccb09 100644 --- a/vms/gen_shrfls.pl +++ b/vms/gen_shrfls.pl @@ -6,13 +6,18 @@ # 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. @@ -29,7 +34,7 @@ # (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)? # # Author: Charles Bailey bailey@genetics.upenn.edu -# Revised: 21-Sep-1994 +# Revised: 01-Mar-1995 require 5.000; @@ -58,6 +63,15 @@ else { ($cpp_file) = ($cc_cmd =~ /~~NOCC~~(.*)/) } $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; @@ -66,14 +80,14 @@ print "\$isvax: \\$isvax\\\n" if $debug; 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}++; } } @@ -81,11 +95,11 @@ sub scan_var { 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}++ } } @@ -101,28 +115,28 @@ else { 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; @@ -130,27 +144,34 @@ while (<DATA>) { 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"; @@ -158,6 +179,7 @@ foreach $var (sort keys %vars) { $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. @@ -173,31 +195,51 @@ foreach $func (sort keys %funcs) { 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 diff --git a/vms/genconfig.pl b/vms/genconfig.pl index 18bc9851db..ca15aa7943 100644 --- a/vms/genconfig.pl +++ b/vms/genconfig.pl @@ -3,9 +3,10 @@ # # 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 @@ -26,11 +27,9 @@ EndOfGasp $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 @@ -39,6 +38,12 @@ print <<EndOfIntro; 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_/; } @@ -59,10 +64,11 @@ while (<IN>) { $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; @@ -70,8 +76,34 @@ while (<DATA>) { 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__ @@ -85,7 +117,15 @@ __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 @@ -100,13 +140,11 @@ signal_t=void 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) diff --git a/vms/mms2make.pl b/vms/mms2make.pl index 54db616c86..6fdc924081 100644 --- a/vms/mms2make.pl +++ b/vms/mms2make.pl @@ -16,6 +16,8 @@ # 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; @@ -83,6 +85,22 @@ while (<INFIL>) { 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; diff --git a/vms/perlvms.pod b/vms/perlvms.pod index 77ec503f61..e7f811e0a8 100644 --- a/vms/perlvms.pod +++ b/vms/perlvms.pod @@ -1,84 +1,203 @@ -=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.. @@ -99,7 +218,14 @@ the behavior of glob expansion performed by Unix shells.) 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, @@ -110,30 +236,31 @@ variables" of the same names. The key C<default> returns the 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, @@ -141,12 +268,12 @@ perl functions were implemented in the VMS port of perl 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 @@ -154,18 +281,16 @@ undefined behavior (rarely, we hope): 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, @@ -179,86 +304,136 @@ your copy of perl: =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. diff --git a/vms/sockadapt.c b/vms/sockadapt.c index fc42bcc5a4..9867d536a1 100644 --- a/vms/sockadapt.c +++ b/vms/sockadapt.c @@ -1,14 +1,14 @@ /* 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" @@ -25,19 +25,8 @@ 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); diff --git a/vms/sockadapt.h b/vms/sockadapt.h index 60890bddce..0d56285750 100644 --- a/vms/sockadapt.h +++ b/vms/sockadapt.h @@ -2,35 +2,57 @@ * * 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 { @@ -39,16 +61,3 @@ 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 # */ -}; diff --git a/vms/test.com b/vms/test.com index 3e42a11474..a23245057f 100644 --- a/vms/test.com +++ b/vms/test.com @@ -6,7 +6,12 @@ $ $! 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.;* @@ -56,7 +61,7 @@ $ Macro/NoDebug/Object=Echo.Obj Sys$Input .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. @@ -1,14 +1,18 @@ -/* 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> @@ -16,6 +20,7 @@ #include <libdef.h> #include <lib$routines.h> #include <lnmdef.h> +#include <prvdef.h> #include <psldef.h> #include <rms.h> #include <shrdef.h> @@ -23,25 +28,44 @@ #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 @@ -57,47 +81,33 @@ my_getenv(char *lnm) { 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() */ /*}}}*/ @@ -121,17 +131,18 @@ my_setenv(char *lnm,char *eqv) 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() */ @@ -146,7 +157,7 @@ do_rmdir(char *name) { 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; @@ -170,24 +181,24 @@ kill_file(char *name) { 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? */ @@ -195,15 +206,15 @@ kill_file(char *name) * 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 */ @@ -212,7 +223,7 @@ kill_file(char *name) /* 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)) @@ -231,8 +242,8 @@ kill_file(char *name) if (aclsts & 1) aclsts = fndsts; } if (!(aclsts & 1)) { - errno = EVMSERR; - vaxc$errno = aclsts; + set_errno(EVMSERR); + set_vaxc_errno(aclsts); return -1; } @@ -241,6 +252,149 @@ kill_file(char *name) } /* 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) { @@ -253,12 +407,12 @@ 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() */ @@ -267,18 +421,52 @@ create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc) 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); @@ -289,6 +477,7 @@ popen_completion_ast(unsigned long int unused) 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 */ @@ -301,8 +490,6 @@ my_popen(char *cmd, char *mode) New(7001,info,1,struct pipe_details); - info->completion=0; /* I assume this will remain 0 until terminates */ - /* create mailbox */ create_mbx(&chan,&namdsc); @@ -310,7 +497,7 @@ my_popen(char *cmd, char *mode) info->fp=fopen(mbxname, mode); /* give up other channel onto it */ - _cksts(sys$dassgn(chan)); + _ckvmssts(sys$dassgn(chan)); if (!info->fp) return Nullfp; @@ -318,16 +505,25 @@ my_popen(char *cmd, char *mode) 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; @@ -339,46 +535,41 @@ my_popen(char *cmd, char *mode) 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(); } @@ -389,19 +580,21 @@ waitpid(unsigned long int pid, int *statusp, int flags) 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, @@ -413,7 +606,6 @@ waitpid(unsigned long int pid, int *statusp, int flags) } } /* end of waitpid() */ -#endif /*}}}*/ /*}}}*/ /*}}}*/ @@ -443,7 +635,7 @@ my_gconvert(double val, int ndig, int trail, char *buf) ** 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 @@ -466,21 +658,41 @@ my_gconvert(double val, int ndig, int trail, char *buf) ** 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 */ @@ -489,42 +701,44 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) 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. */ @@ -533,19 +747,20 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } 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; @@ -555,51 +770,82 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) } 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; @@ -610,8 +856,8 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) 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; @@ -629,26 +875,36 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) { 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; @@ -661,30 +917,36 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) } 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 */ @@ -695,30 +957,21 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts) 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; @@ -741,7 +994,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts) 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; @@ -771,7 +1024,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts) } 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++; @@ -793,7 +1046,8 @@ static char *do_tounixspec(char *spec, char *buf, int ts) *(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; } } @@ -818,7 +1072,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts) } 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++; @@ -841,32 +1095,84 @@ char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); } /*{{{ 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'; @@ -884,7 +1190,7 @@ static char *do_tovmspath(char *path, char *buf, int ts) { 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; @@ -913,7 +1219,7 @@ static char *do_tounixpath(char *path, char *buf, int ts) { 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; @@ -1025,7 +1331,6 @@ getredirection(int *ac, char ***av) 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 @@ -1050,8 +1355,8 @@ getredirection(int *ac, char ***av) { 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; @@ -1065,8 +1370,8 @@ getredirection(int *ac, char ***av) { 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; @@ -1085,8 +1390,8 @@ getredirection(int *ac, char ***av) 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; } @@ -1104,11 +1409,11 @@ getredirection(int *ac, char ***av) 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; } @@ -1116,8 +1421,8 @@ getredirection(int *ac, char ***av) { 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]; @@ -1147,8 +1452,8 @@ getredirection(int *ac, char ***av) { 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); } @@ -1168,10 +1473,10 @@ getredirection(int *ac, char ***av) 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); @@ -1180,24 +1485,37 @@ getredirection(int *ac, char ***av) 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"); @@ -1231,9 +1549,8 @@ static void expand_wild_cards(char *item, 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; @@ -1241,7 +1558,7 @@ int had_directory; 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; @@ -1253,7 +1570,7 @@ 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; @@ -1304,9 +1621,9 @@ unsigned long int zero = 0; 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]; @@ -1334,14 +1651,7 @@ static void sig_child(int chan) 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, @@ -1356,10 +1666,7 @@ static void pipe_and_fork(char **cmargv) $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]); @@ -1377,20 +1684,16 @@ static void pipe_and_fork(char **cmargv) 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); } } @@ -1404,7 +1707,7 @@ static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID"); 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) @@ -1415,23 +1718,14 @@ unsigned long int flags = 17, one = 1; } 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 @@ -1445,84 +1739,6 @@ unsigned long int flags = 17, one = 1; /*}}}*/ /***** 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 @@ -1567,57 +1783,6 @@ trim_unixpath(char *template, char *fspec) } /* 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. @@ -1728,15 +1893,15 @@ collectversions(dd) 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() */ @@ -1750,7 +1915,6 @@ readdir(DIR *dd) { 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. */ @@ -1760,7 +1924,8 @@ readdir(DIR *dd) 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'; @@ -1768,11 +1933,11 @@ readdir(DIR *dd) *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; @@ -1801,7 +1966,6 @@ void seekdir(DIR *dd, long count) { int vms_wantversions; - unsigned long int tmpsts; /* If we haven't done anything yet... */ if (dd->count == 0) @@ -1810,7 +1974,7 @@ seekdir(DIR *dd, long count) /* 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(). */ @@ -1858,7 +2022,7 @@ static int vfork_called; int my_vfork() { - vfork_called = 1; + vfork_called++; return vfork(); } /*}}}*/ @@ -1872,7 +2036,8 @@ setup_argstr(SV *really, SV **mark, SV **sp, char **argstr) register SV **idx; idx = mark; - if (really && *(tmps = SvPV(really,rlen))) { + tmps = SvPV(really,rlen); + if (really && *tmps) { cmdlen += rlen + 1; idx++; } @@ -1937,8 +2102,8 @@ setup_cmddsc(char *cmd, struct dsc$descriptor_s *cmddsc, int check_img) 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'; @@ -1961,13 +2126,17 @@ vms_do_aexec(SV *really,SV **mark,SV **sp) 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; @@ -1980,16 +2149,23 @@ vms_do_exec(char *cmd) { 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(); @@ -2008,8 +2184,8 @@ do_aspawn(SV *really,SV **mark,SV **sp) { 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; @@ -2023,14 +2199,19 @@ do_spawn(char *cmd) 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; @@ -2062,34 +2243,639 @@ my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest) } /* 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 */ diff --git a/vms/vmsish.h b/vms/vmsish.h index ec0dbde2eb..ce6829060e 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -2,26 +2,53 @@ * * 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" @@ -57,6 +84,13 @@ # 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 { @@ -107,6 +141,82 @@ typedef struct _dirdesc { #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; @@ -119,12 +229,11 @@ typedef struct _dirdesc { */ 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 *)); @@ -145,32 +254,31 @@ void seekdir _((DIR *, long)); 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 */ diff --git a/vms/writemain.pl b/vms/writemain.pl index 38b6670b10..0208313288 100644 --- a/vms/writemain.pl +++ b/vms/writemain.pl @@ -1,7 +1,11 @@ #!./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 = ''; } @@ -28,23 +32,30 @@ if (!$ok) { } -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" + } } } diff --git a/x2p/Makefile.SH b/x2p/Makefile.SH index 52a44b5b59..393a335e0b 100755 --- a/x2p/Makefile.SH +++ b/x2p/Makefile.SH @@ -112,7 +112,7 @@ a2p.o: a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h str.h has $(CCCMD) $(LARGE) a2p.c clean: - rm -f a2p *.o + rm -f a2p *.o realclean: clean rm -f *.orig core $(addedbyconf) all malloc.c @@ -139,6 +139,7 @@ shlist: 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/' @@ -1,13 +1,7 @@ #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 $ * @@ -26,7 +20,7 @@ int root; 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 @@ -1920,9 +1914,12 @@ char *yyrule[] = { #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 @@ -1944,9 +1941,8 @@ YYSTYPE yyvs[YYSTACKSIZE]; #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 @@ -1984,8 +1980,8 @@ yyloop: 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 } @@ -1994,8 +1990,8 @@ yyloop: { #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) { @@ -2035,8 +2031,8 @@ yyinrecovery: { #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) { @@ -2050,8 +2046,8 @@ yyinrecovery: { #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; @@ -2068,8 +2064,8 @@ yyinrecovery: 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); @@ -2078,8 +2074,8 @@ yyinrecovery: 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]; @@ -2611,7 +2607,7 @@ case 137: #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; @@ -2621,8 +2617,8 @@ break; { #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; @@ -2636,8 +2632,8 @@ break; 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 } @@ -2651,8 +2647,8 @@ break; 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) { diff --git a/x2p/a2py.c b/x2p/a2py.c index c08b06a723..54bdce0aad 100644 --- a/x2p/a2py.c +++ b/x2p/a2py.c @@ -17,6 +17,13 @@ char *filename; char *myname; int checkers = 0; + +int oper0(); +int oper1(); +int oper2(); +int oper3(); +int oper4(); +int oper5(); STR *walk(); #ifdef OS2 @@ -187,6 +194,7 @@ register char **env; int idtype; +int yylex() { register char *s = bufptr; @@ -871,8 +879,10 @@ register char *s; return s; } +int string(ptr,len) char *ptr; +int len; { int retval = mop; @@ -887,6 +897,7 @@ char *ptr; return retval; } +int oper0(type) int type; { @@ -900,6 +911,7 @@ int type; return retval; } +int oper1(type,arg1) int type; int arg1; @@ -915,6 +927,7 @@ int arg1; return retval; } +int oper2(type,arg1,arg2) int type; int arg1; @@ -932,6 +945,7 @@ int arg2; return retval; } +int oper3(type,arg1,arg2,arg3) int type; int arg1; @@ -951,6 +965,7 @@ int arg3; return retval; } +int oper4(type,arg1,arg2,arg3,arg4) int type; int arg1; @@ -972,6 +987,7 @@ int arg4; return retval; } +int oper5(type,arg1,arg2,arg3,arg4,arg5) int type; int arg1; @@ -1025,6 +1041,7 @@ int branch; } } +int bl(arg,maybe) int arg; int maybe; @@ -1165,6 +1182,7 @@ putone() fputs(tokenbuf,stdout); } +int numary(arg) int arg; { @@ -1179,6 +1197,7 @@ int arg; return arg; } +int rememberargs(arg) int arg; { @@ -1201,6 +1220,7 @@ int arg; return arg; } +int aryrefarg(arg) int arg; { @@ -1215,6 +1235,7 @@ int arg; return arg; } +int fixfargs(name,arg,prevargs) int name; int arg; @@ -1253,6 +1274,7 @@ int prevargs; return numargs; } +int fixrargs(name,arg,prevargs) char *name; int arg; diff --git a/x2p/walk.c b/x2p/walk.c index 0d651988fb..6f425a4845 100644 --- a/x2p/walk.c +++ b/x2p/walk.c @@ -12,6 +12,12 @@ #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; @@ -1554,7 +1560,7 @@ sub Pick {\n\ return str; } -void +static void tab(str,lvl) register STR *str; register int lvl; @@ -1567,7 +1573,7 @@ register int lvl; str_cat(str," "); } -void +static void fixtab(str,lvl) register STR *str; register int lvl; @@ -1587,7 +1593,7 @@ register int lvl; tab(str,lvl); } -void +static void addsemi(str) register STR *str; { @@ -2056,7 +2062,7 @@ int *numericptr; return 1; } -void +static void numericize(node) register int node; { |