diff options
| author | Gurusamy Sarathy <gsar@cpan.org> | 1998-01-30 10:44:38 +0000 |
|---|---|---|
| committer | Gurusamy Sarathy <gsar@cpan.org> | 1998-01-30 10:44:38 +0000 |
| commit | 6b6eec5b869ecabb6b96b0d84c01808aecc78d84 (patch) | |
| tree | be188f6c9db63d9911541036c2e15a4d6b607b5d | |
| parent | 65c6b2907476177557b1357ec8e2bda83f220e47 (diff) | |
| parent | 875e910638b0552c0eec0bc83eb2d5b3f85f5df5 (diff) | |
| download | perl-6b6eec5b869ecabb6b96b0d84c01808aecc78d84.tar.gz | |
[asperl] initial merge of latest win32 branch into ASPerl
p4raw-id: //depot/asperl@445
| -rwxr-xr-x | Configure | 21 | ||||
| -rw-r--r-- | MANIFEST | 8 | ||||
| -rw-r--r-- | README.win32 | 15 | ||||
| -rw-r--r-- | av.c | 223 | ||||
| -rw-r--r-- | av.h | 11 | ||||
| -rw-r--r-- | deb.c | 2 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | ext/DB_File/DB_File.pm | 6 | ||||
| -rw-r--r-- | ext/GDBM_File/typemap | 4 | ||||
| -rw-r--r-- | ext/NDBM_File/typemap | 4 | ||||
| -rw-r--r-- | ext/ODBM_File/typemap | 4 | ||||
| -rw-r--r-- | ext/SDBM_File/typemap | 4 | ||||
| -rw-r--r-- | global.sym | 2 | ||||
| -rw-r--r-- | gv.c | 6 | ||||
| -rw-r--r-- | hints/dec_osf.sh | 56 | ||||
| -rw-r--r-- | hv.c | 68 | ||||
| -rwxr-xr-x | installperl | 8 | ||||
| -rw-r--r-- | lib/ExtUtils/MM_Unix.pm | 29 | ||||
| -rw-r--r-- | lib/ExtUtils/typemap | 48 | ||||
| -rw-r--r-- | lib/File/DosGlob.pm | 35 | ||||
| -rw-r--r-- | lib/Getopt/Long.pm | 1148 | ||||
| -rw-r--r-- | lib/Tie/Array.pm | 262 | ||||
| -rw-r--r-- | lib/blib.pm | 1 | ||||
| -rw-r--r-- | mg.c | 127 | ||||
| -rw-r--r-- | op.c | 38 | ||||
| -rw-r--r-- | os2/OS2/PrfDB/typemap | 2 | ||||
| -rw-r--r-- | perl.h | 11 | ||||
| -rw-r--r-- | perl_exp.SH | 7 | ||||
| -rw-r--r-- | perldir.h | 12 | ||||
| -rw-r--r-- | perlenv.h | 6 | ||||
| -rw-r--r-- | perllio.h | 29 | ||||
| -rw-r--r-- | perlmem.h | 6 | ||||
| -rw-r--r-- | perlproc.h | 47 | ||||
| -rw-r--r-- | perlsock.h | 111 | ||||
| -rw-r--r-- | pod/perlfunc.pod | 1 | ||||
| -rw-r--r-- | pod/perlguts.pod | 185 | ||||
| -rw-r--r-- | pod/perlhist.pod | 451 | ||||
| -rw-r--r-- | pod/perltie.pod | 23 | ||||
| -rw-r--r-- | pod/perlxs.pod | 7 | ||||
| -rw-r--r-- | pod/perlxstut.pod | 10 | ||||
| -rw-r--r-- | pp.c | 288 | ||||
| -rw-r--r-- | pp.h | 4 | ||||
| -rw-r--r-- | pp_ctl.c | 771 | ||||
| -rw-r--r-- | pp_hot.c | 61 | ||||
| -rw-r--r-- | pp_sys.c | 154 | ||||
| -rw-r--r-- | proto.h | 137 | ||||
| -rw-r--r-- | regcomp.h | 8 | ||||
| -rw-r--r-- | regexec.c | 4 | ||||
| -rw-r--r-- | scope.c | 15 | ||||
| -rw-r--r-- | sv.c | 10 | ||||
| -rw-r--r-- | sv.h | 34 | ||||
| -rw-r--r-- | t/harness | 1 | ||||
| -rwxr-xr-x | t/lib/tie-push.t | 24 | ||||
| -rwxr-xr-x | t/lib/tie-stdarray.t | 12 | ||||
| -rwxr-xr-x | t/lib/tie-stdpush.t | 10 | ||||
| -rwxr-xr-x | t/op/avhv.t | 29 | ||||
| -rwxr-xr-x | t/op/push.t | 3 | ||||
| -rw-r--r-- | t/op/re_tests | 3 | ||||
| -rwxr-xr-x | t/op/tiearray.t | 210 | ||||
| -rwxr-xr-x | t/pragma/locale.t | 8 | ||||
| -rw-r--r-- | toke.c | 8 | ||||
| -rw-r--r-- | universal.c | 3 | ||||
| -rw-r--r-- | util.c | 5 | ||||
| -rw-r--r-- | utils/perldoc.PL | 12 | ||||
| -rw-r--r-- | vms/config.vms | 67 | ||||
| -rw-r--r-- | vms/descrip.mms | 793 | ||||
| -rw-r--r-- | vms/gen_shrfls.pl | 4 | ||||
| -rw-r--r-- | vms/genconfig.pl | 27 | ||||
| -rw-r--r-- | vms/perly_c.vms | 1 | ||||
| -rw-r--r-- | vms/vms.c | 8 | ||||
| -rw-r--r-- | vms/vmsish.h | 2 | ||||
| -rw-r--r-- | win32/Makefile | 83 | ||||
| -rw-r--r-- | win32/bin/perlglob.pl | 53 | ||||
| -rw-r--r-- | win32/config.bc | 7 | ||||
| -rw-r--r-- | win32/config.gc | 13 | ||||
| -rw-r--r-- | win32/config.vc | 13 | ||||
| -rw-r--r-- | win32/config_sh.PL | 11 | ||||
| -rw-r--r-- | win32/makefile.mk | 99 | ||||
| -rw-r--r-- | win32/win32.h | 18 | ||||
| -rw-r--r-- | x2p/a2p.h | 25 | ||||
| -rw-r--r-- | x2p/a2py.c | 14 | ||||
| -rw-r--r-- | x2p/s2p.PL | 44 |
82 files changed, 3865 insertions, 2271 deletions
@@ -1825,7 +1825,7 @@ EOM osf1|mls+) case "$5" in alpha) osname=dec_osf - osvers=`echo "$3" | sed 's/^[vt]//'` + osvers=`echo "$3" | sed 's/^[xvt]//'` ;; hp*) osname=hp_osf1 ;; mips) osname=mips_osf1 ;; @@ -9327,7 +9327,7 @@ EOM gethbadd_addr_type="$ans" # Remove the "const" if needed. - gethbadd_addr_type=`echo $gethbadd_addr_type | sed 's/^const //'` + gethbadd_addr_type=`echo "$gethbadd_addr_type" | sed 's/^const //'` rp='What is the type for the 2nd argument to gethostbyaddr ?' dflt="Size_t" @@ -9966,11 +9966,16 @@ int main() { exit(0); } EOCP - : Compile and link separately because the used cc might not be - : able to link the right CRT and libs for pthreading. - if $cc $ccflags -c try.c >/dev/null 2>&1 && - $ld $ldflags -o try try$obj_ext $libs >/dev/null 2>&1; then + if $cc $ccflags $ldflags -o try try.c $libs >/dev/null 2>&1; then yyy=`./try` + case "$yyy" in + detached) + echo "Nope, they aren't." + ;; + *) + echo "Yup, they are." + ;; + esac else echo "(I can't execute the test program--assuming they are.)" yyy=joinable @@ -9978,11 +9983,9 @@ EOCP case "$yyy" in detached) val="$undef" - echo "Nope, they aren't." ;; *) val="$define" - echo "Yup, they are." ;; esac set d_pthreads_created_joinable @@ -9990,7 +9993,7 @@ EOCP $rm -f try try.* fi else - d_pthreads_created_joinable=$undef + d_pthreads_created_joinable="$undef" fi : see whether the various POSIXish _yields exist within given cccmd @@ -426,6 +426,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/Text/Wrap.pm Paragraph formatter +lib/Tie/Array.pm Base class for tied arrays lib/Tie/Hash.pm Base class for tied hashes lib/Tie/RefHash.pm Base class for tied hashes with references as keys lib/Tie/Scalar.pm Base class for tied scalars @@ -604,6 +605,7 @@ pod/perlfaq9.pod Frequently Asked Questions, Part 9 pod/perlform.pod Format info pod/perlfunc.pod Function info pod/perlguts.pod Internals info +pod/perlhist.pod The Perl history records pod/perlipc.pod IPC info pod/perllocale.pod Locale support info pod/perllol.pod How to use lists of lists @@ -735,7 +737,9 @@ t/lib/soundex.t See if Soundex works t/lib/symbol.t See if Symbol works t/lib/texttabs.t See if Text::Tabs works t/lib/textwrap.t See if Text::Wrap works -t/lib/timelocal.t See if Time::Local works +t/lib/tie-push.t Test for Tie::Array +t/lib/tie-stdarray.t Test for Tie::StdArray +t/lib/tie-stdpush.t Test for Tie::StdArray t/lib/thread.t Basic test of threading (skipped if no threads) t/lib/trig.t See if Math::Trig works t/op/append.t See if . works @@ -800,6 +804,7 @@ t/op/substr.t See if substr works t/op/sysio.t See if sysread and syswrite work t/op/taint.t See if tainting works t/op/tie.t See if tie/untie functions work +t/op/tiearray.t See if tied arrays work t/op/time.t See if time functions work t/op/undef.t See if undef works t/op/universal.t See if UNIVERSAL class works @@ -871,6 +876,7 @@ win32/Makefile Win32 makefile for NMAKE (Visual C++ build) win32/TEST Win32 port win32/autosplit.pl Win32 port win32/bin/network.pl Win32 port +win32/bin/perlglob.pl glob() support win32/bin/pl2bat.pl wrap perl scripts into batch files win32/bin/runperl.pl run perl script via batch file namesake win32/bin/search.pl Win32 port diff --git a/README.win32 b/README.win32 index fb42850597..233bb6399c 100644 --- a/README.win32 +++ b/README.win32 @@ -237,16 +237,17 @@ perlglob.bat. perlglob.exe relies on the argv expansion done by the C Runtime of the particular compiler you used, and therefore behaves very differently depending on the Runtime used to build it. To preserve -compatiblity, perlglob.bat (a perl script/module that can be -used portably) is installed. Besides being portable, perlglob.bat -also offers enhanced globbing functionality. +compatiblity, perlglob.bat (a perl script that can be used portably) +is installed. Besides being portable, perlglob.bat also offers +enhanced globbing functionality. If you want perl to use perlglob.bat instead of perlglob.exe, just delete perlglob.exe from the install location (or move it somewhere -perl cannot find). Using File::DosGlob.pm (which is the same -as perlglob.bat) to override the internal CORE::glob() works about 10 -times faster than spawing perlglob.exe, and you should take this -approach when writing new modules. See File::DosGlob for details. +perl cannot find). Using File::DosGlob.pm (which implements the core +functionality of perlglob.bat) to override the internal CORE::glob() +works about 10 times faster than spawing perlglob.exe, and you should +take this approach when writing new modules. See File::DosGlob for +details. =item Using perl from the command line @@ -21,10 +21,14 @@ av_reify(AV *av) I32 key; SV* sv; - if (AvREAL(av)) - return; + if (AvREAL(av)) + return; +#ifdef DEBUGGING + if (SvRMAGICAL(av) && mg_find((SV*)av,'P')) + warn("av_reify called on tied array"); +#endif key = AvMAX(av) + 1; - while (key > AvFILL(av) + 1) + while (key > AvFILLp(av) + 1) AvARRAY(av)[--key] = &sv_undef; while (key) { sv = AvARRAY(av)[--key]; @@ -44,15 +48,30 @@ void av_extend(AV *av, I32 key) { dTHR; /* only necessary if we have to extend stack */ + MAGIC *mg; + if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { + dSP; + ENTER; + SAVETMPS; + PUSHMARK(sp); + EXTEND(sp,2); + PUSHs(mg->mg_obj); + PUSHs(sv_2mortal(newSViv(key+1))); + PUTBACK; + perl_call_method("EXTEND", G_SCALAR|G_DISCARD); + FREETMPS; + LEAVE; + return; + } if (key > AvMAX(av)) { SV** ary; I32 tmp; I32 newmax; if (AvALLOC(av) != AvARRAY(av)) { - ary = AvALLOC(av) + AvFILL(av) + 1; + ary = AvALLOC(av) + AvFILLp(av) + 1; tmp = AvARRAY(av) - AvALLOC(av); - Move(AvARRAY(av), AvALLOC(av), AvFILL(av)+1, SV*); + Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*); AvMAX(av) += tmp; SvPVX(av) = (char*)AvALLOC(av); if (AvREAL(av)) { @@ -127,6 +146,12 @@ av_fetch(register AV *av, I32 key, I32 lval) if (!av) return 0; + if (key < 0) { + key += AvFILL(av) + 1; + if (key < 0) + return 0; + } + if (SvRMAGICAL(av)) { if (mg_find((SV*)av,'P')) { dTHR; @@ -137,12 +162,7 @@ av_fetch(register AV *av, I32 key, I32 lval) } } - if (key < 0) { - key += AvFILL(av) + 1; - if (key < 0) - return 0; - } - else if (key > AvFILL(av)) { + if (key > AvFILLp(av)) { if (!lval) return 0; if (AvREALISH(av)) @@ -172,42 +192,47 @@ SV** av_store(register AV *av, I32 key, SV *val) { SV** ary; + U32 fill; + if (!av) return 0; if (!val) val = &sv_undef; - if (SvRMAGICAL(av)) { - if (mg_find((SV*)av,'P')) { - if (val != &sv_undef) - mg_copy((SV*)av, val, 0, key); - return 0; - } - } - if (key < 0) { key += AvFILL(av) + 1; if (key < 0) return 0; } + if (SvREADONLY(av) && key >= AvFILL(av)) croak(no_modify); + + if (SvRMAGICAL(av)) { + if (mg_find((SV*)av,'P')) { + if (val != &sv_undef) { + mg_copy((SV*)av, val, 0, key); + } + return 0; + } + } + if (!AvREAL(av) && AvREIFY(av)) av_reify(av); if (key > AvMAX(av)) av_extend(av,key); ary = AvARRAY(av); - if (AvFILL(av) < key) { + if (AvFILLp(av) < key) { if (!AvREAL(av)) { dTHR; if (av == curstack && key > stack_sp - stack_base) stack_sp = stack_base + key; /* XPUSH in disguise */ do - ary[++AvFILL(av)] = &sv_undef; - while (AvFILL(av) < key); + ary[++AvFILLp(av)] = &sv_undef; + while (AvFILLp(av) < key); } - AvFILL(av) = key; + AvFILLp(av) = key; } else if (AvREAL(av)) SvREFCNT_dec(ary[key]); @@ -232,7 +257,7 @@ newAV(void) AvREAL_on(av); AvALLOC(av) = 0; SvPVX(av) = 0; - AvMAX(av) = AvFILL(av) = -1; + AvMAX(av) = AvFILLp(av) = -1; return av; } @@ -250,7 +275,7 @@ av_make(register I32 size, register SV **strp) New(4,ary,size,SV*); AvALLOC(av) = ary; SvPVX(av) = (char*)ary; - AvFILL(av) = size - 1; + AvFILLp(av) = size - 1; AvMAX(av) = size - 1; for (i = 0; i < size; i++) { assert (*strp); @@ -275,7 +300,7 @@ av_fake(register I32 size, register SV **strp) Copy(strp,ary,size,SV*); AvFLAGS(av) = AVf_REIFY; SvPVX(av) = (char*)ary; - AvFILL(av) = size - 1; + AvFILLp(av) = size - 1; AvMAX(av) = size - 1; while (size--) { assert (*strp); @@ -296,13 +321,20 @@ av_clear(register AV *av) warn("Attempt to clear deleted array"); } #endif - if (!av || AvMAX(av) < 0) + if (!av) return; /*SUPPRESS 560*/ + /* Give any tie a chance to cleanup first */ + if (SvRMAGICAL(av)) + mg_clear((SV*)av); + + if (AvMAX(av) < 0) + return; + if (AvREAL(av)) { ary = AvARRAY(av); - key = AvFILL(av) + 1; + key = AvFILLp(av) + 1; while (key) { SvREFCNT_dec(ary[--key]); ary[key] = &sv_undef; @@ -312,10 +344,8 @@ av_clear(register AV *av) AvMAX(av) += key; SvPVX(av) = (char*)AvALLOC(av); } - AvFILL(av) = -1; + AvFILLp(av) = -1; - if (SvRMAGICAL(av)) - mg_clear((SV*)av); } void @@ -326,15 +356,21 @@ av_undef(register AV *av) if (!av) return; /*SUPPRESS 560*/ + + /* Give any tie a chance to cleanup first */ + if (SvRMAGICAL(av) && mg_find((SV*)av,'P')) + av_fill(av, -1); /* mg_clear() ? */ + if (AvREAL(av)) { - key = AvFILL(av) + 1; + key = AvFILLp(av) + 1; while (key) SvREFCNT_dec(AvARRAY(av)[--key]); } Safefree(AvALLOC(av)); + AvARRAY(av) = 0; AvALLOC(av) = 0; SvPVX(av) = 0; - AvMAX(av) = AvFILL(av) = -1; + AvMAX(av) = AvFILLp(av) = -1; if (AvARYLEN(av)) { SvREFCNT_dec(AvARYLEN(av)); AvARYLEN(av) = 0; @@ -343,23 +379,54 @@ av_undef(register AV *av) void av_push(register AV *av, SV *val) -{ +{ + MAGIC *mg; if (!av) return; - av_store(av,AvFILL(av)+1,val); + if (SvREADONLY(av)) + croak(no_modify); + + if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { + dSP; + PUSHMARK(sp); + EXTEND(sp,2); + PUSHs(mg->mg_obj); + PUSHs(val); + PUTBACK; + ENTER; + perl_call_method("PUSH", G_SCALAR|G_DISCARD); + LEAVE; + return; + } + av_store(av,AvFILLp(av)+1,val); } SV * av_pop(register AV *av) { SV *retval; + MAGIC* mg; if (!av || AvFILL(av) < 0) return &sv_undef; if (SvREADONLY(av)) croak(no_modify); - retval = AvARRAY(av)[AvFILL(av)]; - AvARRAY(av)[AvFILL(av)--] = &sv_undef; + if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { + dSP; + PUSHMARK(sp); + XPUSHs(mg->mg_obj); + PUTBACK; + ENTER; + if (perl_call_method("POP", G_SCALAR)) { + retval = newSVsv(*stack_sp--); + } else { + retval = &sv_undef; + } + LEAVE; + return retval; + } + retval = AvARRAY(av)[AvFILLp(av)]; + AvARRAY(av)[AvFILLp(av)--] = &sv_undef; if (SvSMAGICAL(av)) mg_set((SV*)av); return retval; @@ -369,12 +436,29 @@ void av_unshift(register AV *av, register I32 num) { register I32 i; - register SV **sstr,**dstr; + register SV **ary; + MAGIC* mg; if (!av || num <= 0) return; if (SvREADONLY(av)) croak(no_modify); + + if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { + dSP; + PUSHMARK(sp); + EXTEND(sp,1+num); + PUSHs(mg->mg_obj); + while (num-- > 0) { + PUSHs(&sv_undef); + } + PUTBACK; + ENTER; + perl_call_method("UNSHIFT", G_SCALAR|G_DISCARD); + LEAVE; + return; + } + if (!AvREAL(av) && AvREIFY(av)) av_reify(av); i = AvARRAY(av) - AvALLOC(av); @@ -384,25 +468,18 @@ av_unshift(register AV *av, register I32 num) num -= i; AvMAX(av) += i; - AvFILL(av) += i; + AvFILLp(av) += i; SvPVX(av) = (char*)(AvARRAY(av) - i); } - if (num) { - av_extend(av,AvFILL(av)+num); - AvFILL(av) += num; - dstr = AvARRAY(av) + AvFILL(av); - sstr = dstr - num; -#ifdef BUGGY_MSC5 - # pragma loop_opt(off) /* don't loop-optimize the following code */ -#endif /* BUGGY_MSC5 */ - for (i = AvFILL(av) - num; i >= 0; --i) { - *dstr-- = *sstr--; -#ifdef BUGGY_MSC5 - # pragma loop_opt() /* loop-optimization back to command-line setting */ -#endif /* BUGGY_MSC5 */ - } - while (num) - AvARRAY(av)[--num] = &sv_undef; + if (num) { + i = AvFILLp(av); + av_extend(av, i + num); + AvFILLp(av) += num; + ary = AvARRAY(av); + Move(ary, ary + num, i + 1, SV*); + do { + ary[--num] = &sv_undef; + } while (num); } } @@ -410,17 +487,32 @@ SV * av_shift(register AV *av) { SV *retval; + MAGIC* mg; if (!av || AvFILL(av) < 0) return &sv_undef; if (SvREADONLY(av)) croak(no_modify); + if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { + dSP; + PUSHMARK(sp); + XPUSHs(mg->mg_obj); + PUTBACK; + ENTER; + if (perl_call_method("SHIFT", G_SCALAR)) { + retval = newSVsv(*stack_sp--); + } else { + retval = &sv_undef; + } + LEAVE; + return retval; + } retval = *AvARRAY(av); if (AvREAL(av)) *AvARRAY(av) = &sv_undef; SvPVX(av) = (char*)(AvARRAY(av) + 1); AvMAX(av)--; - AvFILL(av)--; + AvFILLp(av)--; if (SvSMAGICAL(av)) mg_set((SV*)av); return retval; @@ -435,12 +527,27 @@ av_len(register AV *av) void av_fill(register AV *av, I32 fill) { + MAGIC *mg; if (!av) croak("panic: null array"); if (fill < 0) fill = -1; + if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) { + dSP; + ENTER; + SAVETMPS; + PUSHMARK(sp); + EXTEND(sp,2); + PUSHs(mg->mg_obj); + PUSHs(sv_2mortal(newSViv(fill+1))); + PUTBACK; + perl_call_method("STORESIZE", G_SCALAR|G_DISCARD); + FREETMPS; + LEAVE; + return; + } if (fill <= AvMAX(av)) { - I32 key = AvFILL(av); + I32 key = AvFILLp(av); SV** ary = AvARRAY(av); if (AvREAL(av)) { @@ -454,7 +561,7 @@ av_fill(register AV *av, I32 fill) ary[++key] = &sv_undef; } - AvFILL(av) = fill; + AvFILLp(av) = fill; if (SvSMAGICAL(av)) mg_set((SV*)av); } @@ -1,6 +1,6 @@ /* av.h * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1998, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -9,8 +9,8 @@ struct xpvav { char* xav_array; /* pointer to first array element */ - SSize_t xav_fill; - SSize_t xav_max; + SSize_t xav_fill; /* Index of last element present */ + SSize_t xav_max; /* Number of elements for which array has space */ IV xof_off; /* ptr is incremented by offset */ double xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* magic for scalar array */ @@ -30,7 +30,7 @@ struct xpvav { #define AvARRAY(av) ((SV**)((XPVAV*) SvANY(av))->xav_array) #define AvALLOC(av) ((XPVAV*) SvANY(av))->xav_alloc #define AvMAX(av) ((XPVAV*) SvANY(av))->xav_max -#define AvFILL(av) ((XPVAV*) SvANY(av))->xav_fill +#define AvFILLp(av) ((XPVAV*) SvANY(av))->xav_fill #define AvARYLEN(av) ((XPVAV*) SvANY(av))->xav_arylen #define AvFLAGS(av) ((XPVAV*) SvANY(av))->xav_flags @@ -45,4 +45,7 @@ struct xpvav { #define AvREUSED_off(av) (AvFLAGS(av) &= ~AVf_REUSED) #define AvREALISH(av) (AvFLAGS(av) & (AVf_REAL|AVf_REIFY)) + +#define AvFILL(av) ((SvRMAGICAL((SV *) (av))) \ + ? mg_size((SV *) av) : AvFILLp(av)) @@ -105,7 +105,7 @@ debstackptrs(void) (long)(stack_max-stack_base)); PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n", (unsigned long)mainstack, (unsigned long)AvARRAY(curstack), - (long)mainstack, (long)AvFILL(curstack), (long)AvMAX(curstack)); + (long)mainstack, (long)AvFILLp(curstack), (long)AvMAX(curstack)); return 0; } @@ -314,6 +314,7 @@ #define magic_settaint Perl_magic_settaint #define magic_setuvar Perl_magic_setuvar #define magic_setvec Perl_magic_setvec +#define magic_sizepack Perl_magic_sizepack #define magic_wipepack Perl_magic_wipepack #define magicname Perl_magicname #define markstack_grow Perl_markstack_grow @@ -327,6 +328,7 @@ #define mg_len Perl_mg_len #define mg_magical Perl_mg_magical #define mg_set Perl_mg_set +#define mg_size Perl_mg_size #define mod Perl_mod #define mod_amg Perl_mod_amg #define mod_ass_amg Perl_mod_ass_amg diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index d08b21ceab..812464361a 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -106,7 +106,7 @@ package DB_File::RECNOINFO ; use strict ; -@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ; +@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ; sub TIEHASH { @@ -189,7 +189,9 @@ require DynaLoader; R_SNAPSHOT __R_UNUSED -); +); + +*FETCHSIZE = \&length; sub AUTOLOAD { my($constname); diff --git a/ext/GDBM_File/typemap b/ext/GDBM_File/typemap index a9b73d8b81..73ad370359 100644 --- a/ext/GDBM_File/typemap +++ b/ext/GDBM_File/typemap @@ -20,8 +20,8 @@ T_GDATUM UNIMPLEMENTED OUTPUT T_DATUM - sv_setpvn($arg, $var.dptr, $var.dsize); + SvSetMagicPVN($arg, $var.dptr, $var.dsize); T_GDATUM - sv_usepvn($arg, $var.dptr, $var.dsize); + SvUseMagicPVN($arg, $var.dptr, $var.dsize); T_PTROBJ sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/ext/NDBM_File/typemap b/ext/NDBM_File/typemap index a9b73d8b81..73ad370359 100644 --- a/ext/NDBM_File/typemap +++ b/ext/NDBM_File/typemap @@ -20,8 +20,8 @@ T_GDATUM UNIMPLEMENTED OUTPUT T_DATUM - sv_setpvn($arg, $var.dptr, $var.dsize); + SvSetMagicPVN($arg, $var.dptr, $var.dsize); T_GDATUM - sv_usepvn($arg, $var.dptr, $var.dsize); + SvUseMagicPVN($arg, $var.dptr, $var.dsize); T_PTROBJ sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/ext/ODBM_File/typemap b/ext/ODBM_File/typemap index a6b0e5faa8..c2c3e3e725 100644 --- a/ext/ODBM_File/typemap +++ b/ext/ODBM_File/typemap @@ -20,6 +20,6 @@ T_GDATUM UNIMPLEMENTED OUTPUT T_DATUM - sv_setpvn($arg, $var.dptr, $var.dsize); + SvSetMagicPVN($arg, $var.dptr, $var.dsize); T_GDATUM - sv_usepvn($arg, $var.dptr, $var.dsize); + SvUseMagicPVN($arg, $var.dptr, $var.dsize); diff --git a/ext/SDBM_File/typemap b/ext/SDBM_File/typemap index a9b73d8b81..73ad370359 100644 --- a/ext/SDBM_File/typemap +++ b/ext/SDBM_File/typemap @@ -20,8 +20,8 @@ T_GDATUM UNIMPLEMENTED OUTPUT T_DATUM - sv_setpvn($arg, $var.dptr, $var.dsize); + SvSetMagicPVN($arg, $var.dptr, $var.dsize); T_GDATUM - sv_usepvn($arg, $var.dptr, $var.dsize); + SvUseMagicPVN($arg, $var.dptr, $var.dsize); T_PTROBJ sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/global.sym b/global.sym index 969f752ab6..979f8d1818 100644 --- a/global.sym +++ b/global.sym @@ -416,6 +416,7 @@ magic_settaint magic_setuvar magic_setvec magic_set_all_env +magic_sizepack magic_wipepack magicname markstack_grow @@ -429,6 +430,7 @@ mg_get mg_len mg_magical mg_set +mg_size mod modkids moreswitches @@ -183,7 +183,8 @@ gv_fetchmeth(HV *stash, char *name, STRLEN len, I32 level) if (av) { SV** svp = AvARRAY(av); - I32 items = AvFILL(av) + 1; + /* NOTE: No support for tied ISA */ + I32 items = AvFILLp(av) + 1; while (items--) { SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); @@ -582,7 +583,8 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) AV* av = GvAVn(gv); GvMULTI_on(gv); sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0); - if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1) + /* NOTE: No support for tied ISA */ + if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILLp(av) == -1) { char *pname; av_push(av, newSVpv(pname = "NDBM_File",0)); diff --git a/hints/dec_osf.sh b/hints/dec_osf.sh index 2f93f1f7bc..a1efc11cd1 100644 --- a/hints/dec_osf.sh +++ b/hints/dec_osf.sh @@ -102,7 +102,9 @@ case "$optimize" in *gcc*) optimize='-O3' ;; *) case "$_DEC_cc_style" in - new) optimize='-O4' ;; + new) optimize='-O4' + ccflags="$ccflags -fprm d -ieee" + ;; old) optimize='-O2 -Olimit 3200' ;; esac ccflags="$ccflags -D_INTRINSICS" @@ -111,6 +113,17 @@ case "$optimize" in ;; esac +# Make glibpth agree with the compiler suite. Note that /shlib +# is not here. That's on purpose. Even though that's where libc +# really lives from V4.0 on, the linker (and /sbin/loader) won't +# look there by default. The sharable /sbin utilities were all +# built with "-Wl,-rpath,/shlib" to get around that. This makes +# no attempt to figure out the additional location(s) searched by +# gcc, since not all versions of gcc are easily coerced into +# revealing that information. +glibpth="/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc" +glibpth="$glibpth /usr/lib /usr/local/lib /var/shlib" + # dlopen() is in libc libswanted="`echo $libswanted | sed -e 's/ dl / /'`" @@ -165,16 +178,29 @@ case "$optimize" in esac if [ "X$usethreads" != "X" ]; then - ccflags="-DUSE_THREADS $ccflags" - optimize="-pthread $optimize" - ldflags="-pthread $ldflags" - set `echo X "$libswanted "| sed -e 's/ c / pthread c_r /'` - shift - libswanted="$*" + # Threads interfaces changed with V4.0. + case "$_DEC_uname_r" in + *[123].*) libswanted="$libswanted pthreads mach exc c_r" + ccflags="-DUSE_THREADS -threads $ccflags" + ;; + *) libswanted="$libswanted pthread exc" + ccflags="-DUSE_THREADS -pthread $ccflags" + ;; + esac usemymalloc='n' fi # +# Make embedding in things like INN and Apache more memory friendly. +# Keep it overridable on the Configure command line, though, so that +# "-Uuseshrplib" prevents this default. +# + +case "$_DEC_cc_style.$useshrplib" in + new.) useshrplib="$define" ;; +esac + +# # Unset temporary variables no more needed. # @@ -184,6 +210,22 @@ unset _DEC_uname_r # # History: # +# perl5.004_57: +# +# 19-Dec-1997 Spider Boardman <spider@Orb.Nashua.NH.US> +# +# * Newer Digial UNIX compilers enforce signaling for NaN without +# -ieee. Added -fprm d at the same time since it's friendlier for +# embedding. +# +# * Fixed the library search path to match cc, ld, and /sbin/loader. +# +# * Default to building -Duseshrplib on newer systems. -Uuseshrplib +# still overrides. +# +# * Fix -pthread additions for useshrplib. ld has no -pthread option. +# +# # perl5.004_04: # # 19-Sep-1997 Spider Boardman <spider@Orb.Nashua.NH.US> @@ -259,7 +259,6 @@ hv_magic_check (HV *hv, bool *needs_copy, bool *needs_store) *needs_copy = TRUE; switch (mg->mg_type) { case 'P': - case 'I': case 'S': *needs_store = FALSE; } @@ -426,26 +425,33 @@ hv_delete(HV *hv, char *key, U32 klen, I32 flags) register U32 hash; register HE *entry; register HE **oentry; + SV **svp; SV *sv; if (!hv) return Nullsv; if (SvRMAGICAL(hv)) { - sv = *hv_fetch(hv, key, klen, TRUE); - mg_clear(sv); - if (mg_find(sv, 's')) { - return Nullsv; /* %SIG elements cannot be deleted */ - } - else if (mg_find(sv, 'p')) { - sv_unmagic(sv, 'p'); /* No longer an element */ - return sv; - } + bool needs_copy; + bool needs_store; + hv_magic_check (hv, &needs_copy, &needs_store); + + if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) { + sv = *svp; + mg_clear(sv); + if (!needs_store) { + if (mg_find(sv, 'p')) { + sv_unmagic(sv, 'p'); /* No longer an element */ + return sv; + } + return Nullsv; /* element cannot be deleted */ + } #ifdef ENV_IS_CASELESS - else if (mg_find((SV*)hv,'E')) { - sv = sv_2mortal(newSVpv(key,klen)); - key = strupr(SvPVX(sv)); - } + else if (mg_find((SV*)hv,'E')) { + sv = sv_2mortal(newSVpv(key,klen)); + key = strupr(SvPVX(sv)); + } #endif + } } xhv = (XPVHV*)SvANY(hv); if (!xhv->xhv_array) @@ -494,21 +500,29 @@ hv_delete_ent(HV *hv, SV *keysv, I32 flags, U32 hash) if (!hv) return Nullsv; if (SvRMAGICAL(hv)) { - entry = hv_fetch_ent(hv, keysv, TRUE, hash); - sv = HeVAL(entry); - mg_clear(sv); - if (mg_find(sv, 'p')) { - sv_unmagic(sv, 'p'); /* No longer an element */ - return sv; - } + bool needs_copy; + bool needs_store; + hv_magic_check (hv, &needs_copy, &needs_store); + + if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) { + sv = HeVAL(entry); + mg_clear(sv); + if (!needs_store) { + if (mg_find(sv, 'p')) { + sv_unmagic(sv, 'p'); /* No longer an element */ + return sv; + } + return Nullsv; /* element cannot be deleted */ + } #ifdef ENV_IS_CASELESS - else if (mg_find((SV*)hv,'E')) { - key = SvPV(keysv, klen); - keysv = sv_2mortal(newSVpv(key,klen)); - (void)strupr(SvPVX(keysv)); - hash = 0; - } + else if (mg_find((SV*)hv,'E')) { + key = SvPV(keysv, klen); + keysv = sv_2mortal(newSVpv(key,klen)); + (void)strupr(SvPVX(keysv)); + hash = 0; + } #endif + } } xhv = (XPVHV*)SvANY(hv); if (!xhv->xhv_array) diff --git a/installperl b/installperl index ee00cd16a5..150b334f8c 100755 --- a/installperl +++ b/installperl @@ -2,6 +2,7 @@ BEGIN { require 5.004; + chdir '..' if !-d 'lib' and -d '..\lib'; @INC = 'lib'; $ENV{PERL5LIB} = 'lib'; } @@ -87,8 +88,9 @@ if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; } -x 'perl' . $exe_ext || die "perl isn't executable!\n"; -x 'suidperl' . $exe_ext|| die "suidperl isn't executable!\n" if $d_dosuid; --x 't/TEST' || warn "WARNING: You've never run 'make test'!!!", - " (Installing anyway.)\n"; +-x 't/TEST' || $^O eq 'MSWin32' + || warn "WARNING: You've never run 'make test'!!!", + " (Installing anyway.)\n"; if ($^O eq 'MSWin32') { @@ -160,7 +162,7 @@ foreach $file (@corefiles) { $mainperl_is_instperl = 0; -if (!$versiononly && !$nonono && -t STDIN && -t STDERR +if (!$versiononly && !$nonono && $^O ne 'MSWin32' && -t STDIN && -t STDERR && -w $mainperldir && ! samepath($mainperldir, $installbin)) { local($usrbinperl) = "$mainperldir/perl$exe_ext"; local($instperl) = "$installbin/perl$exe_ext"; diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 6703245562..888e5396dc 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1155,6 +1155,7 @@ sub fixin { # stolen from the pink Camel book, more or less my($shb) = ""; if ($interpreter) { print STDOUT "Changing sharpbang in $file to $interpreter" if $Verbose; + # this is probably value-free on DOSISH platforms if ($does_shbang) { $shb .= "$Config{'sharpbang'}$interpreter"; $shb .= ' ' . $arg if defined $arg; @@ -1163,18 +1164,14 @@ sub fixin { # stolen from the pink Camel book, more or less $shb .= qq{ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' if 0; # not running under some shell -}; +} unless $Is_Win32; # this won't work on win32, so don't } else { warn "Can't find $cmd in PATH, $file unchanged" if $Verbose; next; } - unless ( rename($file, "$file.bak") ) { - warn "Can't modify $file"; - next; - } - unless ( open(FIXOUT,">$file") ) { + unless ( open(FIXOUT,">$file.new") ) { warn "Can't create new $file: $!\n"; next; } @@ -1188,6 +1185,19 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' print FIXOUT $shb, <FIXIN>; close FIXIN; close FIXOUT; + # can't rename open files on some DOSISH platforms + unless ( rename($file, "$file.bak") ) { + warn "Can't rename $file to $file.bak: $!"; + next; + } + unless ( rename("$file.new", $file) ) { + warn "Can't rename $file.new to $file: $!"; + unless ( rename("$file.bak", $file) ) { + warn "Can't rename $file.bak back to $file either: $!"; + warn "Leaving $file renamed as $file.bak\n"; + } + next; + } unlink "$file.bak"; } continue { chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; @@ -1997,9 +2007,12 @@ sub installbin { push(@m, qq{ EXE_FILES = @{$self->{EXE_FILES}} -FIXIN = \$(PERL) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) -MExtUtils::MakeMaker \\ +} . ($Is_Win32 + ? q{FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \ + -e "system qq[pl2bat.bat ].shift" +} : q{FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::MakeMaker \ -e "MY->fixin(shift)" - +}).qq{ all :: @to $self->{NOECHO}\$(NOOP) diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index 20cc96f0b5..430c28ad3d 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -190,44 +190,44 @@ T_HVREF T_CVREF $arg = newRV((SV*)$var); T_IV - sv_setiv($arg, (IV)$var); + SvSetMagicIV($arg, (IV)$var); T_INT - sv_setiv($arg, (IV)$var); + SvSetMagicIV($arg, (IV)$var); T_SYSRET if ($var != -1) { if ($var == 0) - sv_setpvn($arg, "0 but true", 10); + SvSetMagicPVN($arg, "0 but true", 10); else - sv_setiv($arg, (IV)$var); + SvSetMagicIV($arg, (IV)$var); } T_ENUM - sv_setiv($arg, (IV)$var); + SvSetMagicIV($arg, (IV)$var); T_BOOL $arg = boolSV($var); T_U_INT - sv_setiv($arg, (IV)$var); + SvSetMagicIV($arg, (IV)$var); T_SHORT - sv_setiv($arg, (IV)$var); + SvSetMagicIV($arg, (IV)$var); T_U_SHORT - sv_setiv($arg, (IV)$var); + SvSetMagicIV($arg, (IV)$var); T_LONG - sv_setiv($arg, (IV)$var); + SvSetMagicIV($arg, (IV)$var); T_U_LONG - sv_setiv($arg, (IV)$var); + SvSetMagicIV($arg, (IV)$var); T_CHAR - sv_setpvn($arg, (char *)&$var, 1); + SvSetMagicPVN($arg, (char *)&$var, 1); T_U_CHAR - sv_setiv($arg, (IV)$var); + SvSetMagicIV($arg, (IV)$var); T_FLOAT - sv_setnv($arg, (double)$var); + SvSetMagicNV($arg, (double)$var); T_NV - sv_setnv($arg, (double)$var); + SvSetMagicNV($arg, (double)$var); T_DOUBLE - sv_setnv($arg, (double)$var); + SvSetMagicNV($arg, (double)$var); T_PV - sv_setpv((SV*)$arg, $var); + SvSetMagicPV((SV*)$arg, $var); T_PTR - sv_setiv($arg, (IV)$var); + SvSetMagicIV($arg, (IV)$var); T_PTRREF sv_setref_pv($arg, Nullch, (void*)$var); T_REF_IV_REF @@ -244,17 +244,17 @@ T_REFREF T_REFOBJ NOT IMPLEMENTED T_OPAQUE - sv_setpvn($arg, (char *)&$var, sizeof($var)); + SvSetMagicPVN($arg, (char *)&$var, sizeof($var)); T_OPAQUEPTR - sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var); + SvSetMagicPVN($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var); T_PACKED XS_pack_$ntype($arg, $var); T_PACKEDARRAY XS_pack_$ntype($arg, $var, count_$ntype); T_DATAUNIT - sv_setpvn($arg, $var.chp(), $var.size()); + SvSetMagicPVN($arg, $var.chp(), $var.size()); T_CALLBACK - sv_setpvn($arg, $var.context.value().chp(), + SvSetMagicPVN($arg, $var.context.value().chp(), $var.context.value().size()); T_ARRAY ST_EXTEND($var.size); @@ -267,7 +267,7 @@ T_IN { GV *gv = newGVgen("$Package"); if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) - sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + SvSetMagicSV($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &sv_undef; } @@ -275,7 +275,7 @@ T_INOUT { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) - sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + SvSetMagicSV($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &sv_undef; } @@ -283,7 +283,7 @@ T_OUT { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) - sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + SvSetMagicSV($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &sv_undef; } diff --git a/lib/File/DosGlob.pm b/lib/File/DosGlob.pm index 4597c71564..a27dad9030 100644 --- a/lib/File/DosGlob.pm +++ b/lib/File/DosGlob.pm @@ -6,21 +6,6 @@ package File::DosGlob; -unless (caller) { - $| = 1; - while (@ARGV) { - # - # We have to do this one by one for compatibility reasons. - # If an arg doesn't match anything, we are supposed to return - # the original arg. I know, it stinks, eh? - # - my $arg = shift; - my @m = doglob(1,$arg); - print (@m ? join("\0", sort @m) : $arg); - print "\0" if @ARGV; - } -} - sub doglob { my $cond = shift; my @retval = (); @@ -159,8 +144,6 @@ __END__ File::DosGlob - DOS like globbing and then some -perlglob.bat - a more capable perlglob.exe replacement - =head1 SYNOPSIS require 5.004; @@ -173,14 +156,11 @@ perlglob.bat - a more capable perlglob.exe replacement # from the command line (overrides only in main::) > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>" - - > perlglob ../pe*/*p? =head1 DESCRIPTION A module that implements DOS-like globbing with a few enhancements. -This file is also a portable replacement for perlglob.exe. It -is largely compatible with perlglob.exe (the M$ setargv.obj +It is largely compatible with perlglob.exe (the M$ setargv.obj version) in all but one respect--it understands wildcards in directory components. @@ -191,17 +171,6 @@ backslashes and forward slashes are both accepted, and preserved. You may have to double the backslashes if you are putting them in literally, due to double-quotish parsing of the pattern by perl. -When invoked as a program, it will print null-separated filenames -to standard output. - -While one may replace perlglob.exe with this, usage by overriding -CORE::glob via importation should be much more efficient, because -it avoids launching a separate process, and is therefore strongly -recommended. Note that it is currently possible to override -builtins like glob() only on a per-package basis, not "globally". -Thus, every namespace that wants to override glob() must explicitly -request the override. See L<perlsub>. - Extending it to csh patterns is left as an exercise to the reader. =head1 EXPORTS (by request only) @@ -246,5 +215,7 @@ Initial version (GSAR 20-FEB-97) perl +perlglob.bat + =cut diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 2b05300404..38b396771b 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -2,505 +2,14 @@ package Getopt::Long; -# RCS Status : $Id: GetoptLong.pm,v 2.11 1997-09-17 12:23:51+02 jv Exp $ +# RCS Status : $Id: GetoptLong.pm,v 2.13 1997-12-25 16:20:17+01 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Wed Sep 17 12:20:10 1997 -# Update Count : 608 +# Last Modified On: Thu Dec 25 16:18:08 1997 +# Update Count : 647 # Status : Released -=head1 NAME - -GetOptions - extended processing of command line options - -=head1 SYNOPSIS - - use Getopt::Long; - $result = GetOptions (...option-descriptions...); - -=head1 DESCRIPTION - -The Getopt::Long module implements an extended getopt function called -GetOptions(). This function adheres to the POSIX syntax for command -line options, with GNU extensions. In general, this means that options -have long names instead of single letters, and are introduced with a -double dash "--". Support for bundling of command line options, as was -the case with the more traditional single-letter approach, is provided -but not enabled by default. For example, the UNIX "ps" command can be -given the command line "option" - - -vax - -which means the combination of B<-v>, B<-a> and B<-x>. With the new -syntax B<--vax> would be a single option, probably indicating a -computer architecture. - -Command line options can be used to set values. These values can be -specified in one of two ways: - - --size 24 - --size=24 - -GetOptions is called with a list of option-descriptions, each of which -consists of two elements: the option specifier and the option linkage. -The option specifier defines the name of the option and, optionally, -the value it can take. The option linkage is usually a reference to a -variable that will be set when the option is used. For example, the -following call to GetOptions: - - GetOptions("size=i" => \$offset); - -will accept a command line option "size" that must have an integer -value. With a command line of "--size 24" this will cause the variable -$offset to get the value 24. - -Alternatively, the first argument to GetOptions may be a reference to -a HASH describing the linkage for the options, or an object whose -class is based on a HASH. The following call is equivalent to the -example above: - - %optctl = ("size" => \$offset); - GetOptions(\%optctl, "size=i"); - -Linkage may be specified using either of the above methods, or both. -Linkage specified in the argument list takes precedence over the -linkage specified in the HASH. - -The command line options are taken from array @ARGV. Upon completion -of GetOptions, @ARGV will contain the rest (i.e. the non-options) of -the command line. - -Each option specifier designates the name of the option, optionally -followed by an argument specifier. Values for argument specifiers are: - -=over 8 - -=item E<lt>noneE<gt> - -Option does not take an argument. -The option variable will be set to 1. - -=item ! - -Option does not take an argument and may be negated, i.e. prefixed by -"no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo> -(with value 0). -The option variable will be set to 1, or 0 if negated. - -=item =s - -Option takes a mandatory string argument. -This string will be assigned to the option variable. -Note that even if the string argument starts with B<-> or B<-->, it -will not be considered an option on itself. - -=item :s - -Option takes an optional string argument. -This string will be assigned to the option variable. -If omitted, it will be assigned "" (an empty string). -If the string argument starts with B<-> or B<-->, it -will be considered an option on itself. - -=item =i - -Option takes a mandatory integer argument. -This value will be assigned to the option variable. -Note that the value may start with B<-> to indicate a negative -value. - -=item :i - -Option takes an optional integer argument. -This value will be assigned to the option variable. -If omitted, the value 0 will be assigned. -Note that the value may start with B<-> to indicate a negative -value. - -=item =f - -Option takes a mandatory real number argument. -This value will be assigned to the option variable. -Note that the value may start with B<-> to indicate a negative -value. - -=item :f - -Option takes an optional real number argument. -This value will be assigned to the option variable. -If omitted, the value 0 will be assigned. - -=back - -A lone dash B<-> is considered an option, the corresponding option -name is the empty string. - -A double dash on itself B<--> signals end of the options list. - -=head2 Linkage specification - -The linkage specifier is optional. If no linkage is explicitly -specified but a ref HASH is passed, GetOptions will place the value in -the HASH. For example: - - %optctl = (); - GetOptions (\%optctl, "size=i"); - -will perform the equivalent of the assignment - - $optctl{"size"} = 24; - -For array options, a reference to an array is used, e.g.: - - %optctl = (); - GetOptions (\%optctl, "sizes=i@"); - -with command line "-sizes 24 -sizes 48" will perform the equivalent of -the assignment - - $optctl{"sizes"} = [24, 48]; - -For hash options (an option whose argument looks like "name=value"), -a reference to a hash is used, e.g.: - - %optctl = (); - GetOptions (\%optctl, "define=s%"); - -with command line "--define foo=hello --define bar=world" will perform the -equivalent of the assignment - - $optctl{"define"} = {foo=>'hello', bar=>'world') - -If no linkage is explicitly specified and no ref HASH is passed, -GetOptions will put the value in a global variable named after the -option, prefixed by "opt_". To yield a usable Perl variable, -characters that are not part of the syntax for variables are -translated to underscores. For example, "--fpp-struct-return" will set -the variable $opt_fpp_struct_return. Note that this variable resides -in the namespace of the calling program, not necessarily B<main>. -For example: - - GetOptions ("size=i", "sizes=i@"); - -with command line "-size 10 -sizes 24 -sizes 48" will perform the -equivalent of the assignments - - $opt_size = 10; - @opt_sizes = (24, 48); - -A lone dash B<-> is considered an option, the corresponding Perl -identifier is $opt_ . - -The linkage specifier can be a reference to a scalar, a reference to -an array, a reference to a hash or a reference to a subroutine. - -If a REF SCALAR is supplied, the new value is stored in the referenced -variable. If the option occurs more than once, the previous value is -overwritten. - -If a REF ARRAY is supplied, the new value is appended (pushed) to the -referenced array. - -If a REF HASH is supplied, the option value should look like "key" or -"key=value" (if the "=value" is omitted then a value of 1 is implied). -In this case, the element of the referenced hash with the key "key" -is assigned "value". - -If a REF CODE is supplied, the referenced subroutine is called with -two arguments: the option name and the option value. -The option name is always the true name, not an abbreviation or alias. - -=head2 Aliases and abbreviations - -The option name may actually be a list of option names, separated by -"|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name -of this option. If no linkage is specified, options "foo", "bar" and -"blech" all will set $opt_foo. - -Option names may be abbreviated to uniqueness, depending on -configuration option B<auto_abbrev>. - -=head2 Non-option call-back routine - -A special option specifier, E<lt>E<gt>, can be used to designate a subroutine -to handle non-option arguments. GetOptions will immediately call this -subroutine for every non-option it encounters in the options list. -This subroutine gets the name of the non-option passed. -This feature requires configuration option B<permute>, see section -CONFIGURATION OPTIONS. - -See also the examples. - -=head2 Option starters - -On the command line, options can start with B<-> (traditional), B<--> -(POSIX) and B<+> (GNU, now being phased out). The latter is not -allowed if the environment variable B<POSIXLY_CORRECT> has been -defined. - -Options that start with "--" may have an argument appended, separated -with an "=", e.g. "--foo=bar". - -=head2 Return value - -A return status of 0 (false) indicates that the function detected -one or more errors. - -=head1 COMPATIBILITY - -Getopt::Long::GetOptions() is the successor of -B<newgetopt.pl> that came with Perl 4. It is fully upward compatible. -In fact, the Perl 5 version of newgetopt.pl is just a wrapper around -the module. - -If an "@" sign is appended to the argument specifier, the option is -treated as an array. Value(s) are not set, but pushed into array -@opt_name. If explicit linkage is supplied, this must be a reference -to an ARRAY. - -If an "%" sign is appended to the argument specifier, the option is -treated as a hash. Value(s) of the form "name=value" are set by -setting the element of the hash %opt_name with key "name" to "value" -(if the "=value" portion is omitted it defaults to 1). If explicit -linkage is supplied, this must be a reference to a HASH. - -If configuration option B<getopt_compat> is set (see section -CONFIGURATION OPTIONS), options that start with "+" or "-" may also -include their arguments, e.g. "+foo=bar". This is for compatiblity -with older implementations of the GNU "getopt" routine. - -If the first argument to GetOptions is a string consisting of only -non-alphanumeric characters, it is taken to specify the option starter -characters. Everything starting with one of these characters from the -starter will be considered an option. B<Using a starter argument is -strongly deprecated.> - -For convenience, option specifiers may have a leading B<-> or B<-->, -so it is possible to write: - - GetOptions qw(-foo=s --bar=i --ar=s); - -=head1 EXAMPLES - -If the option specifier is "one:i" (i.e. takes an optional integer -argument), then the following situations are handled: - - -one -two -> $opt_one = '', -two is next option - -one -2 -> $opt_one = -2 - -Also, assume specifiers "foo=s" and "bar:s" : - - -bar -xxx -> $opt_bar = '', '-xxx' is next option - -foo -bar -> $opt_foo = '-bar' - -foo -- -> $opt_foo = '--' - -In GNU or POSIX format, option names and values can be combined: - - +foo=blech -> $opt_foo = 'blech' - --bar= -> $opt_bar = '' - --bar=-- -> $opt_bar = '--' - -Example of using variable references: - - $ret = GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar); - -With command line options "-foo blech -bar 24 -ar xx -ar yy" -this will result in: - - $foo = 'blech' - $opt_bar = 24 - @ar = ('xx','yy') - -Example of using the E<lt>E<gt> option specifier: - - @ARGV = qw(-foo 1 bar -foo 2 blech); - GetOptions("foo=i", \$myfoo, "<>", \&mysub); - -Results: - - mysub("bar") will be called (with $myfoo being 1) - mysub("blech") will be called (with $myfoo being 2) - -Compare this with: - - @ARGV = qw(-foo 1 bar -foo 2 blech); - GetOptions("foo=i", \$myfoo); - -This will leave the non-options in @ARGV: - - $myfoo -> 2 - @ARGV -> qw(bar blech) - -=head1 CONFIGURATION OPTIONS - -B<GetOptions> can be configured by calling subroutine -B<Getopt::Long::config>. This subroutine takes a list of quoted -strings, each specifying a configuration option to be set, e.g. -B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g. -B<no_ignore_case>. Case does not matter. Multiple calls to B<config> -are possible. - -Previous versions of Getopt::Long used variables for the purpose of -configuring. Although manipulating these variables still work, it -is strongly encouraged to use the new B<config> routine. Besides, it -is much easier. - -The following options are available: - -=over 12 - -=item default - -This option causes all configuration options to be reset to their -default values. - -=item auto_abbrev - -Allow option names to be abbreviated to uniqueness. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset. - -=item getopt_compat - -Allow '+' to start options. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset. - -=item require_order - -Whether non-options are allowed to be mixed with -options. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case b<require_order> is reset. - -See also B<permute>, which is the opposite of B<require_order>. - -=item permute - -Whether non-options are allowed to be mixed with -options. -Default is set unless environment variable -POSIXLY_CORRECT has been set, in which case B<permute> is reset. -Note that B<permute> is the opposite of B<require_order>. - -If B<permute> is set, this means that - - -foo arg1 -bar arg2 arg3 - -is equivalent to - - -foo -bar arg1 arg2 arg3 - -If a non-option call-back routine is specified, @ARGV will always be -empty upon succesful return of GetOptions since all options have been -processed, except when B<--> is used: - - -foo arg1 -bar arg2 -- arg3 - -will call the call-back routine for arg1 and arg2, and terminate -leaving arg2 in @ARGV. - -If B<require_order> is set, options processing -terminates when the first non-option is encountered. - - -foo arg1 -bar arg2 arg3 - -is equivalent to - - -foo -- arg1 -bar arg2 arg3 - -=item bundling (default: reset) - -Setting this variable to a non-zero value will allow single-character -options to be bundled. To distinguish bundles from long option names, -long options must be introduced with B<--> and single-character -options (and bundles) with B<->. For example, - - ps -vax --vax - -would be equivalent to - - ps -v -a -x --vax - -provided "vax", "v", "a" and "x" have been defined to be valid -options. - -Bundled options can also include a value in the bundle; this value has -to be the last part of the bundle, e.g. - - scale -h24 -w80 - -is equivalent to - - scale -h 24 -w 80 - -Note: resetting B<bundling> also resets B<bundling_override>. - -=item bundling_override (default: reset) - -If B<bundling_override> is set, bundling is enabled as with -B<bundling> but now long option names override option bundles. In the -above example, B<-vax> would be interpreted as the option "vax", not -the bundle "v", "a", "x". - -Note: resetting B<bundling_override> also resets B<bundling>. - -B<Note:> Using option bundling can easily lead to unexpected results, -especially when mixing long options and bundles. Caveat emptor. - -=item ignore_case (default: set) - -If set, case is ignored when matching options. - -Note: resetting B<ignore_case> also resets B<ignore_case_always>. - -=item ignore_case_always (default: reset) - -When bundling is in effect, case is ignored on single-character -options also. - -Note: resetting B<ignore_case_always> also resets B<ignore_case>. - -=item pass_through (default: reset) - -Unknown options are passed through in @ARGV instead of being flagged -as errors. This makes it possible to write wrapper scripts that -process only part of the user supplied options, and passes the -remaining options to some other program. - -This can be very confusing, especially when B<permute> is also set. - -=item debug (default: reset) - -Enable copious debugging output. - -=back - -=head1 OTHER USEFUL VARIABLES - -=over 12 - -=item $Getopt::Long::VERSION - -The version number of this Getopt::Long implementation in the format -C<major>.C<minor>. This can be used to have Exporter check the -version, e.g. - - use Getopt::Long 3.00; - -You can inspect $Getopt::Long::major_version and -$Getopt::Long::minor_version for the individual components. - -=item $Getopt::Long::error - -Internal error flag. May be incremented from a call-back routine to -cause options parsing to fail. - -=back - -=cut - ################ Copyright ################ # This program is Copyright 1990,1997 by Johan Vromans. @@ -526,7 +35,7 @@ BEGIN { require 5.003; use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - $VERSION = sprintf("%d.%02d", q$Revision: 2.11 $ =~ /(\d+)\.(\d+)/); + $VERSION = sprintf("%d.%02d", q$Revision: 2.13 $ =~ /(\d+)\.(\d+)/); @ISA = qw(Exporter); @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); @@ -559,6 +68,7 @@ my $key; # hash key for a hash option # than once in differing environments my $config_defaults; # set config defaults my $find_option; # helper routine +my $croak; # helper routine ################ Subroutines ################ @@ -575,9 +85,9 @@ sub GetOptions { my %linkage; # linkage my $userlinkage; # user supplied HASH $genprefix = $gen_prefix; # so we can call the same module many times - $error = 0; + $error = ''; - print STDERR ('GetOptions $Revision: 2.11 $ ', + print STDERR ('GetOptions $Revision: 2.13 $ ', "[GetOpt::Long $Getopt::Long::VERSION] -- ", "called from package \"$pkg\".\n", " (@ARGV)\n", @@ -605,9 +115,9 @@ sub GetOptions { # starter characters. if ( $optionlist[0] =~ /^\W+$/ ) { $genprefix = shift (@optionlist); - # Turn into regexp. + # Turn into regexp. Needs to be parenthesized! $genprefix =~ s/(\W)/\\$1/g; - $genprefix = "[" . $genprefix . "]"; + $genprefix = "([" . $genprefix . "])"; } # Verify correctness of optionlist. @@ -617,7 +127,7 @@ sub GetOptions { my $opt = shift (@optionlist); # Strip leading prefix so people can specify "--foo=i" if they like. - $opt = $' if $opt =~ /^($genprefix)+/; + $opt = $2 if $opt =~ /^$genprefix+(.*)$/; if ( $opt eq '<>' ) { if ( (defined $userlinkage) @@ -628,20 +138,19 @@ sub GetOptions { } unless ( @optionlist > 0 && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { - warn ("Option spec <> requires a reference to a subroutine\n"); - $error++; + $error .= "Option spec <> requires a reference to a subroutine\n"; next; } $linkage{'<>'} = shift (@optionlist); next; } - if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse][@%]?)?$/ ) { - warn ("Error in option spec: \"", $opt, "\"\n"); - $error++; + # Match option spec. Allow '?' as an alias. + if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?(!|[=:][infse][@%]?)?$/ ) { + $error .= "Error in option spec: \"$opt\"\n"; next; } - my ($o, $c, $a) = ($1, $2); + my ($o, $c, $a) = ($1, $5); $c = '' unless defined $c; if ( ! defined $o ) { @@ -718,18 +227,19 @@ sub GetOptions { $opctl{$o} .= '@' if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/; $bopctl{$o} .= '@' - if $bundling and $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/; + if $bundling and defined $bopctl{$o} and + $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/; } elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) { $linkage{$o} = shift (@optionlist); $opctl{$o} .= '%' if $opctl{$o} ne '' and $opctl{$o} !~ /\%$/; $bopctl{$o} .= '%' - if $bundling and $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/; + if $bundling and defined $bopctl{$o} and + $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/; } else { - warn ("Invalid option linkage for \"", $opt, "\"\n"); - $error++; + $error .= "Invalid option linkage for \"$opt\"\n"; } } else { @@ -756,7 +266,8 @@ sub GetOptions { } # Bail out if errors found. - return 0 if $error; + die ($error) if $error; + $error = 0; # Sort the possible long option names. @opctl = sort(keys (%opctl)) if $autoabbrev; @@ -833,7 +344,7 @@ sub GetOptions { else { print STDERR ("Invalid REF type \"", ref($linkage{$opt}), "\" in linkage\n"); - die ("Getopt::Long -- internal error!\n"); + &$croak ("Getopt::Long -- internal error!\n"); } } # No entry in linkage means entry in userlinkage. @@ -873,7 +384,7 @@ sub GetOptions { # Try non-options call-back. my $cb; if ( (defined ($cb = $linkage{'<>'})) ) { - &$cb($tryopt); + &$cb ($tryopt); } else { print STDERR ("=> saving \"$tryopt\" ", @@ -909,9 +420,9 @@ sub config (@) { foreach $opt ( @options ) { my $try = lc ($opt); my $action = 1; - if ( $try =~ /^no_?/ ) { + if ( $try =~ /^no_?(.*)$/ ) { $action = 0; - $try = $'; + $try = $1; } if ( $try eq 'default' or $try eq 'defaults' ) { &$config_defaults () if $action; @@ -947,48 +458,39 @@ sub config (@) { $debug = $action; } else { - $Carp::CarpLevel = 1; - Carp::croak("Getopt::Long: unknown config parameter \"$opt\"") + &$croak ("Getopt::Long: unknown config parameter \"$opt\"") } } } -# Modified from Exporter. This one handles 2.001 and 2.01 etc just like 2.1. -sub require_version { - no strict; - my ($self, $wanted) = @_; - my $pkg = ref $self || $self; - my $version = $ {"${pkg}::VERSION"} || "(undef)"; - - $wanted .= '.0' unless $wanted =~ /\./; - $wanted = $1 * 1000 + $2 if $wanted =~ /^(\d+)\.(\d+)$/; - $version = $1 * 1000 + $2 if $version =~ /^(\d+)\.(\d+)$/; - if ( $version < $wanted ) { - $version =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e; - $wanted =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e; - $Carp::CarpLevel = 1; - Carp::croak("$pkg $wanted required--this is only version $version") - } - $version; -} +# To prevent Carp from being loaded unnecessarily. +$croak = sub { + require 'Carp.pm'; + $Carp::CarpLevel = 1; + Carp::croak(@_); +}; ################ Private Subroutines ################ $find_option = sub { - return 0 unless $opt =~ /^$genprefix/; + print STDERR ("=> find \"$opt\", genprefix=\"$genprefix\"\n") if $debug; - $opt = $'; - my ($starter) = $&; + return 0 unless $opt =~ /^$genprefix(.*)$/; + + $opt = $2; + my ($starter) = $1; + + print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug; my $optarg = undef; # value supplied with --opt=value my $rest = undef; # remainder from unbundling # If it is a long option, it may include the value. - if (($starter eq "--" || $getopt_compat) - && $opt =~ /^([^=]+)=/ ) { + if (($starter eq "--" || ($getopt_compat && !$bundling)) + && $opt =~ /^([^=]+)=(.*)$/ ) { $opt = $1; - $optarg = $'; + $optarg = $2; print STDERR ("=> option \"", $opt, "\", optarg = \"$optarg\"\n") if $debug; } @@ -1041,8 +543,8 @@ $find_option = sub { # Now see if it really is ambiguous. unless ( keys(%hit) == 1 ) { return 0 if $passthrough; - print STDERR ("Option ", $opt, " is ambiguous (", - join(", ", @hits), ")\n"); + warn ("Option ", $opt, " is ambiguous (", + join(", ", @hits), ")\n"); $error++; undef $opt; return 1; @@ -1082,7 +584,7 @@ $find_option = sub { if ( $type eq '' || $type eq '!' ) { if ( defined $optarg ) { return 0 if $passthrough; - print STDERR ("Option ", $opt, " does not take an argument\n"); + warn ("Option ", $opt, " does not take an argument\n"); $error++; undef $opt; } @@ -1107,7 +609,7 @@ $find_option = sub { # Complain if this option needs an argument. if ( $mand eq "=" ) { return 0 if $passthrough; - print STDERR ("Option ", $opt, " requires an argument\n"); + warn ("Option ", $opt, " requires an argument\n"); $error++; undef $opt; } @@ -1124,7 +626,7 @@ $find_option = sub { # Get key if this is a "name=value" pair for a hash option. $key = undef; if ($hash && defined $arg) { - ($key, $arg) = ($arg =~ /=/o) ? ($`, $') : ($arg, 1); + ($key, $arg) = ($arg =~ /^(.*)=(.*)$/o) ? ($1, $2) : ($arg, 1); } #### Check if the argument is valid for this option #### @@ -1148,15 +650,20 @@ $find_option = sub { } elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer - if ( $arg !~ /^-?[0-9]+$/ ) { + if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/ ) { + $arg = $1; + $rest = $2; + unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; + } + elsif ( $arg !~ /^-?[0-9]+$/ ) { if ( defined $optarg || $mand eq "=" ) { if ( $passthrough ) { unshift (@ARGV, defined $rest ? $starter.$rest : $arg) unless defined $optarg; return 0; } - print STDERR ("Value \"", $arg, "\" invalid for option ", - $opt, " (number expected)\n"); + warn ("Value \"", $arg, "\" invalid for option ", + $opt, " (number expected)\n"); $error++; undef $opt; # Push back. @@ -1172,15 +679,24 @@ $find_option = sub { } elsif ( $type eq "f" ) { # real number, int is also ok - if ( $arg !~ /^-?[0-9.]+([eE]-?[0-9]+)?$/ ) { + # We require at least one digit before a point or 'e', + # and at least one digit following the point and 'e'. + # [-]NN[.NN][eNN] + if ( $bundling && defined $rest && + $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/ ) { + $arg = $1; + $rest = $4; + unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; + } + elsif ( $arg !~ /^-?[0-9.]+(\.[0-9]+)?([eE]-?[0-9]+)?$/ ) { if ( defined $optarg || $mand eq "=" ) { if ( $passthrough ) { unshift (@ARGV, defined $rest ? $starter.$rest : $arg) unless defined $optarg; return 0; } - print STDERR ("Value \"", $arg, "\" invalid for option ", - $opt, " (real number expected)\n"); + warn ("Value \"", $arg, "\" invalid for option ", + $opt, " (real number expected)\n"); $error++; undef $opt; # Push back. @@ -1195,7 +711,7 @@ $find_option = sub { } } else { - die ("GetOpt::Long internal error (Can't happen)\n"); + &$croak ("GetOpt::Long internal error (Can't happen)\n"); } return 1; }; @@ -1236,3 +752,529 @@ $config_defaults = sub { ################ Package return ################ 1; + +__END__ + +=head1 NAME + +GetOptions - extended processing of command line options + +=head1 SYNOPSIS + + use Getopt::Long; + $result = GetOptions (...option-descriptions...); + +=head1 DESCRIPTION + +The Getopt::Long module implements an extended getopt function called +GetOptions(). This function adheres to the POSIX syntax for command +line options, with GNU extensions. In general, this means that options +have long names instead of single letters, and are introduced with a +double dash "--". Support for bundling of command line options, as was +the case with the more traditional single-letter approach, is provided +but not enabled by default. For example, the UNIX "ps" command can be +given the command line "option" + + -vax + +which means the combination of B<-v>, B<-a> and B<-x>. With the new +syntax B<--vax> would be a single option, probably indicating a +computer architecture. + +Command line options can be used to set values. These values can be +specified in one of two ways: + + --size 24 + --size=24 + +GetOptions is called with a list of option-descriptions, each of which +consists of two elements: the option specifier and the option linkage. +The option specifier defines the name of the option and, optionally, +the value it can take. The option linkage is usually a reference to a +variable that will be set when the option is used. For example, the +following call to GetOptions: + + GetOptions("size=i" => \$offset); + +will accept a command line option "size" that must have an integer +value. With a command line of "--size 24" this will cause the variable +$offset to get the value 24. + +Alternatively, the first argument to GetOptions may be a reference to +a HASH describing the linkage for the options, or an object whose +class is based on a HASH. The following call is equivalent to the +example above: + + %optctl = ("size" => \$offset); + GetOptions(\%optctl, "size=i"); + +Linkage may be specified using either of the above methods, or both. +Linkage specified in the argument list takes precedence over the +linkage specified in the HASH. + +The command line options are taken from array @ARGV. Upon completion +of GetOptions, @ARGV will contain the rest (i.e. the non-options) of +the command line. + +Each option specifier designates the name of the option, optionally +followed by an argument specifier. + +Options that do not take arguments will have no argument specifier. +The option variable will be set to 1 if the option is used. + +For the other options, the values for argument specifiers are: + +=over 8 + +=item ! + +Option does not take an argument and may be negated, i.e. prefixed by +"no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo> +(with value 0). +The option variable will be set to 1, or 0 if negated. + +=item =s + +Option takes a mandatory string argument. +This string will be assigned to the option variable. +Note that even if the string argument starts with B<-> or B<-->, it +will not be considered an option on itself. + +=item :s + +Option takes an optional string argument. +This string will be assigned to the option variable. +If omitted, it will be assigned "" (an empty string). +If the string argument starts with B<-> or B<-->, it +will be considered an option on itself. + +=item =i + +Option takes a mandatory integer argument. +This value will be assigned to the option variable. +Note that the value may start with B<-> to indicate a negative +value. + +=item :i + +Option takes an optional integer argument. +This value will be assigned to the option variable. +If omitted, the value 0 will be assigned. +Note that the value may start with B<-> to indicate a negative +value. + +=item =f + +Option takes a mandatory real number argument. +This value will be assigned to the option variable. +Note that the value may start with B<-> to indicate a negative +value. + +=item :f + +Option takes an optional real number argument. +This value will be assigned to the option variable. +If omitted, the value 0 will be assigned. + +=back + +A lone dash B<-> is considered an option, the corresponding option +name is the empty string. + +A double dash on itself B<--> signals end of the options list. + +=head2 Linkage specification + +The linkage specifier is optional. If no linkage is explicitly +specified but a ref HASH is passed, GetOptions will place the value in +the HASH. For example: + + %optctl = (); + GetOptions (\%optctl, "size=i"); + +will perform the equivalent of the assignment + + $optctl{"size"} = 24; + +For array options, a reference to an array is used, e.g.: + + %optctl = (); + GetOptions (\%optctl, "sizes=i@"); + +with command line "-sizes 24 -sizes 48" will perform the equivalent of +the assignment + + $optctl{"sizes"} = [24, 48]; + +For hash options (an option whose argument looks like "name=value"), +a reference to a hash is used, e.g.: + + %optctl = (); + GetOptions (\%optctl, "define=s%"); + +with command line "--define foo=hello --define bar=world" will perform the +equivalent of the assignment + + $optctl{"define"} = {foo=>'hello', bar=>'world') + +If no linkage is explicitly specified and no ref HASH is passed, +GetOptions will put the value in a global variable named after the +option, prefixed by "opt_". To yield a usable Perl variable, +characters that are not part of the syntax for variables are +translated to underscores. For example, "--fpp-struct-return" will set +the variable $opt_fpp_struct_return. Note that this variable resides +in the namespace of the calling program, not necessarily B<main>. +For example: + + GetOptions ("size=i", "sizes=i@"); + +with command line "-size 10 -sizes 24 -sizes 48" will perform the +equivalent of the assignments + + $opt_size = 10; + @opt_sizes = (24, 48); + +A lone dash B<-> is considered an option, the corresponding Perl +identifier is $opt_ . + +The linkage specifier can be a reference to a scalar, a reference to +an array, a reference to a hash or a reference to a subroutine. + +If a REF SCALAR is supplied, the new value is stored in the referenced +variable. If the option occurs more than once, the previous value is +overwritten. + +If a REF ARRAY is supplied, the new value is appended (pushed) to the +referenced array. + +If a REF HASH is supplied, the option value should look like "key" or +"key=value" (if the "=value" is omitted then a value of 1 is implied). +In this case, the element of the referenced hash with the key "key" +is assigned "value". + +If a REF CODE is supplied, the referenced subroutine is called with +two arguments: the option name and the option value. +The option name is always the true name, not an abbreviation or alias. + +=head2 Aliases and abbreviations + +The option name may actually be a list of option names, separated by +"|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name +of this option. If no linkage is specified, options "foo", "bar" and +"blech" all will set $opt_foo. For convenience, the single character +"?" is allowed as an alias, e.g. "help|?". + +Option names may be abbreviated to uniqueness, depending on +configuration option B<auto_abbrev>. + +=head2 Non-option call-back routine + +A special option specifier, E<lt>E<gt>, can be used to designate a subroutine +to handle non-option arguments. GetOptions will immediately call this +subroutine for every non-option it encounters in the options list. +This subroutine gets the name of the non-option passed. +This feature requires configuration option B<permute>, see section +CONFIGURATION OPTIONS. + +See also the examples. + +=head2 Option starters + +On the command line, options can start with B<-> (traditional), B<--> +(POSIX) and B<+> (GNU, now being phased out). The latter is not +allowed if the environment variable B<POSIXLY_CORRECT> has been +defined. + +Options that start with "--" may have an argument appended, separated +with an "=", e.g. "--foo=bar". + +=head2 Return values and Errors + +Configuration errors and errors in the option definitions are +signalled using C<die()> and will terminate the calling +program unless the call to C<Getopt::Long::GetOptions()> was embedded +in C<eval { ... }> or C<die()> was trapped using C<$SIG{__DIE__}>. + +A return value of 1 (true) indicates success. + +A return status of 0 (false) indicates that the function detected one +or more errors during option parsing. These errors are signalled using +C<warn()> and can be trapped with C<$SIG{__WARN__}>. + +Errors that can't happen are signalled using C<Carp::croak()>. + +=head1 COMPATIBILITY + +Getopt::Long::GetOptions() is the successor of +B<newgetopt.pl> that came with Perl 4. It is fully upward compatible. +In fact, the Perl 5 version of newgetopt.pl is just a wrapper around +the module. + +If an "@" sign is appended to the argument specifier, the option is +treated as an array. Value(s) are not set, but pushed into array +@opt_name. If explicit linkage is supplied, this must be a reference +to an ARRAY. + +If an "%" sign is appended to the argument specifier, the option is +treated as a hash. Value(s) of the form "name=value" are set by +setting the element of the hash %opt_name with key "name" to "value" +(if the "=value" portion is omitted it defaults to 1). If explicit +linkage is supplied, this must be a reference to a HASH. + +If configuration option B<getopt_compat> is set (see section +CONFIGURATION OPTIONS), options that start with "+" or "-" may also +include their arguments, e.g. "+foo=bar". This is for compatiblity +with older implementations of the GNU "getopt" routine. + +If the first argument to GetOptions is a string consisting of only +non-alphanumeric characters, it is taken to specify the option starter +characters. Everything starting with one of these characters from the +starter will be considered an option. B<Using a starter argument is +strongly deprecated.> + +For convenience, option specifiers may have a leading B<-> or B<-->, +so it is possible to write: + + GetOptions qw(-foo=s --bar=i --ar=s); + +=head1 EXAMPLES + +If the option specifier is "one:i" (i.e. takes an optional integer +argument), then the following situations are handled: + + -one -two -> $opt_one = '', -two is next option + -one -2 -> $opt_one = -2 + +Also, assume specifiers "foo=s" and "bar:s" : + + -bar -xxx -> $opt_bar = '', '-xxx' is next option + -foo -bar -> $opt_foo = '-bar' + -foo -- -> $opt_foo = '--' + +In GNU or POSIX format, option names and values can be combined: + + +foo=blech -> $opt_foo = 'blech' + --bar= -> $opt_bar = '' + --bar=-- -> $opt_bar = '--' + +Example of using variable references: + + $ret = GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar); + +With command line options "-foo blech -bar 24 -ar xx -ar yy" +this will result in: + + $foo = 'blech' + $opt_bar = 24 + @ar = ('xx','yy') + +Example of using the E<lt>E<gt> option specifier: + + @ARGV = qw(-foo 1 bar -foo 2 blech); + GetOptions("foo=i", \$myfoo, "<>", \&mysub); + +Results: + + mysub("bar") will be called (with $myfoo being 1) + mysub("blech") will be called (with $myfoo being 2) + +Compare this with: + + @ARGV = qw(-foo 1 bar -foo 2 blech); + GetOptions("foo=i", \$myfoo); + +This will leave the non-options in @ARGV: + + $myfoo -> 2 + @ARGV -> qw(bar blech) + +=head1 CONFIGURATION OPTIONS + +B<GetOptions> can be configured by calling subroutine +B<Getopt::Long::config>. This subroutine takes a list of quoted +strings, each specifying a configuration option to be set, e.g. +B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g. +B<no_ignore_case>. Case does not matter. Multiple calls to B<config> +are possible. + +Previous versions of Getopt::Long used variables for the purpose of +configuring. Although manipulating these variables still work, it +is strongly encouraged to use the new B<config> routine. Besides, it +is much easier. + +The following options are available: + +=over 12 + +=item default + +This option causes all configuration options to be reset to their +default values. + +=item auto_abbrev + +Allow option names to be abbreviated to uniqueness. +Default is set unless environment variable +POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset. + +=item getopt_compat + +Allow '+' to start options. +Default is set unless environment variable +POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset. + +=item require_order + +Whether non-options are allowed to be mixed with +options. +Default is set unless environment variable +POSIXLY_CORRECT has been set, in which case b<require_order> is reset. + +See also B<permute>, which is the opposite of B<require_order>. + +=item permute + +Whether non-options are allowed to be mixed with +options. +Default is set unless environment variable +POSIXLY_CORRECT has been set, in which case B<permute> is reset. +Note that B<permute> is the opposite of B<require_order>. + +If B<permute> is set, this means that + + -foo arg1 -bar arg2 arg3 + +is equivalent to + + -foo -bar arg1 arg2 arg3 + +If a non-option call-back routine is specified, @ARGV will always be +empty upon succesful return of GetOptions since all options have been +processed, except when B<--> is used: + + -foo arg1 -bar arg2 -- arg3 + +will call the call-back routine for arg1 and arg2, and terminate +leaving arg2 in @ARGV. + +If B<require_order> is set, options processing +terminates when the first non-option is encountered. + + -foo arg1 -bar arg2 arg3 + +is equivalent to + + -foo -- arg1 -bar arg2 arg3 + +=item bundling (default: reset) + +Setting this variable to a non-zero value will allow single-character +options to be bundled. To distinguish bundles from long option names, +long options must be introduced with B<--> and single-character +options (and bundles) with B<->. For example, + + ps -vax --vax + +would be equivalent to + + ps -v -a -x --vax + +provided "vax", "v", "a" and "x" have been defined to be valid +options. + +Bundled options can also include a value in the bundle; for strings +this value is the rest of the bundle, but integer and floating values +may be combined in the bundle, e.g. + + scale -h24w80 + +is equivalent to + + scale -h 24 -w 80 + +Note: resetting B<bundling> also resets B<bundling_override>. + +=item bundling_override (default: reset) + +If B<bundling_override> is set, bundling is enabled as with +B<bundling> but now long option names override option bundles. In the +above example, B<-vax> would be interpreted as the option "vax", not +the bundle "v", "a", "x". + +Note: resetting B<bundling_override> also resets B<bundling>. + +B<Note:> Using option bundling can easily lead to unexpected results, +especially when mixing long options and bundles. Caveat emptor. + +=item ignore_case (default: set) + +If set, case is ignored when matching options. + +Note: resetting B<ignore_case> also resets B<ignore_case_always>. + +=item ignore_case_always (default: reset) + +When bundling is in effect, case is ignored on single-character +options also. + +Note: resetting B<ignore_case_always> also resets B<ignore_case>. + +=item pass_through (default: reset) + +Unknown options are passed through in @ARGV instead of being flagged +as errors. This makes it possible to write wrapper scripts that +process only part of the user supplied options, and passes the +remaining options to some other program. + +This can be very confusing, especially when B<permute> is also set. + +=item debug (default: reset) + +Enable copious debugging output. + +=back + +=head1 OTHER USEFUL VARIABLES + +=over 12 + +=item $Getopt::Long::VERSION + +The version number of this Getopt::Long implementation in the format +C<major>.C<minor>. This can be used to have Exporter check the +version, e.g. + + use Getopt::Long 3.00; + +You can inspect $Getopt::Long::major_version and +$Getopt::Long::minor_version for the individual components. + +=item $Getopt::Long::error + +Internal error flag. May be incremented from a call-back routine to +cause options parsing to fail. + +=back + +=head1 AUTHOR + +Johan Vromans E<lt>jvromans@squirrel.nlE<gt> + +=head1 COPYRIGHT AND DISCLAIMER + +This program is Copyright 1990,1997 by Johan Vromans. +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +If you do not have a copy of the GNU General Public License write to +the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +MA 02139, USA. + +=cut diff --git a/lib/Tie/Array.pm b/lib/Tie/Array.pm new file mode 100644 index 0000000000..336e003b25 --- /dev/null +++ b/lib/Tie/Array.pm @@ -0,0 +1,262 @@ +package Tie::Array; +use vars qw($VERSION); +use strict; +$VERSION = '1.00'; + +# Pod documentation after __END__ below. + +sub DESTROY { } +sub EXTEND { } +sub UNSHIFT { shift->SPLICE(0,0,@_) } +sub SHIFT { shift->SPLICE(0,1) } +sub CLEAR { shift->STORESIZE(0) } + +sub PUSH +{ + my $obj = shift; + my $i = $obj->FETCHSIZE; + $obj->STORE($i++, shift) while (@_); +} + +sub POP +{ + my $obj = shift; + my $newsize = $obj->FETCHSIZE - 1; + my $val; + if ($newsize >= 0) + { + $val = $obj->FETCH($newsize); + $obj->SETSIZE($newsize); + } + $val; +} + +sub SPLICE +{ + my $obj = shift; + my $sz = $obj->FETCHSIZE; + my $off = (@_) ? shift : 0; + $off += $sz if ($off < 0); + my $len = (@_) ? shift : $sz - $off; + my @result; + for (my $i = 0; $i < $len; $i++) + { + push(@result,$obj->FETCH($off+$i)); + } + if (@_ > $len) + { + # Move items up to make room + my $d = @_ - $len; + my $e = $off+$len; + $obj->EXTEND($sz+$d); + for (my $i=$sz-1; $i >= $e; $i--) + { + my $val = $obj->FETCH($i); + $obj->STORE($i+$d,$val); + } + } + elsif (@_ < $len) + { + # Move items down to close the gap + my $d = $len - @_; + my $e = $off+$len; + for (my $i=$off+$len; $i < $sz; $i++) + { + my $val = $obj->FETCH($i); + $obj->STORE($i-$d,$val); + } + $obj->STORESIZE($sz-$d); + } + for (my $i=0; $i < @_; $i++) + { + $obj->STORE($off+$i,$_[$i]); + } + return @result; +} + +package Tie::StdArray; +use vars qw(@ISA); +@ISA = 'Tie::Array'; + +sub TIEARRAY { bless [], $_[0] } +sub FETCHSIZE { scalar @{$_[0]} } +sub STORESIZE { $#{$_[0]} = $_[1]-1 } +sub STORE { $_[0]->[$_[1]] = $_[2] } +sub FETCH { $_[0]->[$_[1]] } +sub CLEAR { @{$_[0]} = () } +sub POP { pop(@{$_[0]}) } +sub PUSH { my $o = shift; push(@$o,@_) } +sub SHIFT { shift(@{$_[0]}) } +sub UNSHIFT { my $o = shift; unshift(@$o,@_) } + +sub SPLICE +{ + my $ob = shift; + my $sz = $ob->FETCHSIZE; + my $off = @_ ? shift : 0; + $off += $sz if $off < 0; + my $len = @_ ? shift : $sz-$off; + return splice(@$ob,$off,$len,@_); +} + +1; + +__END__ + +=head1 NAME + +Tie::Array - base class for tied arrays + +=head1 SYNOPSIS + + package NewArray; + use Tie::Array; + @ISA = ('Tie::Array'); + + # mandatory methods + sub TIEARRAY { ... } + sub FETCH { ... } + sub FETCHSIZE { ... } + + sub STORE { ... } # mandatory if elements writeable + sub STORESIZE { ... } # mandatory if elements can be added/deleted + + # optional methods - for efficiency + sub CLEAR { ... } + sub PUSH { ... } + sub POP { ... } + sub SHIFT { ... } + sub UNSHIFT { ... } + sub SPLICE { ... } + sub EXTEND { ... } + sub DESTROY { ... } + + package NewStdArray; + use Tie::Array; + + @ISA = ('Tie::StdArray'); + + # all methods provided by default + + package main; + + $object = tie @somearray,Tie::NewArray; + $object = tie @somearray,Tie::StdArray; + $object = tie @somearray,Tie::NewStdArray; + + + +=head1 DESCRIPTION + +This module provides methods for array-tying classes. See +L<perltie> for a list of the functions required in order to tie an array +to a package. The basic B<Tie::Array> package provides stub C<DELETE> +and C<EXTEND> methods, and implementations of C<PUSH>, C<POP>, C<SHIFT>, +C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>, +C<FETCHSIZE>, C<STORESIZE>. + +The B<Tie::StdHash> package provides efficient methods required for tied arrays +which are implemented as blessed references to an "inner" perl array. +It inherits from B<Tie::Array>, and should cause tied arrays to behave exactly +like standard hashes, allowing for selective overloading of methods. + +For developers wishing to write their own tied arrays, the required methods +are briefly defined below. See the L<perltie> section for more detailed +descriptive, as well as example code: + +=over + +=item TIEARRAY classname, LIST + +The class method is invoked by the command C<tie @array, classname>. Associates +an array instance with the specified class. C<LIST> would represent +additional arguments (along the lines of L<AnyDBM_File> and compatriots) needed +to complete the association. The method should return an object of a class which +provides the methods below. + +=item STORE this, index, value + +Store datum I<value> into I<index> for the tied array assoicated with +object I<this>. If this makes the array larger then +class's mapping of C<undef> should be returned for new positions. + +=item FETCH this, index + +Retrieve the datum in I<index> for the tied array assoicated with +object I<this>. + +=item FETCHSIZE this + +Returns the total number of items in the tied array assoicated with +object I<this>. (Equivalent to C<scalar(@array)>). + +=item STORESIZE this, count + +Sets the total number of items in the tied array assoicated with +object I<this> to be I<count>. If this makes the array larger then +class's mapping of C<undef> should be returned for new positions. +If the array becomes smaller then entries beyond count should be +deleted. + +=item EXTEND this, count + +Informative call that array is likely to grow to have I<count> entries. +Can be used to optimize allocation. This method need do nothing. + +=item CLEAR this + +Clear (remove, delete, ...) all values from the tied array assoicated with +object I<this>. + +=item DESTROY this + +Normal object destructor method. + +=item PUSH this, LIST + +Append elements of LIST to the array. + +=item POP this + +Remove last element of the array and return it. + +=item SHIFT this + +Remove the first element of the array (shifting other elements down) +and return it. + +=item UNSHIFT this, LIST + +Insert LIST elements at the begining of the array, moving existing elements +up to make room. + +=item SPLICE this, offset, length, LIST + +Perform the equivalent of C<splice> on the array. + +I<offset> is optional and defaults to zero, negative values count back +from the end of the array. + +I<length> is optional and defaults to rest of the array. + +I<LIST> may be empty. + +Returns a list of the original I<length> elements at I<offset>. + +=back + +=head1 CAVEATS + +There is no support at present for tied @ISA. There is a potential conflict +between magic entries needed to notice setting of @ISA, and those needed to +implement 'tie'. + +Very little consideration has been given to the behaviour of tied arrays +when C<$[> is not default value of zero. + +=head1 AUTHOR + +Nick Ing-Simmons E<lt>nik@tiuk.ti.comE<gt> + +=cut + diff --git a/lib/blib.pm b/lib/blib.pm index 9e0f6c07c3..1d56a58174 100644 --- a/lib/blib.pm +++ b/lib/blib.pm @@ -45,6 +45,7 @@ sub import { my $package = shift; my $dir = getcwd; + if ($^O eq 'VMS') { ($dir = VMS::Filespec::unixify($dir)) =~ s-/$--; } if (@_) { $dir = shift; @@ -190,6 +190,37 @@ mg_len(SV *sv) return len; } +I32 +mg_size(SV *sv) +{ + MAGIC* mg; + I32 len; + + for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { + MGVTBL* vtbl = mg->mg_virtual; + if (vtbl && vtbl->svt_len) { + MGS mgs; + ENTER; + /* omit MGf_GSKIP -- not changed here */ + len = (*vtbl->svt_len)(sv, mg); + LEAVE; + return len; + } + } + + switch(SvTYPE(sv)) { + case SVt_PVAV: + len = AvFILLp((AV *) sv); /* Fallback to non-tied array */ + return len; + case SVt_PVHV: + /* FIXME */ + default: + croak("Size magic not implemented"); + break; + } + return 0; +} + int mg_clear(SV *sv) { @@ -895,8 +926,9 @@ magic_setisa(SV *sv, MAGIC *mg) stash = GvSTASH(mg->mg_obj); svp = AvARRAY((AV*)sv); - - for (fill = AvFILL((AV*)sv); fill >= 0; fill--, svp++) { + + /* NOTE: No support for tied ISA */ + for (fill = AvFILLp((AV*)sv); fill >= 0; fill--, svp++) { HV *basestash = gv_stashsv(*svp, FALSE); if (!basestash) { @@ -950,6 +982,33 @@ magic_setnkeys(SV *sv, MAGIC *mg) LvTARG(sv) = Nullsv; /* Don't allow a ref to reassign this. */ } return 0; +} + +static int +magic_methcall(MAGIC *mg, char *meth, I32 flags, int n, SV *val) +{ + dSP; + + PUSHMARK(sp); + EXTEND(sp, n); + PUSHs(mg->mg_obj); + if (n > 1) { + if (mg->mg_ptr) { + if (mg->mg_length >= 0) + PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_length))); + else if (mg->mg_length == HEf_SVKEY) + PUSHs((SV*)mg->mg_ptr); + } + else if (mg->mg_type == 'p') { + PUSHs(sv_2mortal(newSViv(mg->mg_length))); + } + } + if (n > 2) { + PUSHs(val); + } + PUTBACK; + + return perl_call_method(meth, flags); } STATIC int @@ -959,21 +1018,10 @@ magic_methpack(SV *sv, MAGIC *mg, char *meth) ENTER; SAVETMPS; - PUSHMARK(sp); - EXTEND(sp, 2); - PUSHs(mg->mg_obj); - if (mg->mg_ptr) { - if (mg->mg_length >= 0) - PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_length))); - else if (mg->mg_length == HEf_SVKEY) - PUSHs((SV*)mg->mg_ptr); - } - else if (mg->mg_type == 'p') - PUSHs(sv_2mortal(newSViv(mg->mg_length))); - PUTBACK; - if (perl_call_method(meth, G_SCALAR)) + if (magic_methcall(mg, meth, G_SCALAR, 2, NULL)) { sv_setsv(sv, *stack_sp--); + } FREETMPS; LEAVE; @@ -991,25 +1039,10 @@ magic_getpack(SV *sv, MAGIC *mg) int magic_setpack(SV *sv, MAGIC *mg) -{ - dSP; - - PUSHMARK(sp); - EXTEND(sp, 3); - PUSHs(mg->mg_obj); - if (mg->mg_ptr) { - if (mg->mg_length >= 0) - PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_length))); - else if (mg->mg_length == HEf_SVKEY) - PUSHs((SV*)mg->mg_ptr); - } - else if (mg->mg_type == 'p') - PUSHs(sv_2mortal(newSViv(mg->mg_length))); - PUSHs(sv); - PUTBACK; - - perl_call_method("STORE", G_SCALAR|G_DISCARD); - +{ + ENTER; + magic_methcall(mg, "STORE", G_SCALAR|G_DISCARD, 3, sv); + LEAVE; return 0; } @@ -1019,6 +1052,24 @@ magic_clearpack(SV *sv, MAGIC *mg) return magic_methpack(sv,mg,"DELETE"); } + +U32 +magic_sizepack(SV *sv, MAGIC *mg) +{ + dTHR; + U32 retval = 0; + + ENTER; + SAVETMPS; + if (magic_methcall(mg, "FETCHSIZE", G_SCALAR, 2, NULL)) { + sv = *stack_sp--; + retval = (U32) SvIV(sv)-1; + } + FREETMPS; + LEAVE; + return retval; +} + int magic_wipepack(SV *sv, MAGIC *mg) { dSP; @@ -1026,9 +1077,9 @@ int magic_wipepack(SV *sv, MAGIC *mg) PUSHMARK(sp); XPUSHs(mg->mg_obj); PUTBACK; - + ENTER; perl_call_method("CLEAR", G_SCALAR|G_DISCARD); - + LEAVE; return 0; } @@ -1238,7 +1289,7 @@ magic_getdefelem(SV *sv, MAGIC *mg) targ = HeVAL(he); } else { - AV* av = (AV*)LvTARG(sv); + AV* av = (AV*)LvTARG(sv); if ((I32)LvTARGOFF(sv) <= AvFILL(av)) targ = AvARRAY(av)[LvTARGOFF(sv)]; } @@ -1842,7 +1893,7 @@ sighandler(int sig) oldstack = curstack; if (curstack != signalstack) - AvFILL(signalstack) = 0; + AvFILLp(signalstack) = 0; SWITCHSTACK(curstack, signalstack); if(psig_name[sig]) { @@ -116,9 +116,9 @@ pad_allocmy(char *name) } croak("Can't use global %s in \"my\"",name); } - if (dowarn && AvFILL(comppad_name) >= 0) { + if (dowarn && AvFILLp(comppad_name) >= 0) { SV **svp = AvARRAY(comppad_name); - for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) { + for (off = AvFILLp(comppad_name); off > comppad_name_floor; off--) { if ((sv = svp[off]) && sv != &sv_undef && SvIVX(sv) == 999999999 /* var is in open scope */ @@ -184,7 +184,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) continue; curname = (AV*)*svp; svp = AvARRAY(curname); - for (off = AvFILL(curname); off > 0; off--) { + for (off = AvFILLp(curname); off > 0; off--) { if ((sv = svp[off]) && sv != &sv_undef && seq <= SvIVX(sv) && @@ -315,7 +315,7 @@ pad_findmy(char *name) #endif /* USE_THREADS */ /* The one we're looking for is probably just before comppad_name_fill. */ - for (off = AvFILL(comppad_name); off > 0; off--) { + for (off = AvFILLp(comppad_name); off > 0; off--) { if ((sv = svp[off]) && sv != &sv_undef && (!SvIVX(sv) || @@ -353,7 +353,7 @@ pad_leavemy(I32 fill) } } /* "Deintroduce" my variables that are leaving with this scope. */ - for (off = AvFILL(comppad_name); off > fill; off--) { + for (off = AvFILLp(comppad_name); off > fill; off--) { if ((sv = svp[off]) && sv != &sv_undef && SvIVX(sv) == 999999999) SvIVX(sv) = cop_seqmax; } @@ -372,13 +372,13 @@ pad_alloc(I32 optype, U32 tmptype) pad_reset(); if (tmptype & SVs_PADMY) { do { - sv = *av_fetch(comppad, AvFILL(comppad) + 1, TRUE); + sv = *av_fetch(comppad, AvFILLp(comppad) + 1, TRUE); } while (SvPADBUSY(sv)); /* need a fresh one */ - retval = AvFILL(comppad); + retval = AvFILLp(comppad); } else { SV **names = AvARRAY(comppad_name); - SSize_t names_fill = AvFILL(comppad_name); + SSize_t names_fill = AvFILLp(comppad_name); for (;;) { /* * "foreach" index vars temporarily become aliases to non-"my" @@ -1510,7 +1510,7 @@ block_start(int full) int retval = savestack_ix; SAVEI32(comppad_name_floor); if (full) { - if ((comppad_name_fill = AvFILL(comppad_name)) > 0) + if ((comppad_name_fill = AvFILLp(comppad_name)) > 0) comppad_name_floor = comppad_name_fill; else comppad_name_floor = 0; @@ -3034,7 +3034,7 @@ cv_undef(CV *cv) if (CvPADLIST(cv)) { /* may be during global destruction */ if (SvREFCNT(CvPADLIST(cv))) { - I32 i = AvFILL(CvPADLIST(cv)); + I32 i = AvFILLp(CvPADLIST(cv)); while (i >= 0) { SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE); SV* sv = svp ? *svp : Nullsv; @@ -3088,7 +3088,7 @@ CV* cv; pname = AvARRAY(pad_name); ppad = AvARRAY(pad); - for (ix = 1; ix <= AvFILL(pad_name); ix++) { + for (ix = 1; ix <= AvFILLp(pad_name); ix++) { if (SvPOK(pname[ix])) PerlIO_printf(Perl_debug_log, "\t%4d. 0x%lx (%s\"%s\" %ld-%ld)\n", ix, ppad[ix], @@ -3111,8 +3111,8 @@ cv_clone2(CV *proto, CV *outside) AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE); SV** pname = AvARRAY(protopad_name); SV** ppad = AvARRAY(protopad); - I32 fname = AvFILL(protopad_name); - I32 fpad = AvFILL(protopad); + I32 fname = AvFILLp(protopad_name); + I32 fpad = AvFILLp(protopad); AV* comppadlist; CV* cv; @@ -3157,7 +3157,7 @@ cv_clone2(CV *proto, CV *outside) av_store(comppadlist, 0, (SV*)comppad_name); av_store(comppadlist, 1, (SV*)comppad); CvPADLIST(cv) = comppadlist; - av_fill(comppad, AvFILL(protopad)); + av_fill(comppad, AvFILLp(protopad)); curpad = AvARRAY(comppad); av = newAV(); /* will be @_ */ @@ -3394,12 +3394,12 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) return cv; } - if (AvFILL(comppad_name) < AvFILL(comppad)) - av_store(comppad_name, AvFILL(comppad), Nullsv); + if (AvFILLp(comppad_name) < AvFILLp(comppad)) + av_store(comppad_name, AvFILLp(comppad), Nullsv); if (CvCLONE(cv)) { SV **namep = AvARRAY(comppad_name); - for (ix = AvFILL(comppad); ix > 0; ix--) { + for (ix = AvFILLp(comppad); ix > 0; ix--) { SV *namesv; if (SvIMMORTAL(curpad[ix])) @@ -3425,7 +3425,7 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) av_store(comppad, 0, (SV*)av); AvFLAGS(av) = AVf_REIFY; - for (ix = AvFILL(comppad); ix > 0; ix--) { + for (ix = AvFILLp(comppad); ix > 0; ix--) { if (SvIMMORTAL(curpad[ix])) continue; if (!SvPADMY(curpad[ix])) @@ -3614,7 +3614,7 @@ newFORM(I32 floor, OP *o, OP *block) CvGV(cv) = (GV*)SvREFCNT_inc(gv); CvFILEGV(cv) = curcop->cop_filegv; - for (ix = AvFILL(comppad); ix > 0; ix--) { + for (ix = AvFILLp(comppad); ix > 0; ix--) { if (!SvPADMY(curpad[ix]) && !SvIMMORTAL(curpad[ix])) SvPADTMP_on(curpad[ix]); } diff --git a/os2/OS2/PrfDB/typemap b/os2/OS2/PrfDB/typemap index 0b91f3750a..1e01470f87 100644 --- a/os2/OS2/PrfDB/typemap +++ b/os2/OS2/PrfDB/typemap @@ -11,4 +11,4 @@ T_PVNULL ############################################################################# OUTPUT T_PVNULL - sv_setpv((SV*)$arg, $var); + SvSetMagicPV((SV*)$arg, $var); @@ -140,7 +140,8 @@ register struct op *op asm(stringify(OP_IN_REGISTER)); # define STANDARD_C 1 #endif -#if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(OS2) +#if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(OS2) \ + || defined(__DGUX) # define DONT_DECLARE_STD 1 #endif @@ -977,7 +978,7 @@ typedef union any ANY; typedef I32 (*filter_t) _((int, SV *, int)); #define FILTER_READ(idx, sv, len) filter_read(idx, sv, len) #define FILTER_DATA(idx) (AvARRAY(rsfp_filters)[idx]) -#define FILTER_ISREADER(idx) (idx >= AvFILL(rsfp_filters)) +#define FILTER_ISREADER(idx) (idx >= AvFILLp(rsfp_filters)) #ifdef DOSISH # if defined(OS2) @@ -1449,7 +1450,9 @@ int runops_debug _((void)); /* VMS doesn't use environ array and NeXT has problems with crt0.o globals */ #if !defined(VMS) && !(defined(NeXT) && defined(__DYNAMIC__)) -#if !defined(DONT_DECLARE_STD) || (defined(__svr4__) && defined(__GNUC__) && defined(sun)) || defined(__sgi) +#if !defined(DONT_DECLARE_STD) \ + || (defined(__svr4__) && defined(__GNUC__) && defined(sun)) \ + || defined(__sgi) || defined(__DGUX) extern char ** environ; /* environment variables supplied via exec */ #endif #else @@ -1848,7 +1851,7 @@ EXT MGVTBL vtbl_sigelem = {magic_getsig, magic_setsig, 0, magic_clearsig, 0}; -EXT MGVTBL vtbl_pack = {0, 0, 0, magic_wipepack, +EXT MGVTBL vtbl_pack = {0, 0, magic_sizepack, magic_wipepack, 0}; EXT MGVTBL vtbl_packelem = {magic_getpack, magic_setpack, diff --git a/perl_exp.SH b/perl_exp.SH index 06b587f9ef..067ebec135 100644 --- a/perl_exp.SH +++ b/perl_exp.SH @@ -54,6 +54,13 @@ y*) ;; *) sed -n '/^[A-Za-z]/ s/^/Perl_/p' global.sym interp.sym >> perl.exp + expperlvars=/tmp/exp$$pv + expthrdvar=/tmp/exp$$tv + sed -n 's/^PERLVARI*(G\([^,]*\).*/Perl_\1/p' perlvars.h >> $expperlvars + sed -n 's/^PERLVARI*(T\([^,]*\).*/Perl_\1/p' thrdvar.h >> $expthrdvar + # The shebang line nicely sorts as the first one. + sort -o perl.exp -u perl.exp $expperlvars $expthrdvar + rm -f $expperlvars $expthrdvar ;; esac @@ -2,18 +2,6 @@ #define H_PERLDIR 1 #ifdef PERL_OBJECT - -#include "ipdir.h" - -#define PerlDir_mkdir(name, mode) piDir->MKdir((name), (mode), ErrorNo()) -#define PerlDir_chdir(name) piDir->Chdir((name), ErrorNo()) -#define PerlDir_rmdir(name) piDir->Rmdir((name), ErrorNo()) -#define PerlDir_close(dir) piDir->Close((dir), ErrorNo()) -#define PerlDir_open(name) piDir->Open((name), ErrorNo()) -#define PerlDir_read(dir) piDir->Read((dir), ErrorNo()) -#define PerlDir_rewind(dir) piDir->Rewind((dir), ErrorNo()) -#define PerlDir_seek(dir, loc) piDir->Seek((dir), (loc), ErrorNo()) -#define PerlDir_tell(dir) piDir->Tell((dir), ErrorNo()) #else #define PerlDir_mkdir(name, mode) mkdir((name), (mode)) #define PerlDir_chdir(name) chdir((name)) @@ -2,12 +2,6 @@ #define H_PERLENV 1 #ifdef PERL_OBJECT - -#include "ipenv.h" - -#define PerlEnv_putenv(str) piENV->Putenv((str), ErrorNo()) -#define PerlEnv_getenv(str) piENV->Getenv((str), ErrorNo()) -#define PerlEnv_lib_path piENV->LibPath #else #define PerlEnv_putenv(str) putenv((str)) #define PerlEnv_getenv(str) getenv((str)) @@ -2,33 +2,6 @@ #define H_PERLLIO 1 #ifdef PERL_OBJECT - -#include "iplio.h" - -#define PerlLIO_access(file, mode) piLIO->Access((file), (mode), ErrorNo()) -#define PerlLIO_chmod(file, mode) piLIO->Chmod((file), (mode), ErrorNo()) -#define PerlLIO_chsize(fd, size) piLIO->Chsize((fd), (size), ErrorNo()) -#define PerlLIO_close(fd) piLIO->Close((fd), ErrorNo()) -#define PerlLIO_dup(fd) piLIO->Dup((fd), ErrorNo()) -#define PerlLIO_dup2(fd1, fd2) piLIO->Dup2((fd1), (fd2), ErrorNo()) -#define PerlLIO_flock(fd, op) piLIO->Flock((fd), (op), ErrorNo()) -#define PerlLIO_fstat(fd, buf) piLIO->FStat((fd), (buf), ErrorNo()) -#define PerlLIO_ioctl(fd, u, buf) piLIO->IOCtl((fd), (u), (buf), ErrorNo()) -#define PerlLIO_isatty(fd) piLIO->Isatty((fd), ErrorNo()) -#define PerlLIO_lseek(fd, offset, mode) piLIO->Lseek((fd), (offset), (mode), ErrorNo()) -#define PerlLIO_lstat(name, buf) piLIO->Lstat((name), (buf), ErrorNo()) -#define PerlLIO_mktemp(file) piLIO->Mktemp((file), ErrorNo()) -#define PerlLIO_open(file, flag) piLIO->Open((file), (flag), ErrorNo()) -#define PerlLIO_open3(file, flag, perm) piLIO->Open((file), (flag), (perm), ErrorNo()) -#define PerlLIO_read(fd, buf, count) piLIO->Read((fd), (buf), (count), ErrorNo()) -#define PerlLIO_rename(oldname, newname) piLIO->Rename((oldname), (newname), ErrorNo()) -#define PerlLIO_setmode(fd, mode) piLIO->Setmode((fd), (mode), ErrorNo()) -#define PerlLIO_stat(name, buf) piLIO->STat((name), (buf), ErrorNo()) -#define PerlLIO_tmpnam(str) piLIO->Tmpnam((str), ErrorNo()) -#define PerlLIO_umask(mode) piLIO->Umask((mode), ErrorNo()) -#define PerlLIO_unlink(file) piLIO->Unlink((file), ErrorNo()) -#define PerlLIO_utime(file, time) piLIO->Utime((file), (time), ErrorNo()) -#define PerlLIO_write(fd, buf, count) piLIO->Write((fd), (buf), (count), ErrorNo()) #else #define PerlLIO_access(file, mode) access((file), (mode)) #define PerlLIO_chmod(file, mode) chmod((file), (mode)) @@ -36,9 +9,7 @@ #define PerlLIO_close(fd) close((fd)) #define PerlLIO_dup(fd) dup((fd)) #define PerlLIO_dup2(fd1, fd2) dup2((fd1), (fd2)) -#define PerlLIO_flock(fd, op) FLOCK((fd), (op)) #define PerlLIO_fstat(fd, buf) Fstat((fd), (buf)) -#define PerlLIO_ioctl(fd, u, buf) ioctl((fd), (u), (buf)) #define PerlLIO_isatty(fd) isatty((fd)) #define PerlLIO_lseek(fd, offset, mode) lseek((fd), (offset), (mode)) #define PerlLIO_lstat(name, buf) lstat((name), (buf)) @@ -2,12 +2,6 @@ #define H_PERLMEM 1 #ifdef PERL_OBJECT - -#include "ipmem.h" - -#define PerlMem_malloc(size) piMem->Malloc((size)) -#define PerlMem_realloc(buf, size) piMem->Realloc((buf), (size)) -#define PerlMem_free(buf) piMem->Free((buf)) #else #define PerlMem_malloc(size) malloc((size)) #define PerlMem_realloc(buf, size) realloc((buf), (size)) diff --git a/perlproc.h b/perlproc.h index 8e58c2232d..40218c2814 100644 --- a/perlproc.h +++ b/perlproc.h @@ -2,42 +2,6 @@ #define H_PERLPROC 1 #ifdef PERL_OBJECT - -#include "ipproc.h" - -#define PerlProc_abort() piProc->Abort() -#define PerlProc_exit(s) piProc->Exit((s)) -#define PerlProc__exit(s) piProc->_Exit((s)) -#define PerlProc_execl(c, w, x, y, z) piProc->Execl((c), (w), (x), (y), (z)) -#define PerlProc_execv(c, a) piProc->Execv((c), (a)) -#define PerlProc_execvp(c, a) piProc->Execvp((c), (a)) -#define PerlProc_getuid() piProc->Getuid() -#define PerlProc_geteuid() piProc->Geteuid() -#define PerlProc_getgid() piProc->Getgid() -#define PerlProc_getegid() piProc->Getegid() -#define PerlProc_getlogin() piProc->Getlogin() -#define PerlProc_kill(i, a) piProc->Kill((i), (a)) -#define PerlProc_killpg(i, a) piProc->Killpg((i), (a)) -#define PerlProc_pause() piProc->PauseProc() -#define PerlProc_popen(c, m) piProc->Popen((c), (m)) -#define PerlProc_pclose(f) piProc->Pclose((f)) -#define PerlProc_pipe(fd) piProc->Pipe((fd)) -#define PerlProc_setuid(u) piProc->Setuid((u)) -#define PerlProc_setgid(g) piProc->Setgid((g)) -#define PerlProc_sleep(t) piProc->Sleep((t)) -#define PerlProc_times(t) piProc->Times((t)) -#define PerlProc_wait(t) piProc->Wait((t)) -#define PerlProc_setjmp(b, n) Sigsetjmp((b), (n)) -#define PerlProc_longjmp(b, n) Siglongjmp((b), (n)) -#define PerlProc_signal(n, h) piProc->Signal((n), (h)) -#ifdef WIN32 -#define PerlProc_GetSysMsg(s,l,e) piProc->GetSysMsg((s), (l), (e)) -#define PerlProc_FreeBuf(s) piProc->FreeBuf((s)) -#define PerlProc_Cmd(s) piProc->DoCmd((s)) -#define do_spawn(s) piProc->Spawn((s)) -#define do_spawnvp(m, c, a) piProc->Spawnvp((m), (c), (a)) -#define PerlProc_aspawn(m, c, a) piProc->ASpawn((m), (c), (a)) -#endif #else #define PerlProc_abort() abort() #define PerlProc_exit(s) exit((s)) @@ -45,22 +9,11 @@ #define PerlProc_execl(c, w, x, y, z) execl((c), (w), (x), (y), (z)) #define PerlProc_execv(c, a) execv((c), (a)) #define PerlProc_execvp(c, a) execvp((c), (a)) -#define PerlProc_getuid() getuid() -#define PerlProc_geteuid() geteuid() -#define PerlProc_getgid() getgid() -#define PerlProc_getegid() getegid() -#define PerlProc_getlogin() getlogin() #define PerlProc_kill(i, a) kill((i), (a)) #define PerlProc_killpg(i, a) killpg((i), (a)) -#define PerlProc_pause() Pause() #define PerlProc_popen(c, m) my_popen((c), (m)) #define PerlProc_pclose(f) my_pclose((f)) #define PerlProc_pipe(fd) pipe((fd)) -#define PerlProc_setuid(u) setuid((u)) -#define PerlProc_setgid(g) setgid((g)) -#define PerlProc_sleep(t) sleep((t)) -#define PerlProc_times(t) times((t)) -#define PerlProc_wait(t) wait((t)) #define PerlProc_setjmp(b, n) Sigsetjmp((b), (n)) #define PerlProc_longjmp(b, n) Siglongjmp((b), (n)) #define PerlProc_signal(n, h) signal((n), (h)) diff --git a/perlsock.h b/perlsock.h index d1ae265fcf..5c83082840 100644 --- a/perlsock.h +++ b/perlsock.h @@ -2,95 +2,36 @@ #define H_PERLSOCK 1 #ifdef PERL_OBJECT - -#include "ipsock.h" - -#define PerlSock_htonl(x) piSock->Htonl(x) -#define PerlSock_htons(x) piSock->Htons(x) -#define PerlSock_ntohl(x) piSock->Ntohl(x) -#define PerlSock_ntohs(x) piSock->Ntohs(x) -#define PerlSock_accept(s, a, l) piSock->Accept(s, a, l, ErrorNo()) -#define PerlSock_bind(s, n, l) piSock->Bind(s, n, l, ErrorNo()) -#define PerlSock_connect(s, n, l) piSock->Connect(s, n, l, ErrorNo()) -#define PerlSock_endhostent() piSock->Endhostent(ErrorNo()) -#define PerlSock_endnetent() piSock->Endnetent(ErrorNo()) -#define PerlSock_endprotoent() piSock->Endprotoent(ErrorNo()) -#define PerlSock_endservent() piSock->Endservent(ErrorNo()) -#define PerlSock_gethostbyaddr(a, l, t) piSock->Gethostbyaddr(a, l, t, ErrorNo()) -#define PerlSock_gethostbyname(n) piSock->Gethostbyname(n, ErrorNo()) -#define PerlSock_gethostent() piSock->Gethostent(ErrorNo()) -#define PerlSock_gethostname(n, l) piSock->Gethostname(n, l, ErrorNo()) -#define PerlSock_getnetbyaddr(n, t) piSock->Getnetbyaddr(n, t, ErrorNo()) -#define PerlSock_getnetbyname(c) piSock->Getnetbyname(c, ErrorNo()) -#define PerlSock_getnetent() piSock->Getnetent(ErrorNo()) -#define PerlSock_getpeername(s, n, l) piSock->Getpeername(s, n, l, ErrorNo()) -#define PerlSock_getprotobyname(n) piSock->Getprotobyname(n, ErrorNo()) -#define PerlSock_getprotobynumber(n) piSock->Getprotobynumber(n, ErrorNo()) -#define PerlSock_getprotoent() piSock->Getprotoent(ErrorNo()) -#define PerlSock_getservbyname(n, p) piSock->Getservbyname(n, p, ErrorNo()) -#define PerlSock_getservbyport(port, p) piSock->Getservbyport(port, p, ErrorNo()) -#define PerlSock_getservent() piSock->Getservent(ErrorNo()) -#define PerlSock_getsockname(s, n, l) piSock->Getsockname(s, n, l, ErrorNo()) -#define PerlSock_getsockopt(s, l, n, v, i) piSock->Getsockopt(s, l, n, v, i, ErrorNo()) -#define PerlSock_inet_addr(c) piSock->InetAddr(c, ErrorNo()) -#define PerlSock_inet_ntoa(i) piSock->InetNtoa(i, ErrorNo()) -#define PerlSock_listen(s, b) piSock->Listen(s, b, ErrorNo()) -#define PerlSock_recvfrom(s, b, l, f, from, fromlen) piSock->Recvfrom(s, b, l, f, from, fromlen, ErrorNo()) -#define PerlSock_select(n, r, w, e, t) piSock->Select(n, (char*)r, (char*)w, (char*)e, t, ErrorNo()) -#define PerlSock_send(s, b, l, f) piSock->Send(s, b, l, f, ErrorNo()) -#define PerlSock_sendto(s, b, l, f, t, tlen) piSock->Sendto(s, b, l, f, t, tlen, ErrorNo()) -#define PerlSock_sethostent(f) piSock->Sethostent(f, ErrorNo()) -#define PerlSock_setnetent(f) piSock->Setnetent(f, ErrorNo()) -#define PerlSock_setprotoent(f) piSock->Setprotoent(f, ErrorNo()) -#define PerlSock_setservent(f) piSock->Setservent(f, ErrorNo()) -#define PerlSock_setsockopt(s, l, n, v, len) piSock->Setsockopt(s, l, n, v, len, ErrorNo()) -#define PerlSock_shutdown(s, h) piSock->Shutdown(s, h, ErrorNo()) -#define PerlSock_socket(a, t, p) piSock->Socket(a, t, p, ErrorNo()) -#define PerlSock_socketpair(a, t, p, f) piSock->Socketpair(a, t, p, f, ErrorNo()) #else -#define PerlSock_htonl(x) htonl(x) -#define PerlSock_htons(x) htons(x) -#define PerlSock_ntohl(x) ntohl(x) -#define PerlSock_ntohs(x) ntohs(x) -#define PerlSock_accept(s, a, l) accept(s, a, l) -#define PerlSock_bind(s, n, l) bind(s, n, l) -#define PerlSock_connect(s, n, l) connect(s, n, l) -#define PerlSock_endhostent() endhostent() -#define PerlSock_endnetent() endnetent() -#define PerlSock_endprotoent() endprotoent() -#define PerlSock_endservent() endservent() -#define PerlSock_gethostbyaddr(a, l, t) gethostbyaddr(a, l, t) -#define PerlSock_gethostbyname(n) gethostbyname(n) +#define PerlSock_htonl(x) htonl((x)) +#define PerlSock_htons(x) htons((x)) +#define PerlSock_ntohl(x) ntohl((x)) +#define PerlSock_ntohs(x) ntohs((x)) +#define PerlSock_accept(s, a, l) accept((s), (a), (l)) +#define PerlSock_bind(s, n, l) bind((s), (n), (l)) +#define PerlSock_connect(s, n, l) connect((s), (n), (l)) +#define PerlSock_gethostbyaddr(a, l, t) gethostbyaddr((a), (l), (t)) +#define PerlSock_gethostbyname(n) gethostbyname((n)) #define PerlSock_gethostent() gethostent() -#define PerlSock_gethostname(n, l) gethostname(n, l) -#define PerlSock_getnetbyaddr(n, t) getnetbyaddr(n, t) -#define PerlSock_getnetbyname(c) getnetbyname(c) -#define PerlSock_getnetent() getnetent() -#define PerlSock_getpeername(s, n, l) getpeername(s, n, l) -#define PerlSock_getprotobyname(n) getprotobyname(n) -#define PerlSock_getprotobynumber(n) getprotobynumber(n) +#define PerlSock_gethostname(n, l) gethostname((n), (l)) +#define PerlSock_getpeername(s, n, l) getpeername((s), (n), (l)) +#define PerlSock_getprotobyname(n) getprotobyname((n)) +#define PerlSock_getprotobynumber(n) getprotobynumber((n)) #define PerlSock_getprotoent() getprotoent() -#define PerlSock_getservbyname(n, p) getservbyname(n, p) -#define PerlSock_getservbyport(port, p) getservbyport(port, p) +#define PerlSock_getservbyname(n, p) getservbyname((n), (p)) +#define PerlSock_getservbyport(port, p) getservbyport((port), (p)) #define PerlSock_getservent() getservent() -#define PerlSock_getsockname(s, n, l) getsockname(s, n, l) -#define PerlSock_getsockopt(s, l, n, v, i) getsockopt(s, l, n, v, i) -#define PerlSock_inet_addr(c) inet_addr(c) -#define PerlSock_inet_ntoa(i) inet_ntoa(i) -#define PerlSock_listen(s, b) listen(s, b) -#define PerlSock_recvfrom(s, b, l, f, from, fromlen) recvfrom(s, b, l, f, from, fromlen) -#define PerlSock_select(n, r, w, e, t) select(n, r, w, e, t) -#define PerlSock_send(s, b, l, f) send(s, b, l, f) -#define PerlSock_sendto(s, b, l, f, t, tlen) sendto(s, b, l, f, t, tlen) -#define PerlSock_sethostent(f) sethostent(f) -#define PerlSock_setnetent(f) setnetent(f) -#define PerlSock_setprotoent(f) setprotoent(f) -#define PerlSock_setservent(f) setservent(f) -#define PerlSock_setsockopt(s, l, n, v, len) setsockopt(s, l, n, v, len) -#define PerlSock_shutdown(s, h) shutdown(s, h) -#define PerlSock_socket(a, t, p) socket(a, t, p) -#define PerlSock_socketpair(a, t, p, f) socketpair(a, t, p, f) +#define PerlSock_getsockname(s, n, l) getsockname((s), (n), (l)) +#define PerlSock_getsockopt(s, l, n, v, i) getsockopt((s), (l), (n), (v), (i)) +#define PerlSock_listen(s, b) listen((s), (b)) +#define PerlSock_recvfrom(s, b, l, f, from, fromlen) recvfrom((s), (b), (l), (f), (from), (fromlen)) +#define PerlSock_select(n, r, w, e, t) select((n), (r), (w), (e), (t)) +#define PerlSock_send(s, b, l, f) send((s), (b), (l), (f)) +#define PerlSock_sendto(s, b, l, f, t, tlen) sendto((s), (b), (l), (f), (t), (tlen)) +#define PerlSock_setsockopt(s, l, n, v, len) setsockopt((s), (l), (n), (v), (len)) +#define PerlSock_shutdown(s, h) shutdown((s), (h)) +#define PerlSock_socket(a, t, p) socket((a), (t), (p)) +#define PerlSock_socketpair(a, t, p, f) socketpair((a), (t), (p), (f)) #endif /* PERL_OBJECT */ #endif /* Include guard */ - diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index a89ee99e06..a1184c8a08 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -1580,6 +1580,7 @@ elements. That is, modifying an element of a list returned by grep actually modifies the element in the original list. See also L</map> for an array composed of the results of the BLOCK or EXPR. + =item hex EXPR =item hex diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 20a11ac45c..1db8249d24 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -57,7 +57,9 @@ calculate the length by using C<sv_setpv> or by specifying 0 as the second argument to C<newSVpv>. Be warned, though, that Perl will determine the string's length by using C<strlen>, which depends on the string terminating with a NUL character. The arguments of C<sv_setpvf> are processed like -C<sprintf>, and the formatted output becomes the value. +C<sprintf>, and the formatted output becomes the value. The C<sv_set*()> +functions are not generic enough to operate on values that have "magic". +See L<Magic Virtual Tables> later in this document. All SVs that will contain strings should, but need not, be terminated with a NUL character. If it is not NUL-terminated there is a risk of @@ -130,7 +132,9 @@ using C<strlen>. In the second, you specify the length of the string yourself. The third function processes its arguments like C<sprintf> and appends the formatted output. The fourth function extends the string stored in the first SV with the string stored in the second SV. It also -forces the second SV to be interpreted as a string. +forces the second SV to be interpreted as a string. The C<sv_cat*()> +functions are not generic enough to operate on values that have "magic". +See L<Magic Virtual Tables> later in this document. If you know the name of a scalar variable, you can get a pointer to its SV by using the following: @@ -831,6 +835,17 @@ as the extension is sufficient. For '~' magic, it may also be appropriate to add an I32 'signature' at the top of the private data area and check that. +Also note that most of the C<sv_set*()> functions that modify scalars do +B<not> invoke 'set' magic on their targets. This must be done by the user +either by calling the C<SvSETMAGIC()> macro after calling these functions, +or by using one of the C<SvSetMagic*()> macros. Similarly, generic C code +must call the C<SvGETMAGIC()> macro to invoke any 'get' magic if they use +an SV obtained from external sources in functions that don't handle magic. +L<API LISTING> later in this document identifies such macros and functions. +For example, calls to the C<sv_cat*()> functions typically need to be +followed by C<SvSETMAGIC()>, but they don't need a prior C<SvGETMAGIC()> +since their implementation handles 'get' magic. + =head2 Finding Magic MAGIC* mg_find(SV*, int type); /* Finds the magic pointer of that type */ @@ -2324,28 +2339,29 @@ Opening bracket for arguments on a callback. See C<PUTBACK> and L<perlcall>. =item PUSHi Push an integer onto the stack. The stack must have room for this element. -See C<XPUSHi>. +Handles 'set' magic. See C<XPUSHi>. PUSHi(int d) =item PUSHn Push a double onto the stack. The stack must have room for this element. -See C<XPUSHn>. +Handles 'set' magic. See C<XPUSHn>. PUSHn(double d) =item PUSHp Push a string onto the stack. The stack must have room for this element. -The C<len> indicates the length of the string. See C<XPUSHp>. +The C<len> indicates the length of the string. Handles 'set' magic. See +C<XPUSHp>. PUSHp(char *c, int len ) =item PUSHs -Push an SV onto the stack. The stack must have room for this element. See -C<XPUSHs>. +Push an SV onto the stack. The stack must have room for this element. Does +not handle 'set' magic. See C<XPUSHs>. PUSHs(sv) @@ -2492,30 +2508,39 @@ of the SV is unaffected. SV* sv_bless _((SV* sv, HV* stash)); +=item SvCatMagicPV + +=item SvCatMagicPVN + +=item SvCatMagicSV + =item sv_catpv Concatenates the string onto the end of the string which is in the SV. +Handles 'get' magic, but not 'set' magic. See C<SvCatMagicPV>. void sv_catpv _((SV* sv, char* ptr)); =item sv_catpvn Concatenates the string onto the end of the string which is in the SV. The -C<len> indicates number of bytes to copy. +C<len> indicates number of bytes to copy. Handles 'get' magic, but not +'set' magic. See C<SvCatMagicPVN). void sv_catpvn _((SV* sv, char* ptr, STRLEN len)); =item sv_catpvf Processes its arguments like C<sprintf> and appends the formatted output -to an SV. +to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must +typically be called after calling this function to handle 'set' magic. void sv_catpvf _((SV* sv, const char* pat, ...)); =item sv_catsv Concatenates the string from SV C<ssv> onto the end of the string in SV -C<dsv>. +C<dsv>. Handles 'get' magic, but not 'set' magic. See C<SvCatMagicSV). void sv_catsv _((SV* dsv, SV* ssv)); @@ -2559,6 +2584,13 @@ identical. I32 sv_eq _((SV* sv1, SV* sv2)); +=item SvGETMAGIC + +Invokes C<mg_get> on an SV if it has 'get' magic. This macro evaluates +its argument more than once. + + void SvGETMAGIC( SV *sv ) + =item SvGROW Expands the character buffer in the SV. Calls C<sv_grow> to perform the @@ -2776,7 +2808,7 @@ Checks the B<private> setting. Use C<SvPOK>. Returns a pointer to the string in the SV, or a stringified form of the SV if the SV does not contain a string. If C<len> is C<na> then Perl will -handle the length on its own. +handle the length on its own. Handles 'get' magic. char * SvPV (SV* sv, int len ) @@ -2828,6 +2860,13 @@ Dereferences an RV to return the SV. SV* SvRV (SV* sv); +=item SvSETMAGIC + +Invokes C<mg_set> on an SV if it has 'set' magic. This macro evaluates +its argument more than once. + + void SvSETMAGIC( SV *sv ) + =item SvTAINT Taints an SV if tainting is enabled @@ -2857,35 +2896,102 @@ Marks an SV as tainted. SvTAINTED_on (SV* sv); +=item SvSetMagicIV + +A macro that calls C<sv_setiv>, and invokes 'set' magic on the SV. +May evaluate arguments more than once. + + void SvSetMagicIV (SV* sv, IV num) + +=item SvSetMagicNV + +A macro that calls C<sv_setnv>, and invokes 'set' magic on the SV. +May evaluate arguments more than once. + + void SvSetMagicNV (SV* sv, double num) + +=item SvSetMagicPV + +A macro that calls C<sv_setpv>, and invokes 'set' magic on the SV. +May evaluate arguments more than once. + + void SvSetMagicPV (SV* sv, char *ptr) + +=item SvSetMagicPVIV + +A macro that calls C<sv_setpviv>, and invokes 'set' magic on the SV. +May evaluate arguments more than once. + + void SvSetMagicPVIV (SV* sv, IV num) + +=item SvSetMagicPVN + +A macro that calls C<sv_setpvn>, and invokes 'set' magic on the SV. +May evaluate arguments more than once. + + void SvSetMagicPVN (SV* sv, char* ptr, STRLEN len) + +=item SvSetMagicSV + +Same as C<SvSetSV>, but also invokes 'set' magic on the SV. +May evaluate arguments more than once. + + void SvSetMagicSV (SV* dsv, SV* ssv) + +=item SvSetMagicSV_nosteal + +Same as C<SvSetSV_nosteal>, but also invokes 'set' magic on the SV. +May evaluate arguments more than once. + + void SvSetMagicSV_nosteal (SV* dsv, SV* ssv) + +=item SvSetMagicUV + +A macro that calls C<sv_setuv>, and invokes 'set' magic on the SV. +May evaluate arguments more than once. + + void SvSetMagicUV (SV* sv, UV num) + =item sv_setiv -Copies an integer into the given SV. +Copies an integer into the given SV. Does not handle 'set' magic. +See C<SvSetMagicIV>. void sv_setiv _((SV* sv, IV num)); =item sv_setnv -Copies a double into the given SV. +Copies a double into the given SV. Does not handle 'set' magic. +See C<SvSetMagicNV>. void sv_setnv _((SV* sv, double num)); =item sv_setpv Copies a string into an SV. The string must be null-terminated. +Does not handle 'set' magic. See C<SvSetMagicPV>. void sv_setpv _((SV* sv, char* ptr)); +=item sv_setpviv + +Copies an integer into the given SV, also updating its string value. +Does not handle 'set' magic. See C<SvSetMagicPVIV>. + + void sv_setpviv _((SV* sv, IV num)); + =item sv_setpvn Copies a string into an SV. The C<len> parameter indicates the number of -bytes to be copied. +bytes to be copied. Does not handle 'set' magic. See C<SvSetMagicPVN>. void sv_setpvn _((SV* sv, char* ptr, STRLEN len)); =item sv_setpvf Processes its arguments like C<sprintf> and sets an SV to the formatted -output. +output. Does not handle 'set' magic. C<SvSETMAGIC()> must typically +be called after calling this function to handle 'set' magic. void sv_setpvf _((SV* sv, const char* pat, ...)); @@ -2938,13 +3044,36 @@ a reference count of 1. Note that C<sv_setref_pv> copies the pointer while this copies the string. +=item SvSetSV + +Calls C<sv_setsv> if dsv is not the same as ssv. May evaluate arguments +more than once. + + void SvSetSV (SV* dsv, SV* ssv) + +=item SvSetSV_nosteal + +Calls a non-destructive version of C<sv_setsv> if dsv is not the same as ssv. +May evaluate arguments more than once. + + void SvSetSV_nosteal (SV* dsv, SV* ssv) + =item sv_setsv Copies the contents of the source SV C<ssv> into the destination SV C<dsv>. -The source SV may be destroyed if it is mortal. +The source SV may be destroyed if it is mortal. Does not handle 'set' magic. +See the macro forms C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and +C<SvSetMagicSV_nosteal>. void sv_setsv _((SV* dsv, SV* ssv)); +=item sv_setuv + +Copies an unsigned integer into the given SV. Does not handle 'set' magic. +See C<SvSetMagicUV>. + + void sv_setuv _((SV* sv, UV num)); + =item SvSTASH Returns the stash of the SV. @@ -2982,7 +3111,7 @@ Double type flag for scalars. See C<svtype>. =item SvTRUE Returns a boolean indicating whether Perl would evaluate the SV as true or -false, defined or undefined. +false, defined or undefined. Does not handle 'get' magic. int SvTRUE (SV* sv) @@ -3020,6 +3149,8 @@ as a reversal of C<newSVrv>. See C<SvROK_off>. void sv_unref _((SV* sv)); +=item SvUseMagicPVN + =item sv_usepvn Tells an SV to use C<ptr> to find its string value. Normally the string is @@ -3027,7 +3158,8 @@ stored inside the SV but sv_usepvn allows the SV to use an outside string. The C<ptr> should point to memory that was allocated by C<malloc>. The string length, C<len>, must be supplied. This function will realloc the memory pointed to by C<ptr>, so that pointer should not be freed or used by -the programmer after giving it to sv_usepvn. +the programmer after giving it to sv_usepvn. Does not handle 'set' magic. +See C<SvUseMagicPVN>. void sv_usepvn _((SV* sv, char* ptr, STRLEN len)); @@ -3060,28 +3192,29 @@ function the same way you use the C C<printf> function. See C<croak()>. =item XPUSHi -Push an integer onto the stack, extending the stack if necessary. See -C<PUSHi>. +Push an integer onto the stack, extending the stack if necessary. Handles +'set' magic. See C<PUSHi>. XPUSHi(int d) =item XPUSHn -Push a double onto the stack, extending the stack if necessary. See -C<PUSHn>. +Push a double onto the stack, extending the stack if necessary. Handles 'set' +magic. See C<PUSHn>. XPUSHn(double d) =item XPUSHp Push a string onto the stack, extending the stack if necessary. The C<len> -indicates the length of the string. See C<PUSHp>. +indicates the length of the string. Handles 'set' magic. See C<PUSHp>. XPUSHp(char *c, int len) =item XPUSHs -Push an SV onto the stack, extending the stack if necessary. See C<PUSHs>. +Push an SV onto the stack, extending the stack if necessary. Does not +handle 'set' magic. See C<PUSHs>. XPUSHs(sv) @@ -3204,8 +3337,8 @@ Jeff Okamoto <F<okamoto@corp.hp.com>> With lots of help and suggestions from Dean Roehrich, Malcolm Beattie, Andreas Koenig, Paul Hudson, Ilya Zakharevich, Paul Marquess, Neil -Bowers, Matthew Green, Tim Bunce, Spider Boardman, Ulrich Pfeifer, and -Stephen McCamant. +Bowers, Matthew Green, Tim Bunce, Spider Boardman, Ulrich Pfeifer, +Stephen McCamant, and Gurusamy Sarathy. API Listing by Dean Roehrich <F<roehrich@cray.com>>. diff --git a/pod/perlhist.pod b/pod/perlhist.pod new file mode 100644 index 0000000000..9113ed90a4 --- /dev/null +++ b/pod/perlhist.pod @@ -0,0 +1,451 @@ +=pod + +=head1 NAME + +perlhist - the Perl history records + +=for RCS +# +# $Id: perlhist.pod,v 1.27 1998/01/16 19:50:20 jhi Exp $ +# +=end RCS + +=head1 DESCRIPTION + +This document aims to record the Perl source code releases. + +=head1 INTRODUCTION + +Perl history in brief, by Larry Wall: + + Perl 0 introduced Perl to my officemates. + Perl 1 introduced Perl to the world, and changed /\(...\|...\)/ to + /(...|...)/. \(Dan Faigin still hasn't forgiven me. :-\) + Perl 2 introduced Henry Spencer's regular expression package. + Perl 3 introduced the ability to handle binary data (embedded nulls). + Perl 4 introduced the first Camel book. Really. We mostly just + switched version numbers so the book could refer to 4.000. + Perl 5 introduced everything else, including the ability to + introduce everything else. + +=head1 THE KEEPERS OF THE PUMPKIN + +Larry Wall, Andy Dougherty, Tom Christiansen, Charles Bailey, Nick +Ing-Simmons, Chip Salzenberg, Tim Bunce, Malcolm Beattie. + +=head2 PUMPKIN? + +[from Porting/pumpkin.pod in the Perl source code distribution] + +Chip Salzenberg gets credit for that, with a nod to his cow orker, +David Croy. We had passed around various names (baton, token, hot +potato) but none caught on. Then, Chip asked: + +[begin quote] + + Who has the patch pumpkin? + +To explain: David Croy once told me once that at a previous job, +there was one tape drive and multiple systems that used it for backups. +But instead of some high-tech exclusion software, they used a low-tech +method to prevent multiple simultaneous backups: a stuffed pumpkin. +No one was allowed to make backups unless they had the "backup pumpkin". + +[end quote] + +The name has stuck. The holder of the pumpkin is sometimes called +the pumpking or the pumpkineer. + +=head1 THE RECORDS + + Pump- Release Date Notes + king (by no means + comprehensive, + see Changes* + for details) + =========================================================================== + + Larry 0 Classified. Don't ask. + + Larry 1.000 1987-Dec-18 + + 1.001..10 1988-Jan-30 + 1.011..14 1988-Feb-02 + + Larry 2.000 1988-Jun-05 + + 2.001 1988-Jun-28 + + Larry 3.000 1989-Oct-18 + + 3.001 1989-Oct-26 + 3.002..4 1989-Nov-11 + 3.005 1989-Nov-18 + 3.006..8 1989-Dec-22 + 3.009..13 1990-Mar-02 + 3.014 1990-Mar-13 + 3.015 1990-Mar-14 + 3.016..18 1990-Mar-28 + 3.019..27 1990-Aug-10 User subs. + 3.028 1990-Aug-14 + 3.029..36 1990-Oct-17 + 3.037 1990-Oct-20 + 3.040 1990-Nov-10 + 3.041 1990-Nov-13 + 3.042..43 1990-Jan-91 + 3.044 1991-Jan-12 + + Larry 4.000 1991-Mar-21 + + 4.001..3 1991-Apr-12 + 4.004..9 1991-Jun-07 + 4.010 1991-Jun-10 + 4.011..18 1991-Nov-05 + 4.019 1991-Nov-11 Stable. + 4.020..33 1992-Jun-08 + 4.034 1992-Jun-11 + 4.035 1992-Jun-23 + Larry 4.036 1993-Feb-05 Very stable. + + 5.000alpha1 1993-Jul-31 + 5.000alpha2 1993-Aug-16 + 5.000alpha3 1993-Oct-10 + 5.000alpha4 1993-???-?? + 5.000alpha5 1993-???-?? + 5.000alpha6 1993-Mar-18 + 5.003alpha7 1994-Mar-25 + Andy 5.000alpha8 1994-Apr-04 + Larry 5.000alpha9 1994-May-05 + 5.000alpha10 1994-???-?? + 5.000alpha11 1994-???-?? + Andy 5.000a11a 1994-Jul-07 To fit 14. + 5.000a11b 1994-Jul-14 + 5.000a11c 1994-Jul-19 + 5.000a11d 1994-Jul-22 + Larry 5.000alpha12 1994-???-?? + Andy 5.000a12a 1994-Aug-08 + 5.000a12b 1994-Aug-15 + 5.000a12c 1994-Aug-22 + 5.000a12d 1994-Aug-22 + 5.000a12e 1994-Aug-22 + 5.000a12f 1994-Aug-24 + 5.000a12g 1994-Aug-24 + 5.000a12h 1994-Aug-24 + Larry 5.000beta1 1994-???-?? + Andy 5.000b1a 1994-???-?? + Larry 5.000beta2 1994-Sep-14 Core slushified. + Andy 5.000b2a 1994-Sep-14 + 5.000b2b 1994-Sep-17 + 5.000b2c 1994-Sep-17 + Larry 5.000beta3 1994-???-?? + Andy 5.000b3a 1994-Sep-18 + 5.000b3b 1994-Sep-22 + 5.000b3c 1994-Sep-23 + 5.000b3d 1994-Sep-27 + 5.000b3e 1994-Sep-28 + 5.000b3f 1994-Sep-30 + 5.000b3g 1994-Oct-04 + Andy 5.000b3h 1994-Oct-07 + + Larry 5.000 1994-Oct-18 + + Andy 5.000a 1994-Dec-19 + 5.000b 1995-Jan-18 + 5.000c 1995-Jan-18 + 5.000d 1995-Jan-18 + 5.000e 1995-Jan-18 + 5.000f 1995-Jan-18 + 5.000g 1995-Jan-18 + 5.000h 1995-Jan-18 + 5.000i 1995-Jan-26 + 5.000j 1995-Feb-07 + 5.000k 1995-Feb-11 + 5.000l 1995-Feb-21 + 5.000m 1995-???-?? + 5.000n 1995-Mar-07 + + Larry 5.001 1995-Mar-13 + + Andy 5.001a 1995-Mar-15 + 5.001b 1995-Mar-31 + 5.001c 1995-Apr-07 + 5.001d 1995-Apr-14 + 5.001e 1995-Apr-18 Stable. + 5.001f 1995-May-31 + 5.001g 1995-May-25 + 5.001h 1995-May-25 + 5.001i 1995-May-30 + 5.001j 1995-Jun-05 + 5.001k 1995-Jun-06 + 5.001l 1995-Jun-06 Stable. + 5.001m 1995-Jul-02 Very stable. + 5.001n 1995-Oct-31 Very unstable. + 5.002beta1 1995-Nov-21 + 5.002b1a 1995-Nov-?? + 5.002b1b 1995-Dec-04 + 5.002b1c 1995-Dec-04 + 5.002b1d 1995-Dec-04 + 5.002b1e 1995-Dec-08 + 5.002b1f 1995-Dec-08 + Tom 5.002b1g 1995-Dec-21 Doc release. + Andy 5.002b1h 1996-Jan-05 + 5.002b2 1996-Jan-14 + Larry 5.002b3 1996-Feb-02 + Andy 5.002gamma 1996-Feb-11 + Larry 5.002delta 1996-Feb-27 + + Larry 5.002 1996-Feb-29 + + Charles 5.002_01 1996-Mar-25 + + 5.003 1996-Jun-25 Security release. + + 5.003_01 1996-Jul-31 + Nick 5.003_02 1996-Aug-10 + Andy 5.003_03 1996-Aug-28 + 5.003_04 1996-Sep-02 + 5.003_05 1996-Sep-12 + 5.003_06 1996-Oct-07 + 5.003_07 1996-Oct-10 + Chip 5.003_08 1996-Nov-19 + 5.003_09 1996-Nov-26 + 5.003_10 1996-Nov-29 + 5.003_11 1996-Dec-06 + 5.003_12 1996-Dec-19 + 5.003_13 1996-Dec-20 + 5.003_14 1996-Dec-23 + 5.003_15 1996-Dec-23 + 5.003_16 1996-Dec-24 + 5.003_17 1996-Dec-27 + 5.003_18 1996-Dec-31 + 5.003_19 1997-Jan-04 + 5.003_20 1997-Jan-07 + 5.003_21 1997-Jan-15 + 5.003_22 1997-Jan-16 + 5.003_23 1997-Jan-25 + 5.003_24 1997-Jan-29 + 5.003_25 1997-Feb-04 + 5.003_26 1997-Feb-10 + 5.003_27 1997-Feb-18 + 5.003_28 1997-Feb-21 + 5.003_90 1997-Feb-25 Ramping up to the 5.004 release. + 5.003_91 1997-Mar-01 + 5.003_92 1997-Mar-06 + 5.003_93 1997-Mar-10 + 5.003_94 1997-Mar-22 + 5.003_95 1997-Mar-25 + 5.003_96 1997-Apr-01 + 5.003_97 1997-Apr-03 Fairly widely used. + 5.003_97a 1997-Apr-05 + 5.003_97b 1997-Apr-08 + 5.003_97c 1997-Apr-10 + 5.003_97d 1997-Apr-13 + 5.003_97e 1997-Apr-15 + 5.003_97f 1997-Apr-17 + 5.003_97g 1997-Apr-18 + 5.003_97h 1997-Apr-24 + 5.003_97i 1997-Apr-25 + 5.003_97j 1997-Apr-28 + 5.003_98 1997-Apr-30 + 5.003_99 1997-May-01 + 5.003_99a 1997-May-09 + p54rc1 1997-May-12 Release Candidates. + p54rc2 1997-May-14 + + Chip 5.004 1997-May-15 A major maintenance release. + + Tim 5.004_01 1997-Jun-13 The 5.004 maintenance track. + 5.004_02 1997-Aug-07 + 5.004_03 1997-Sep-05 + 5.004_04 1997-Oct-15 + + Malcolm 5.004_50 1997-Sep-09 The 5.005 development track. + 5.004_51 1997-Oct-02 + 5.004_52 1997-Oct-15 + 5.004_53 1997-Oct-16 + 5.004_54 1997-Nov-14 + 5.004_55 1997-Nov-25 + 5.004_56 1997-Dec-18 + +=head2 SELECTED RELEASE SIZES + +For example the notation "core: 212 29" in the release 1.000 means that +it had in the core 212 kilobytes, in 29 files. The "core".."doc" are +explained below. + + release core lib ext t doc + ====================================================================== + + 1.000 212 29 - - - - 38 51 62 3 + 1.014 219 29 - - - - 39 52 68 4 + 2.000 309 31 2 3 - - 55 57 92 4 + 2.001 312 31 2 3 - - 55 57 94 4 + 3.000 508 36 24 11 - - 79 73 156 5 + 3.044 645 37 61 20 - - 90 74 190 6 + 4.000 635 37 59 20 - - 91 75 198 4 + 4.019 680 37 85 29 - - 98 76 199 4 + 4.036 709 37 89 30 - - 98 76 208 5 + 5.000alpha2 785 50 114 32 - - 112 86 209 5 + 5.000a3 801 50 117 33 - - 121 87 209 5 + 5.000a9 1022 56 149 43 116 29 125 90 217 6 + 5.000a12h 978 49 140 49 205 46 152 97 228 9 + 5.000beta3h 1035 53 232 70 216 38 162 94 218 21 + 5.000 1038 53 250 76 216 38 154 92 536 62 + 5.001m 1071 54 388 82 240 38 159 95 544 29 + 5.002 1121 54 661 101 287 43 155 94 847 35 + 5.003 1129 54 680 102 291 43 166 100 853 35 + 5.003_07 1231 60 748 106 396 53 213 137 976 39 + 5.004 1351 60 1230 136 408 51 355 161 1587 55 + 5.004_01 1356 60 1258 138 410 51 358 161 1587 55 + 5.004_04 1375 60 1294 139 413 51 394 162 1629 55 + 5.004_51 1401 61 1260 140 413 53 358 162 1594 56 + 5.004_53 1422 62 1295 141 438 70 394 162 1637 56 + 5.004_56 1501 66 1301 140 447 74 408 165 1648 57 + +The "core"..."doc" mean the following files from the Perl source code +distribution. The glob notation ** means recursively, (.) means +regular files. + + core *.[hcy] + lib lib/**/*.p[ml] + ext ext/**/*.{[hcyt],xs,pm} + t t/**/*(.) + doc {README*,INSTALL,*[_.]man{,.?},pod/**/*.pod} + +Here are some statistics for the other subdirectories and one file in +the Perl source distribution for somewhat more selected releases. + + ====================================================================== + Legend: kB # + + 1.014 2.001 3.044 4.000 4.019 4.036 + + atarist - - - - - - - - - - 113 31 + Configure 31 1 37 1 62 1 73 1 83 1 86 1 + eg - - 34 28 47 39 47 39 47 39 47 39 + emacs - - - - - - 67 4 67 4 67 4 + h2pl - - - - 12 12 12 12 12 12 12 12 + hints - - - - - - - - 5 42 11 56 + msdos - - - - 41 13 57 15 58 15 60 15 + os2 - - - - 63 22 81 29 81 29 113 31 + usub - - - - 21 16 25 7 43 8 43 8 + x2p 103 17 104 17 137 17 147 18 152 19 154 19 + + ====================================================================== + + 5.000a2 5.000a12h 5.000b3h 5.000 5.001m 5.002 5.003 + + atarist 113 31 113 31 - - - - - - - - - - + bench - - 0 1 - - - - - - - - - - + Bugs 2 5 26 1 - - - - - - - - - - + dlperl 40 5 - - - - - - - - - - - - + do 127 71 - - - - - - - - - - - - + Configure - - 153 1 159 1 160 1 180 1 201 1 201 1 + Doc - - 26 1 75 7 11 1 11 1 - - - - + eg 79 58 53 44 51 43 54 44 54 44 54 44 54 44 + emacs 67 4 104 6 104 6 104 1 104 6 108 1 108 1 + h2pl 12 12 12 12 12 12 12 12 12 12 12 12 12 12 + hints 11 56 12 46 18 48 18 48 44 56 73 59 77 60 + msdos 60 15 60 15 - - - - - - - - - - + os2 113 31 113 31 - - - - - - 84 17 56 10 + U - - 62 8 112 42 - - - - - - - - + usub 43 8 - - - - - - - - - - - - + utils - - - - - - - - - - 87 7 88 7 + vms - - 80 7 123 9 184 15 304 20 500 24 475 26 + x2p 171 22 171 21 162 20 162 20 279 20 280 20 280 20 + + ====================================================================== + + 5.003_07 5.004 5.004_04 5.004_56 + + Configure 217 1 225 1 225 1 232 1 + cygwin32 - - 23 5 23 5 23 5 + djgpp - - - - - - 15 5 + eg 54 44 81 62 81 62 81 62 + emacs 143 1 194 1 204 1 212 2 + h2pl 12 12 12 12 12 12 12 12 + hints 90 62 129 69 132 71 138 72 + os2 117 42 121 42 127 42 134 44 + plan9 79 15 82 15 82 15 82 15 + Porting 51 1 94 2 109 4 109 4 + qnx - - 1 2 1 2 1 2 + utils 97 7 112 8 118 8 118 8 + vms 505 27 518 34 524 34 538 34 + win32 - - 285 33 378 36 449 38 + x2p 280 19 281 19 281 19 281 19 + +=head2 SELECTED PATCH SIZES + +The "diff lines kb" means that for example the patch 5.003_08, +to be applied on top 5.003_07 (or whatever was before it) added +lines for 110 kilobytes, it removed lines for 19 kilobytes, and +changed lines for 424 kilobytes. Just the lines themselves are +counted, not their context. The "+ - !" become from the diff(1)s +context diff output format. + + Pump- Release Date diff lines kB + king + - ! + =========================================================================== + + Chip 5.003_08 1996-Nov-19 110 19 424 + 5.003_09 1996-Nov-26 38 9 248 + 5.003_10 1996-Nov-29 29 2 27 + 5.003_11 1996-Dec-06 73 12 165 + 5.003_12 1996-Dec-19 275 6 436 + 5.003_13 1996-Dec-20 95 1 56 + 5.003_14 1996-Dec-23 23 7 333 + 5.003_15 1996-Dec-23 0 0 1 + 5.003_16 1996-Dec-24 12 3 50 + 5.003_17 1996-Dec-27 19 1 14 + 5.003_18 1996-Dec-31 21 1 32 + 5.003_19 1997-Jan-04 80 3 85 + 5.003_20 1997-Jan-07 18 1 146 + 5.003_21 1997-Jan-15 38 10 221 + 5.003_22 1997-Jan-16 4 0 18 + 5.003_23 1997-Jan-25 71 15 119 + 5.003_24 1997-Jan-29 426 1 20 + 5.003_25 1997-Feb-04 21 8 169 + 5.003_26 1997-Feb-10 16 1 15 + 5.003_27 1997-Feb-18 32 10 38 + 5.003_28 1997-Feb-21 58 4 66 + 5.003_90 1997-Feb-25 22 2 34 + 5.003_91 1997-Mar-01 37 1 39 + 5.003_92 1997-Mar-06 16 3 69 + 5.003_93 1997-Mar-10 12 3 15 + 5.003_94 1997-Mar-22 407 7 200 + 5.003_95 1997-Mar-25 41 1 37 + 5.003_96 1997-Apr-01 283 5 261 + 5.003_97 1997-Apr-03 13 2 34 + 5.003_97a 1997-Apr-05 57 1 27 + 5.003_97b 1997-Apr-08 14 1 20 + 5.003_97c 1997-Apr-10 20 1 16 + 5.003_97d 1997-Apr-13 8 0 16 + 5.003_97e 1997-Apr-15 15 4 46 + 5.003_97f 1997-Apr-17 7 1 33 + 5.003_97g 1997-Apr-18 6 1 42 + 5.003_97h 1997-Apr-24 23 3 68 + 5.003_97i 1997-Apr-25 23 1 31 + 5.003_97j 1997-Apr-28 36 1 49 + 5.003_98 1997-Apr-30 171 12 539 + 5.003_99 1997-May-01 6 0 7 + 5.003_99a 1997-May-09 36 2 61 + p54rc1 1997-May-12 8 1 11 + p54rc2 1997-May-14 6 0 40 + + 5.004 1997-May-15 4 0 4 + + Tim 5.004_01 1997-Jun-13 222 14 57 + 5.004_02 1997-Aug-07 112 16 119 + 5.004_03 1997-Sep-05 109 0 17 + 5.004_04 1997-Oct-15 66 8 173 + +=head1 THE KEEPERS OF THE RECORDS + +Jarkko Hietaniemi <F<jhi@iki.fi>>. + +Thanks to the collective memory of the Perlfolk. In addition to the +Keepers of the Pumpkin also Alan Champion, Andreas König, John +Macdonald, Matthias Neeracher, Michael Peppler, Randal Schwartz, and +Paul D. Smith sent corrections and additions. + +=cut diff --git a/pod/perltie.pod b/pod/perltie.pod index c6eb7156ce..79a749e68a 100644 --- a/pod/perltie.pod +++ b/pod/perltie.pod @@ -180,17 +180,26 @@ TIESCALAR classes are certainly possible. =head2 Tying Arrays A class implementing a tied ordinary array should define the following -methods: TIEARRAY, FETCH, STORE, and perhaps DESTROY. +methods: TIEARRAY, FETCH, STORE, FETCHSIZE, STORESIZE and perhaps DESTROY. -B<WARNING>: Tied arrays are I<incomplete>. They are also distinctly lacking -something for the C<$#ARRAY> access (which is hard, as it's an lvalue), as -well as the other obvious array functions, like push(), pop(), shift(), -unshift(), and splice(). +FETCHSIZE and STORESIZE are used to provide C<$#array> and +equivalent C<scalar(@array)> access. + +The methods POP, PUSH, SHIFT, UNSHIFT, SPLICE are required if the perl +operator with the corresponding (but lowercase) name is to operate on the +tied array. The B<Tie::Array> class can be used as a base class to implement +these in terms of the basic five methods above. + +In addition EXTEND will be called when perl would have pre-extended +allocation in a real array. + +This means that tied arrays are now I<complete>. The example below needs +upgrading to illustrate this. (The documentation in B<Tie::Array> is more +complete.) For this discussion, we'll implement an array whose indices are fixed at its creation. If you try to access anything beyond those bounds, you'll -take an exception. (Well, if you access an individual element; an -aggregate assignment would be missed.) For example: +take an exception. For example: require Bounded_Array; tie @ary, 'Bounded_Array', 2; diff --git a/pod/perlxs.pod b/pod/perlxs.pod index 6629af2dd5..d257b196eb 100644 --- a/pod/perlxs.pod +++ b/pod/perlxs.pod @@ -268,14 +268,17 @@ be seen by Perl. The OUTPUT: keyword will also allow an output parameter to be mapped to a matching piece of code rather than to a -typemap. +typemap. The following duplicates the behavior of the +typemap: bool_t rpcb_gettime(host,timep) char *host time_t &timep OUTPUT: - timep sv_setnv(ST(1), (double)timep); + timep SvSetMagicNV(ST(1), (double)timep); + +See L<perlguts> for details about C<SvSetMagicNV()>. =head2 The CODE: Keyword diff --git a/pod/perlxstut.pod b/pod/perlxstut.pod index 9ebfe82a97..dfc56ffbf1 100644 --- a/pod/perlxstut.pod +++ b/pod/perlxstut.pod @@ -428,7 +428,7 @@ Let's now take a look at a portion of the .c file created for our extension. } else { arg = 0.0; } - sv_setnv(ST(0), (double)arg); /* XXXXX */ + SvSetMagicNV(ST(0), (double)arg); /* XXXXX */ } XSRETURN(1); } @@ -438,10 +438,10 @@ the typemap file, you'll see that doubles are of type T_DOUBLE. In the INPUT section, an argument that is T_DOUBLE is assigned to the variable arg by calling the routine SvNV on something, then casting it to double, then assigned to the variable arg. Similarly, in the OUTPUT section, -once arg has its final value, it is passed to the sv_setnv function to -be passed back to the calling subroutine. These two functions are explained -in L<perlguts>; we'll talk more later about what that "ST(0)" means in the -section on the argument stack. +once arg has its final value, it is passed to the SvSetMagicNV() macro +(which calls the sv_setnv() function) to be passed back to the calling +subroutine. These macros/functions are explained in L<perlguts>; we'll talk +more later about what that "ST(0)" means in the section on the argument stack. =head2 WARNING @@ -24,7 +24,7 @@ */ #ifdef CXUX_BROKEN_CONSTANT_CONVERT static double UV_MAX_cxux = ((double)UV_MAX); -#endif +#endif /* * Types used in bitwise operations. @@ -143,7 +143,16 @@ PP(pp_padav) if (GIMME == G_ARRAY) { I32 maxarg = AvFILL((AV*)TARG) + 1; EXTEND(SP, maxarg); - Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*); + if (SvMAGICAL(TARG)) { + U32 i; + for (i=0; i < maxarg; i++) { + SV **svp = av_fetch((AV*)TARG, i, FALSE); + SP[i+1] = (svp) ? *svp : &sv_undef; + } + } + else { + Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*); + } SP += maxarg; } else { @@ -191,7 +200,7 @@ PP(pp_padany) PP(pp_rv2gv) { djSP; dTOPss; - + if (SvROK(sv)) { wasref: sv = SvRV(sv); @@ -299,7 +308,7 @@ PP(pp_av2arylen) PP(pp_pos) { djSP; dTARGET; dPOPss; - + if (op->op_flags & OPf_MOD) { if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); @@ -312,7 +321,7 @@ PP(pp_pos) RETURN; } else { - MAGIC* mg; + MAGIC* mg; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { mg = mg_find(sv, 'g'); @@ -376,7 +385,7 @@ PP(pp_srefgen) djSP; *SP = refto(*SP); RETURN; -} +} PP(pp_refgen) { @@ -424,7 +433,7 @@ PP(pp_ref) sv = POPs; if (sv && SvGMAGICAL(sv)) - mg_get(sv); + mg_get(sv); if (!sv || !SvROK(sv)) RETPUSHNO; @@ -630,7 +639,7 @@ PP(pp_chomp) { djSP; dMARK; dTARGET; register I32 count = 0; - + while (SP > MARK) count += do_chomp(POPs); PUSHi(count); @@ -786,7 +795,7 @@ PP(pp_postdec) PP(pp_pow) { - djSP; dATARGET; tryAMAGICbin(pow,opASSIGN); + djSP; dATARGET; tryAMAGICbin(pow,opASSIGN); { dPOPTOPnnrl; SETn( pow( left, right) ); @@ -796,7 +805,7 @@ PP(pp_pow) PP(pp_multiply) { - djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPnnrl; SETn( left * right ); @@ -806,7 +815,7 @@ PP(pp_multiply) PP(pp_divide) { - djSP; dATARGET; tryAMAGICbin(div,opASSIGN); + djSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPPOPnnrl; double value; @@ -939,7 +948,7 @@ PP(pp_repeat) PP(pp_subtract) { - djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { dPOPTOPnnrl_ul; SETn( left - right ); @@ -949,7 +958,7 @@ PP(pp_subtract) PP(pp_left_shift) { - djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); + djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { IBW shift = POPi; if (op->op_private & HINT_INTEGER) { @@ -968,7 +977,7 @@ PP(pp_left_shift) PP(pp_right_shift) { - djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); + djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { IBW shift = POPi; if (op->op_private & HINT_INTEGER) { @@ -987,7 +996,7 @@ PP(pp_right_shift) PP(pp_lt) { - djSP; tryAMAGICbinSET(lt,0); + djSP; tryAMAGICbinSET(lt,0); { dPOPnv; SETs(boolSV(TOPn < value)); @@ -997,7 +1006,7 @@ PP(pp_lt) PP(pp_gt) { - djSP; tryAMAGICbinSET(gt,0); + djSP; tryAMAGICbinSET(gt,0); { dPOPnv; SETs(boolSV(TOPn > value)); @@ -1007,7 +1016,7 @@ PP(pp_gt) PP(pp_le) { - djSP; tryAMAGICbinSET(le,0); + djSP; tryAMAGICbinSET(le,0); { dPOPnv; SETs(boolSV(TOPn <= value)); @@ -1017,7 +1026,7 @@ PP(pp_le) PP(pp_ge) { - djSP; tryAMAGICbinSET(ge,0); + djSP; tryAMAGICbinSET(ge,0); { dPOPnv; SETs(boolSV(TOPn >= value)); @@ -1027,7 +1036,7 @@ PP(pp_ge) PP(pp_ne) { - djSP; tryAMAGICbinSET(ne,0); + djSP; tryAMAGICbinSET(ne,0); { dPOPnv; SETs(boolSV(TOPn != value)); @@ -1037,7 +1046,7 @@ PP(pp_ne) PP(pp_ncmp) { - djSP; dTARGET; tryAMAGICbin(ncmp,0); + djSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPnnrl; I32 value; @@ -1059,7 +1068,7 @@ PP(pp_ncmp) PP(pp_slt) { - djSP; tryAMAGICbinSET(slt,0); + djSP; tryAMAGICbinSET(slt,0); { dPOPTOPssrl; int cmp = ((op->op_private & OPpLOCALE) @@ -1072,7 +1081,7 @@ PP(pp_slt) PP(pp_sgt) { - djSP; tryAMAGICbinSET(sgt,0); + djSP; tryAMAGICbinSET(sgt,0); { dPOPTOPssrl; int cmp = ((op->op_private & OPpLOCALE) @@ -1085,7 +1094,7 @@ PP(pp_sgt) PP(pp_sle) { - djSP; tryAMAGICbinSET(sle,0); + djSP; tryAMAGICbinSET(sle,0); { dPOPTOPssrl; int cmp = ((op->op_private & OPpLOCALE) @@ -1098,7 +1107,7 @@ PP(pp_sle) PP(pp_sge) { - djSP; tryAMAGICbinSET(sge,0); + djSP; tryAMAGICbinSET(sge,0); { dPOPTOPssrl; int cmp = ((op->op_private & OPpLOCALE) @@ -1111,7 +1120,7 @@ PP(pp_sge) PP(pp_seq) { - djSP; tryAMAGICbinSET(seq,0); + djSP; tryAMAGICbinSET(seq,0); { dPOPTOPssrl; SETs(boolSV(sv_eq(left, right))); @@ -1121,7 +1130,7 @@ PP(pp_seq) PP(pp_sne) { - djSP; tryAMAGICbinSET(sne,0); + djSP; tryAMAGICbinSET(sne,0); { dPOPTOPssrl; SETs(boolSV(!sv_eq(left, right))); @@ -1144,16 +1153,16 @@ PP(pp_scmp) PP(pp_bit_and) { - djSP; dATARGET; tryAMAGICbin(band,opASSIGN); + djSP; dATARGET; tryAMAGICbin(band,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (op->op_private & HINT_INTEGER) { - IBW value = SvIV(left) & SvIV(right); + IBW value = SvIV(left) & SvIV(right); SETi(BWi(value)); } else { - UBW value = SvUV(left) & SvUV(right); + UBW value = SvUV(left) & SvUV(right); SETu(BWu(value)); } } @@ -1167,16 +1176,16 @@ PP(pp_bit_and) PP(pp_bit_xor) { - djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); + djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (op->op_private & HINT_INTEGER) { - IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); + IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); SETi(BWi(value)); } else { - UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); + UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); SETu(BWu(value)); } } @@ -1190,16 +1199,16 @@ PP(pp_bit_xor) PP(pp_bit_or) { - djSP; dATARGET; tryAMAGICbin(bor,opASSIGN); + djSP; dATARGET; tryAMAGICbin(bor,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (op->op_private & HINT_INTEGER) { - IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); + IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); SETi(BWi(value)); } else { - UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); + UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); SETu(BWu(value)); } } @@ -1254,7 +1263,7 @@ PP(pp_not) PP(pp_complement) { - djSP; dTARGET; tryAMAGICun(compl); + djSP; dTARGET; tryAMAGICun(compl); { dTOPss; if (SvNIOKp(sv)) { @@ -1297,7 +1306,7 @@ PP(pp_complement) PP(pp_i_multiply) { - djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); + djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPiirl; SETi( left * right ); @@ -1307,7 +1316,7 @@ PP(pp_i_multiply) PP(pp_i_divide) { - djSP; dATARGET; tryAMAGICbin(div,opASSIGN); + djSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPiv; if (value == 0) @@ -1332,7 +1341,7 @@ PP(pp_i_modulo) PP(pp_i_add) { - djSP; dATARGET; tryAMAGICbin(add,opASSIGN); + djSP; dATARGET; tryAMAGICbin(add,opASSIGN); { dPOPTOPiirl; SETi( left + right ); @@ -1342,7 +1351,7 @@ PP(pp_i_add) PP(pp_i_subtract) { - djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); + djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { dPOPTOPiirl; SETi( left - right ); @@ -1352,7 +1361,7 @@ PP(pp_i_subtract) PP(pp_i_lt) { - djSP; tryAMAGICbinSET(lt,0); + djSP; tryAMAGICbinSET(lt,0); { dPOPTOPiirl; SETs(boolSV(left < right)); @@ -1362,7 +1371,7 @@ PP(pp_i_lt) PP(pp_i_gt) { - djSP; tryAMAGICbinSET(gt,0); + djSP; tryAMAGICbinSET(gt,0); { dPOPTOPiirl; SETs(boolSV(left > right)); @@ -1372,7 +1381,7 @@ PP(pp_i_gt) PP(pp_i_le) { - djSP; tryAMAGICbinSET(le,0); + djSP; tryAMAGICbinSET(le,0); { dPOPTOPiirl; SETs(boolSV(left <= right)); @@ -1382,7 +1391,7 @@ PP(pp_i_le) PP(pp_i_ge) { - djSP; tryAMAGICbinSET(ge,0); + djSP; tryAMAGICbinSET(ge,0); { dPOPTOPiirl; SETs(boolSV(left >= right)); @@ -1392,7 +1401,7 @@ PP(pp_i_ge) PP(pp_i_eq) { - djSP; tryAMAGICbinSET(eq,0); + djSP; tryAMAGICbinSET(eq,0); { dPOPTOPiirl; SETs(boolSV(left == right)); @@ -1402,7 +1411,7 @@ PP(pp_i_eq) PP(pp_i_ne) { - djSP; tryAMAGICbinSET(ne,0); + djSP; tryAMAGICbinSET(ne,0); { dPOPTOPiirl; SETs(boolSV(left != right)); @@ -1412,7 +1421,7 @@ PP(pp_i_ne) PP(pp_i_ncmp) { - djSP; dTARGET; tryAMAGICbin(ncmp,0); + djSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPiirl; I32 value; @@ -1439,7 +1448,7 @@ PP(pp_i_negate) PP(pp_atan2) { - djSP; dTARGET; tryAMAGICbin(atan2,0); + djSP; dTARGET; tryAMAGICbin(atan2,0); { dPOPTOPnnrl; SETn(atan2(left, right)); @@ -1755,7 +1764,7 @@ PP(pp_substr) rem -= pos; } if (fail < 0) { - if (dowarn || lvalue) + if (dowarn || lvalue) warn("substr outside of string"); RETPUSHUNDEF; } @@ -1783,7 +1792,7 @@ PP(pp_substr) LvTYPE(TARG) = 'x'; LvTARG(TARG) = sv; LvTARGOFF(TARG) = pos; - LvTARGLEN(TARG) = rem; + LvTARGLEN(TARG) = rem; } } PUSHs(TARG); /* avoid SvSETMAGIC here */ @@ -1815,8 +1824,8 @@ PP(pp_vec) LvTYPE(TARG) = 'v'; LvTARG(TARG) = src; - LvTARGOFF(TARG) = offset; - LvTARGLEN(TARG) = size; + LvTARGOFF(TARG) = offset; + LvTARGLEN(TARG) = size; } if (len > srclen) { if (size <= 8) @@ -2200,7 +2209,7 @@ PP(pp_each) HE *entry; I32 gimme = GIMME_V; I32 realhv = (SvTYPE(hash) == SVt_PVHV); - + PUTBACK; /* might clobber stack_sp */ entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash); @@ -2448,13 +2457,25 @@ PP(pp_splice) I32 after; I32 diff; SV **tmparyval = 0; + MAGIC *mg; + + if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) { + *MARK-- = mg->mg_obj; + PUSHMARK(MARK); + PUTBACK; + ENTER; + perl_call_method("SPLICE",GIMME_V); + LEAVE; + SPAGAIN; + RETURN; + } SP++; if (++MARK < SP) { offset = i = SvIVx(*MARK); if (offset < 0) - offset += AvFILL(ary) + 1; + offset += AvFILLp(ary) + 1; else offset -= curcop->cop_arybase; if (offset < 0) @@ -2471,9 +2492,9 @@ PP(pp_splice) offset = 0; length = AvMAX(ary) + 1; } - if (offset > AvFILL(ary) + 1) - offset = AvFILL(ary) + 1; - after = AvFILL(ary) + 1 - (offset + length); + if (offset > AvFILLp(ary) + 1) + offset = AvFILLp(ary) + 1; + after = AvFILLp(ary) + 1 - (offset + length); if (after < 0) { /* not that much array */ length += after; /* offset+length now in array */ after = 0; @@ -2521,7 +2542,7 @@ PP(pp_splice) SvREFCNT_dec(*dst++); /* free them now */ } } - AvFILL(ary) += diff; + AvFILLp(ary) += diff; /* pull up or down? */ @@ -2542,7 +2563,7 @@ PP(pp_splice) dst = src + diff; /* diff is negative */ Move(src, dst, after, SV*); } - dst = &AvARRAY(ary)[AvFILL(ary)+1]; + dst = &AvARRAY(ary)[AvFILLp(ary)+1]; /* avoid later double free */ } i = -diff; @@ -2576,15 +2597,15 @@ PP(pp_splice) } SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */ AvMAX(ary) += diff; - AvFILL(ary) += diff; + AvFILLp(ary) += diff; } else { - if (AvFILL(ary) + diff >= AvMAX(ary)) /* oh, well */ - av_extend(ary, AvFILL(ary) + diff); - AvFILL(ary) += diff; + if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */ + av_extend(ary, AvFILLp(ary) + diff); + AvFILLp(ary) += diff; if (after) { - dst = AvARRAY(ary) + AvFILL(ary); + dst = AvARRAY(ary) + AvFILLp(ary); src = dst - diff; for (i = after; i; i--) { *dst-- = *src--; @@ -2635,12 +2656,25 @@ PP(pp_push) djSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv = &sv_undef; + MAGIC *mg; - for (++MARK; MARK <= SP; MARK++) { - sv = NEWSV(51, 0); - if (*MARK) - sv_setsv(sv, *MARK); - av_push(ary, sv); + if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) { + *MARK-- = mg->mg_obj; + PUSHMARK(MARK); + PUTBACK; + ENTER; + perl_call_method("PUSH",G_SCALAR|G_DISCARD); + LEAVE; + SPAGAIN; + } + else { + /* Why no pre-extend of ary here ? */ + for (++MARK; MARK <= SP; MARK++) { + sv = NEWSV(51, 0); + if (*MARK) + sv_setsv(sv, *MARK); + av_push(ary, sv); + } } SP = ORIGMARK; PUSHi( AvFILL(ary) + 1 ); @@ -2678,14 +2712,26 @@ PP(pp_unshift) register AV *ary = (AV*)*++MARK; register SV *sv; register I32 i = 0; + MAGIC *mg; + + if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) { - av_unshift(ary, SP - MARK); - while (MARK < SP) { - sv = NEWSV(27, 0); - sv_setsv(sv, *++MARK); - (void)av_store(ary, i++, sv); - } + *MARK-- = mg->mg_obj; + PUTBACK; + ENTER; + perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD); + LEAVE; + SPAGAIN; + } + else { + av_unshift(ary, SP - MARK); + while (MARK < SP) { + sv = NEWSV(27, 0); + sv_setsv(sv, *++MARK); + (void)av_store(ary, i++, sv); + } + } SP = ORIGMARK; PUSHi( AvFILL(ary) + 1 ); RETURN; @@ -3236,7 +3282,7 @@ PP(pp_unpack) case 'w': EXTEND(SP, len); EXTEND_MORTAL(len); - { + { UV auv = 0; U32 bytes = 0; @@ -3530,7 +3576,7 @@ is_an_int(char *s, STRLEN l) STATIC int div128(SV *pnum, bool *done) /* must be '\0' terminated */ - + { STRLEN len; char *s = SvPV(pnum, len); @@ -3878,7 +3924,7 @@ PP(pp_pack) SV *norm; STRLEN len; bool done; - + /* Copy string and check for compliance */ from = SvPV(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) @@ -4022,6 +4068,7 @@ PP(pp_pack) } #undef NEXTFROM + PP(pp_split) { djSP; dTARG; @@ -4045,6 +4092,8 @@ PP(pp_split) AV *oldstack = curstack; I32 gimme = GIMME_V; I32 oldsave = savestack_ix; + I32 make_mortal = 1; + MAGIC *mg = (MAGIC *) NULL; #ifdef DEBUGGING Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*); @@ -4070,15 +4119,24 @@ PP(pp_split) ary = Nullav; if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) { realarray = 1; - if (!AvREAL(ary)) { - AvREAL_on(ary); - for (i = AvFILL(ary); i >= 0; i--) - AvARRAY(ary)[i] = &sv_undef; /* don't free mere refs */ - } + PUTBACK; av_extend(ary,0); av_clear(ary); - /* temporarily switch stacks */ - SWITCHSTACK(curstack, ary); + SPAGAIN; + if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) { + PUSHMARK(SP); + XPUSHs(mg->mg_obj); + } + else { + if (!AvREAL(ary)) { + AvREAL_on(ary); + for (i = AvFILLp(ary); i >= 0; i--) + AvARRAY(ary)[i] = &sv_undef; /* don't free mere refs */ + } + /* temporarily switch stacks */ + SWITCHSTACK(curstack, ary); + make_mortal = 0; + } } base = SP - stack_base; orig = s; @@ -4111,7 +4169,7 @@ PP(pp_split) dstr = NEWSV(30, m-s); sv_setpvn(dstr, s, m-s); - if (!realarray) + if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); @@ -4131,13 +4189,13 @@ PP(pp_split) break; dstr = NEWSV(30, m-s); sv_setpvn(dstr, s, m-s); - if (!realarray) + if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); s = m; } } - else if (rx->check_substr && !rx->nparens + else if (rx->check_substr && !rx->nparens && (rx->reganch & ROPT_CHECK_ALL) && !(rx->reganch & ROPT_ANCH)) { i = SvCUR(rx->check_substr); @@ -4150,7 +4208,7 @@ PP(pp_split) break; dstr = NEWSV(30, m-s); sv_setpvn(dstr, s, m-s); - if (!realarray) + if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); s = m + 1; @@ -4165,7 +4223,7 @@ PP(pp_split) { dstr = NEWSV(31, m-s); sv_setpvn(dstr, s, m-s); - if (!realarray) + if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); s = m + i; @@ -4189,7 +4247,7 @@ PP(pp_split) m = rx->startp[0]; dstr = NEWSV(32, m-s); sv_setpvn(dstr, s, m-s); - if (!realarray) + if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); if (rx->nparens) { @@ -4202,7 +4260,7 @@ PP(pp_split) } else dstr = NEWSV(33, 0); - if (!realarray) + if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); } @@ -4210,16 +4268,17 @@ PP(pp_split) s = rx->endp[0]; } } + LEAVE_SCOPE(oldsave); iters = (SP - stack_base) - base; if (iters > maxiters) DIE("Split loop"); - + /* keep field after final delim? */ if (s < strend || (iters && origlimit)) { dstr = NEWSV(34, strend-s); sv_setpvn(dstr, s, strend-s); - if (!realarray) + if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); iters++; @@ -4228,18 +4287,37 @@ PP(pp_split) while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) iters--, SP--; } + if (realarray) { - SWITCHSTACK(ary, oldstack); - if (SvSMAGICAL(ary)) { + if (!mg) { + SWITCHSTACK(ary, oldstack); + if (SvSMAGICAL(ary)) { + PUTBACK; + mg_set((SV*)ary); + SPAGAIN; + } + if (gimme == G_ARRAY) { + EXTEND(SP, iters); + Copy(AvARRAY(ary), SP + 1, iters, SV*); + SP += iters; + RETURN; + } + } + else { PUTBACK; - mg_set((SV*)ary); + ENTER; + perl_call_method("PUSH",G_SCALAR|G_DISCARD); + LEAVE; SPAGAIN; - } - if (gimme == G_ARRAY) { - EXTEND(SP, iters); - Copy(AvARRAY(ary), SP + 1, iters, SV*); - SP += iters; - RETURN; + if (gimme == G_ARRAY) { + /* EXTEND should not be needed - we just popped them */ + EXTEND(SP, iters); + for (i=0; i < iters; i++) { + SV **svp = av_fetch(ary, i, FALSE); + PUSHs((svp) ? *svp : &sv_undef); + } + RETURN; + } } } else { @@ -4260,7 +4338,7 @@ unlock_condpair(void *svv) { dTHR; MAGIC *mg = mg_find((SV*)svv, 'm'); - + if (!mg) croak("panic: unlock_condpair unlocking non-mutex"); MUTEX_LOCK(MgMUTEXP(mg)); @@ -4281,7 +4359,7 @@ PP(pp_lock) SV *retsv = sv; #ifdef USE_THREADS MAGIC *mg; - + if (SvROK(sv)) sv = SvRV(sv); @@ -158,10 +158,10 @@ #define ARGTARG op->op_targ #define MAXARG op->op_private -#define SWITCHSTACK(f,t) AvFILL(f) = sp - stack_base; \ +#define SWITCHSTACK(f,t) AvFILLp(f) = sp - stack_base; \ stack_base = AvARRAY(t); \ stack_max = stack_base + AvMAX(t); \ - sp = stack_sp = stack_base + AvFILL(t); \ + sp = stack_sp = stack_base + AvFILLp(t); \ curstack = t; #define EXTEND_MORTAL(n) \ @@ -37,9 +37,8 @@ static I32 dopoptolabel _((char *label)); static I32 dopoptoloop _((I32 startingblock)); static I32 dopoptosub _((I32 startingblock)); static void save_lines _((AV *array, SV *sv)); -static int sortcv _((const void *, const void *)); -static int sortcmp _((const void *, const void *)); -static int sortcmp_locale _((const void *, const void *)); +static I32 sortcv _((SV *a, SV *b)); +static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b))); static OP *doeval _((int gimme, OP** startop)); #endif @@ -764,10 +763,10 @@ PP(pp_sort) #ifdef PERL_OBJECT MUTEX_LOCK(&sort_mutex); pSortPerl = this; - qsort((char*)(myorigmark+1), max, sizeof(SV*), SortCv); + qsortsv((myorigmark+1), max, SortCv); MUTEX_UNLOCK(&sort_mutex); #else - qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv); + qsortsv((myorigmark+1), max, sortcv); #endif POPBLOCK(cx,curpm); @@ -782,12 +781,12 @@ PP(pp_sort) #ifdef PERL_OBJECT MUTEX_LOCK(&sort_mutex); pSortPerl = this; - qsort((char*)(ORIGMARK+1), max, sizeof(SV*), - (op->op_private & OPpLOCALE) ? SortCmpLocale : SortCmp); + qsortsv(ORIGMARK+1, max, + (op->op_private & OPpLOCALE) ? sv_cmp_locale : sv_cmp); MUTEX_UNLOCK(&sort_mutex); #else - qsort((char*)(ORIGMARK+1), max, sizeof(SV*), - (op->op_private & OPpLOCALE) ? sortcmp_locale : sortcmp); + qsortsv(ORIGMARK+1, max, + (op->op_private & OPpLOCALE) ? sv_cmp_locale : sv_cmp); #endif } } @@ -1251,25 +1250,23 @@ PP(pp_caller) AvREAL_off(dbargs); /* XXX Should be REIFY */ } - if (AvMAX(dbargs) < AvFILL(ary) + off) - av_extend(dbargs, AvFILL(ary) + off); - Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILL(ary) + 1 + off, SV*); - AvFILL(dbargs) = AvFILL(ary) + off; + if (AvMAX(dbargs) < AvFILLp(ary) + off) + av_extend(dbargs, AvFILLp(ary) + off); + Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILLp(ary) + 1 + off, SV*); + AvFILLp(dbargs) = AvFILLp(ary) + off; } RETURN; } -STATIC int -sortcv(const void *a, const void *b) +STATIC I32 +sortcv(SV *a, SV *b) { dTHR; - SV * const *str1 = (SV * const *)a; - SV * const *str2 = (SV * const *)b; I32 oldsaveix = savestack_ix; I32 oldscopeix = scopestack_ix; I32 result; - GvSV(firstgv) = *str1; - GvSV(secondgv) = *str2; + GvSV(firstgv) = a; + GvSV(secondgv) = b; stack_sp = stack_base; op = sortcop; CALLRUNOPS(); @@ -1285,18 +1282,6 @@ sortcv(const void *a, const void *b) return result; } -STATIC int -sortcmp(const void *a, const void *b) -{ - return sv_cmp(*(SV * const *)a, *(SV * const *)b); -} - -STATIC int -sortcmp_locale(const void *a, const void *b) -{ - return sv_cmp_locale(*(SV * const *)a, *(SV * const *)b); -} - PP(pp_reset) { djSP; @@ -1399,7 +1384,7 @@ PP(pp_enteriter) cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); else { cx->blk_loop.iterary = curstack; - AvFILL(curstack) = sp - stack_base; + AvFILLp(curstack) = sp - stack_base; cx->blk_loop.iterix = MARK - stack_base; } @@ -1673,7 +1658,7 @@ PP(pp_redo) static OP* lastgotoprobe; -STATIC OP * +static OP * dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit) { OP *kid; @@ -1765,7 +1750,7 @@ PP(pp_goto) if (cx->blk_sub.hasargs) { /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; - items = AvFILL(av) + 1; + items = AvFILLp(av) + 1; stack_sp++; EXTEND(stack_sp, items); /* @_ could have been extended. */ Copy(AvARRAY(av), stack_sp, items, SV*); @@ -1799,7 +1784,7 @@ PP(pp_goto) } else { stack_sp--; /* There is no cv arg. */ - (void)(*CvXSUB(cv))(THIS_ cv); + (void)(*CvXSUB(cv))(cv); } LEAVE; return pop_return(); @@ -1815,10 +1800,10 @@ PP(pp_goto) else { /* save temporaries on recursion? */ if (CvDEPTH(cv) == 100 && dowarn) sub_crush_depth(cv); - if (CvDEPTH(cv) > AvFILL(padlist)) { + if (CvDEPTH(cv) > AvFILLp(padlist)) { AV *newpad = newAV(); SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); - I32 ix = AvFILL((AV*)svp[1]); + I32 ix = AvFILLp((AV*)svp[1]); svp = AvARRAY(svp[0]); for ( ;ix > 0; ix--) { if (svp[ix] != &sv_undef) { @@ -1852,7 +1837,7 @@ PP(pp_goto) AvFLAGS(av) = AVf_REIFY; } av_store(padlist, CvDEPTH(cv), (SV*)newpad); - AvFILL(padlist) = CvDEPTH(cv); + AvFILLp(padlist) = CvDEPTH(cv); svp = AvARRAY(padlist); } } @@ -1860,7 +1845,7 @@ PP(pp_goto) if (!cx->blk_sub.hasargs) { AV* av = (AV*)curpad[0]; - items = AvFILL(av) + 1; + items = AvFILLp(av) + 1; if (items) { /* Mark is at the end of the stack. */ EXTEND(sp, items); @@ -1900,7 +1885,7 @@ PP(pp_goto) } } Copy(mark,AvARRAY(av),items,SV*); - AvFILL(av) = items - 1; + AvFILLp(av) = items - 1; while (items--) { if (*mark) @@ -2001,7 +1986,7 @@ PP(pp_goto) if (op->op_type == OP_ENTERITER) DIE("Can't \"goto\" into the middle of a foreach loop", label); - (CALLOP->op_ppaddr)(ARGS); + (*op->op_ppaddr)(ARGS); } op = oldop; } @@ -2089,7 +2074,7 @@ PP(pp_cswitch) /* Eval. */ -STATIC void +static void save_lines(AV *array, SV *sv) { register char *s = SvPVX(sv); @@ -2113,7 +2098,7 @@ save_lines(AV *array, SV *sv) } } -STATIC OP * +static OP * docatch(OP *o) { dTHR; @@ -2142,7 +2127,7 @@ docatch(OP *o) restartop = 0; /* FALL THROUGH */ case 0: - CALLRUNOPS(); + runops(); break; } JMPENV_POP; @@ -2205,7 +2190,7 @@ sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp) } /* With USE_THREADS, eval_owner must be held on entry to doeval */ -STATIC OP * +static OP * doeval(int gimme, OP** startop) { dSP; @@ -2213,6 +2198,7 @@ doeval(int gimme, OP** startop) HV *newstash; CV *caller; AV* comppadlist; + I32 i; in_eval = 1; @@ -2229,6 +2215,16 @@ doeval(int gimme, OP** startop) SAVEI32(max_intro_pending); caller = compcv; + for (i = cxstack_ix - 1; i >= 0; i--) { + PERL_CONTEXT *cx = &cxstack[i]; + if (cx->cx_type == CXt_EVAL) + break; + else if (cx->cx_type == CXt_SUB) { + caller = cx->blk_sub.cv; + break; + } + } + SAVESPTR(compcv); compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)compcv, SVt_PVCV); @@ -2629,10 +2625,10 @@ PP(pp_leaveeval) * (Note that the fact that compcv and friends are still set here * is, AFAIK, an accident.) --Chip */ - if (AvFILL(comppad_name) >= 0) { + if (AvFILLp(comppad_name) >= 0) { SV **svp = AvARRAY(comppad_name); I32 ix; - for (ix = AvFILL(comppad_name); ix >= 0; ix--) { + for (ix = AvFILLp(comppad_name); ix >= 0; ix--) { SV *sv = svp[ix]; if (sv && sv != &sv_undef && *SvPVX(sv) == '&') { SvREFCNT_dec(sv); @@ -2743,7 +2739,7 @@ PP(pp_leavetry) RETURN; } -STATIC void +static void doparseform(SV *sv) { STRLEN len; @@ -2921,4 +2917,683 @@ doparseform(SV *sv) SvCOMPILED_on(sv); } +/* + * The rest of this file was derived from source code contributed + * by Tom Horsley. + * + * NOTE: this code was derived from Tom Horsley's qsort replacement + * and should not be confused with the original code. + */ + +/* Copyright (C) Tom Horsley, 1997. All rights reserved. + + Permission granted to distribute under the same terms as perl which are + (briefly): + + This program is free software; you can redistribute it and/or modify + it under the terms of either: + + a) the GNU General Public License as published by the Free + Software Foundation; either version 1, or (at your option) any + later version, or + + b) the "Artistic License" which comes with this Kit. + + Details on the perl license can be found in the perl source code which + may be located via the www.perl.com web page. + + This is the most wonderfulest possible qsort I can come up with (and + still be mostly portable) My (limited) tests indicate it consistently + does about 20% fewer calls to compare than does the qsort in the Visual + C++ library, other vendors may vary. + + Some of the ideas in here can be found in "Algorithms" by Sedgewick, + others I invented myself (or more likely re-invented since they seemed + pretty obvious once I watched the algorithm operate for a while). + + Most of this code was written while watching the Marlins sweep the Giants + in the 1997 National League Playoffs - no Braves fans allowed to use this + code (just kidding :-). + + I realize that if I wanted to be true to the perl tradition, the only + comment in this file would be something like: + + ...they shuffled back towards the rear of the line. 'No, not at the + rear!' the slave-driver shouted. 'Three files up. And stay there... + + However, I really needed to violate that tradition just so I could keep + track of what happens myself, not to mention some poor fool trying to + understand this years from now :-). +*/ + +/* ********************************************************** Configuration */ + +#ifndef QSORT_ORDER_GUESS +#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */ +#endif + +/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for + future processing - a good max upper bound is log base 2 of memory size + (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can + safely be smaller than that since the program is taking up some space and + most operating systems only let you grab some subset of contiguous + memory (not to mention that you are normally sorting data larger than + 1 byte element size :-). +*/ +#ifndef QSORT_MAX_STACK +#define QSORT_MAX_STACK 32 +#endif + +/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort. + Anything bigger and we use qsort. If you make this too small, the qsort + will probably break (or become less efficient), because it doesn't expect + the middle element of a partition to be the same as the right or left - + you have been warned). +*/ +#ifndef QSORT_BREAK_EVEN +#define QSORT_BREAK_EVEN 6 +#endif + +/* ************************************************************* Data Types */ + +/* hold left and right index values of a partition waiting to be sorted (the + partition includes both left and right - right is NOT one past the end or + anything like that). +*/ +struct partition_stack_entry { + int left; + int right; +#ifdef QSORT_ORDER_GUESS + int qsort_break_even; +#endif +}; + +/* ******************************************************* Shorthand Macros */ + +/* Note that these macros will be used from inside the qsort function where + we happen to know that the variable 'elt_size' contains the size of an + array element and the variable 'temp' points to enough space to hold a + temp element and the variable 'array' points to the array being sorted + and 'compare' is the pointer to the compare routine. + + Also note that there are very many highly architecture specific ways + these might be sped up, but this is simply the most generally portable + code I could think of. +*/ +/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2 +*/ +#define qsort_cmp(elt1, elt2) \ + ((*compare)(array[elt1], array[elt2])) + +#ifdef QSORT_ORDER_GUESS +#define QSORT_NOTICE_SWAP swapped++; +#else +#define QSORT_NOTICE_SWAP +#endif + +/* swaps contents of array elements elt1, elt2. +*/ +#define qsort_swap(elt1, elt2) \ + STMT_START { \ + QSORT_NOTICE_SWAP \ + temp = array[elt1]; \ + array[elt1] = array[elt2]; \ + array[elt2] = temp; \ + } STMT_END + +/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets + elt3 and elt3 gets elt1. +*/ +#define qsort_rotate(elt1, elt2, elt3) \ + STMT_START { \ + QSORT_NOTICE_SWAP \ + temp = array[elt1]; \ + array[elt1] = array[elt2]; \ + array[elt2] = array[elt3]; \ + array[elt3] = temp; \ + } STMT_END + +/* ************************************************************ Debug stuff */ + +#ifdef QSORT_DEBUG + +static void +break_here() +{ + return; /* good place to set a breakpoint */ +} + +#define qsort_assert(t) (void)( (t) || (break_here(), 0) ) + +static void +doqsort_all_asserts( + void * array, + size_t num_elts, + size_t elt_size, + int (*compare)(const void * elt1, const void * elt2), + int pc_left, int pc_right, int u_left, int u_right) +{ + int i; + + qsort_assert(pc_left <= pc_right); + qsort_assert(u_right < pc_left); + qsort_assert(pc_right < u_left); + for (i = u_right + 1; i < pc_left; ++i) { + qsort_assert(qsort_cmp(i, pc_left) < 0); + } + for (i = pc_left; i < pc_right; ++i) { + qsort_assert(qsort_cmp(i, pc_right) == 0); + } + for (i = pc_right + 1; i < u_left; ++i) { + qsort_assert(qsort_cmp(pc_right, i) < 0); + } +} + +#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \ + doqsort_all_asserts(array, num_elts, elt_size, compare, \ + PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) + +#else + +#define qsort_assert(t) ((void)0) + +#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0) + +#endif + +/* ****************************************************************** qsort */ + +void +qsortsv( + SV ** array, + size_t num_elts, + I32 (*compare)(SV *a, SV *b)) +{ + register SV * temp; + + struct partition_stack_entry partition_stack[QSORT_MAX_STACK]; + int next_stack_entry = 0; + + int part_left; + int part_right; +#ifdef QSORT_ORDER_GUESS + int qsort_break_even; + int swapped; +#endif + + /* Make sure we actually have work to do. + */ + if (num_elts <= 1) { + return; + } + + /* Setup the initial partition definition and fall into the sorting loop + */ + part_left = 0; + part_right = (int)(num_elts - 1); +#ifdef QSORT_ORDER_GUESS + qsort_break_even = QSORT_BREAK_EVEN; +#else +#define qsort_break_even QSORT_BREAK_EVEN +#endif + for ( ; ; ) { + if ((part_right - part_left) >= qsort_break_even) { + /* OK, this is gonna get hairy, so lets try to document all the + concepts and abbreviations and variables and what they keep + track of: + + pc: pivot chunk - the set of array elements we accumulate in the + middle of the partition, all equal in value to the original + pivot element selected. The pc is defined by: + + pc_left - the leftmost array index of the pc + pc_right - the rightmost array index of the pc + + we start with pc_left == pc_right and only one element + in the pivot chunk (but it can grow during the scan). + + u: uncompared elements - the set of elements in the partition + we have not yet compared to the pivot value. There are two + uncompared sets during the scan - one to the left of the pc + and one to the right. + + u_right - the rightmost index of the left side's uncompared set + u_left - the leftmost index of the right side's uncompared set + + The leftmost index of the left sides's uncompared set + doesn't need its own variable because it is always defined + by the leftmost edge of the whole partition (part_left). The + same goes for the rightmost edge of the right partition + (part_right). + + We know there are no uncompared elements on the left once we + get u_right < part_left and no uncompared elements on the + right once u_left > part_right. When both these conditions + are met, we have completed the scan of the partition. + + Any elements which are between the pivot chunk and the + uncompared elements should be less than the pivot value on + the left side and greater than the pivot value on the right + side (in fact, the goal of the whole algorithm is to arrange + for that to be true and make the groups of less-than and + greater-then elements into new partitions to sort again). + + As you marvel at the complexity of the code and wonder why it + has to be so confusing. Consider some of the things this level + of confusion brings: + + Once I do a compare, I squeeze every ounce of juice out of it. I + never do compare calls I don't have to do, and I certainly never + do redundant calls. + + I also never swap any elements unless I can prove there is a + good reason. Many sort algorithms will swap a known value with + an uncompared value just to get things in the right place (or + avoid complexity :-), but that uncompared value, once it gets + compared, may then have to be swapped again. A lot of the + complexity of this code is due to the fact that it never swaps + anything except compared values, and it only swaps them when the + compare shows they are out of position. + */ + int pc_left, pc_right; + int u_right, u_left; + + int s; + + pc_left = ((part_left + part_right) / 2); + pc_right = pc_left; + u_right = pc_left - 1; + u_left = pc_right + 1; + + /* Qsort works best when the pivot value is also the median value + in the partition (unfortunately you can't find the median value + without first sorting :-), so to give the algorithm a helping + hand, we pick 3 elements and sort them and use the median value + of that tiny set as the pivot value. + + Some versions of qsort like to use the left middle and right as + the 3 elements to sort so they can insure the ends of the + partition will contain values which will stop the scan in the + compare loop, but when you have to call an arbitrarily complex + routine to do a compare, its really better to just keep track of + array index values to know when you hit the edge of the + partition and avoid the extra compare. An even better reason to + avoid using a compare call is the fact that you can drop off the + edge of the array if someone foolishly provides you with an + unstable compare function that doesn't always provide consistent + results. + + So, since it is simpler for us to compare the three adjacent + elements in the middle of the partition, those are the ones we + pick here (conveniently pointed at by u_right, pc_left, and + u_left). The values of the left, center, and right elements + are refered to as l c and r in the following comments. + */ + +#ifdef QSORT_ORDER_GUESS + swapped = 0; +#endif + s = qsort_cmp(u_right, pc_left); + if (s < 0) { + /* l < c */ + s = qsort_cmp(pc_left, u_left); + /* if l < c, c < r - already in order - nothing to do */ + if (s == 0) { + /* l < c, c == r - already in order, pc grows */ + ++pc_right; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else if (s > 0) { + /* l < c, c > r - need to know more */ + s = qsort_cmp(u_right, u_left); + if (s < 0) { + /* l < c, c > r, l < r - swap c & r to get ordered */ + qsort_swap(pc_left, u_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else if (s == 0) { + /* l < c, c > r, l == r - swap c&r, grow pc */ + qsort_swap(pc_left, u_left); + --pc_left; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else { + /* l < c, c > r, l > r - make lcr into rlc to get ordered */ + qsort_rotate(pc_left, u_right, u_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } + } + } else if (s == 0) { + /* l == c */ + s = qsort_cmp(pc_left, u_left); + if (s < 0) { + /* l == c, c < r - already in order, grow pc */ + --pc_left; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else if (s == 0) { + /* l == c, c == r - already in order, grow pc both ways */ + --pc_left; + ++pc_right; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else { + /* l == c, c > r - swap l & r, grow pc */ + qsort_swap(u_right, u_left); + ++pc_right; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } + } else { + /* l > c */ + s = qsort_cmp(pc_left, u_left); + if (s < 0) { + /* l > c, c < r - need to know more */ + s = qsort_cmp(u_right, u_left); + if (s < 0) { + /* l > c, c < r, l < r - swap l & c to get ordered */ + qsort_swap(u_right, pc_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else if (s == 0) { + /* l > c, c < r, l == r - swap l & c, grow pc */ + qsort_swap(u_right, pc_left); + ++pc_right; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else { + /* l > c, c < r, l > r - rotate lcr into crl to order */ + qsort_rotate(u_right, pc_left, u_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } + } else if (s == 0) { + /* l > c, c == r - swap ends, grow pc */ + qsort_swap(u_right, u_left); + --pc_left; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else { + /* l > c, c > r - swap ends to get in order */ + qsort_swap(u_right, u_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } + } + /* We now know the 3 middle elements have been compared and + arranged in the desired order, so we can shrink the uncompared + sets on both sides + */ + --u_right; + ++u_left; + qsort_all_asserts(pc_left, pc_right, u_left, u_right); + + /* The above massive nested if was the simple part :-). We now have + the middle 3 elements ordered and we need to scan through the + uncompared sets on either side, swapping elements that are on + the wrong side or simply shuffling equal elements around to get + all equal elements into the pivot chunk. + */ + + for ( ; ; ) { + int still_work_on_left; + int still_work_on_right; + + /* Scan the uncompared values on the left. If I find a value + equal to the pivot value, move it over so it is adjacent to + the pivot chunk and expand the pivot chunk. If I find a value + less than the pivot value, then just leave it - its already + on the correct side of the partition. If I find a greater + value, then stop the scan. + */ + while (still_work_on_left = (u_right >= part_left)) { + s = qsort_cmp(u_right, pc_left); + if (s < 0) { + --u_right; + } else if (s == 0) { + --pc_left; + if (pc_left != u_right) { + qsort_swap(u_right, pc_left); + } + --u_right; + } else { + break; + } + qsort_assert(u_right < pc_left); + qsort_assert(pc_left <= pc_right); + qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0); + qsort_assert(qsort_cmp(pc_left, pc_right) == 0); + } + + /* Do a mirror image scan of uncompared values on the right + */ + while (still_work_on_right = (u_left <= part_right)) { + s = qsort_cmp(pc_right, u_left); + if (s < 0) { + ++u_left; + } else if (s == 0) { + ++pc_right; + if (pc_right != u_left) { + qsort_swap(pc_right, u_left); + } + ++u_left; + } else { + break; + } + qsort_assert(u_left > pc_right); + qsort_assert(pc_left <= pc_right); + qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0); + qsort_assert(qsort_cmp(pc_left, pc_right) == 0); + } + + if (still_work_on_left) { + /* I know I have a value on the left side which needs to be + on the right side, but I need to know more to decide + exactly the best thing to do with it. + */ + if (still_work_on_right) { + /* I know I have values on both side which are out of + position. This is a big win because I kill two birds + with one swap (so to speak). I can advance the + uncompared pointers on both sides after swapping both + of them into the right place. + */ + qsort_swap(u_right, u_left); + --u_right; + ++u_left; + qsort_all_asserts(pc_left, pc_right, u_left, u_right); + } else { + /* I have an out of position value on the left, but the + right is fully scanned, so I "slide" the pivot chunk + and any less-than values left one to make room for the + greater value over on the right. If the out of position + value is immediately adjacent to the pivot chunk (there + are no less-than values), I can do that with a swap, + otherwise, I have to rotate one of the less than values + into the former position of the out of position value + and the right end of the pivot chunk into the left end + (got all that?). + */ + --pc_left; + if (pc_left == u_right) { + qsort_swap(u_right, pc_right); + qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1); + } else { + qsort_rotate(u_right, pc_left, pc_right); + qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1); + } + --pc_right; + --u_right; + } + } else if (still_work_on_right) { + /* Mirror image of complex case above: I have an out of + position value on the right, but the left is fully + scanned, so I need to shuffle things around to make room + for the right value on the left. + */ + ++pc_right; + if (pc_right == u_left) { + qsort_swap(u_left, pc_left); + qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right); + } else { + qsort_rotate(pc_right, pc_left, u_left); + qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right); + } + ++pc_left; + ++u_left; + } else { + /* No more scanning required on either side of partition, + break out of loop and figure out next set of partitions + */ + break; + } + } + + /* The elements in the pivot chunk are now in the right place. They + will never move or be compared again. All I have to do is decide + what to do with the stuff to the left and right of the pivot + chunk. + + Notes on the QSORT_ORDER_GUESS ifdef code: + + 1. If I just built these partitions without swapping any (or + very many) elements, there is a chance that the elements are + already ordered properly (being properly ordered will + certainly result in no swapping, but the converse can't be + proved :-). + + 2. A (properly written) insertion sort will run faster on + already ordered data than qsort will. + + 3. Perhaps there is some way to make a good guess about + switching to an insertion sort earlier than partition size 6 + (for instance - we could save the partition size on the stack + and increase the size each time we find we didn't swap, thus + switching to insertion sort earlier for partitions with a + history of not swapping). + + 4. Naturally, if I just switch right away, it will make + artificial benchmarks with pure ascending (or descending) + data look really good, but is that a good reason in general? + Hard to say... + */ + +#ifdef QSORT_ORDER_GUESS + if (swapped < 3) { +#if QSORT_ORDER_GUESS == 1 + qsort_break_even = (part_right - part_left) + 1; +#endif +#if QSORT_ORDER_GUESS == 2 + qsort_break_even *= 2; +#endif +#if QSORT_ORDER_GUESS == 3 + int prev_break = qsort_break_even; + qsort_break_even *= qsort_break_even; + if (qsort_break_even < prev_break) { + qsort_break_even = (part_right - part_left) + 1; + } +#endif + } else { + qsort_break_even = QSORT_BREAK_EVEN; + } +#endif + + if (part_left < pc_left) { + /* There are elements on the left which need more processing. + Check the right as well before deciding what to do. + */ + if (pc_right < part_right) { + /* We have two partitions to be sorted. Stack the biggest one + and process the smallest one on the next iteration. This + minimizes the stack height by insuring that any additional + stack entries must come from the smallest partition which + (because it is smallest) will have the fewest + opportunities to generate additional stack entries. + */ + if ((part_right - pc_right) > (pc_left - part_left)) { + /* stack the right partition, process the left */ + partition_stack[next_stack_entry].left = pc_right + 1; + partition_stack[next_stack_entry].right = part_right; +#ifdef QSORT_ORDER_GUESS + partition_stack[next_stack_entry].qsort_break_even = qsort_break_even; +#endif + part_right = pc_left - 1; + } else { + /* stack the left partition, process the right */ + partition_stack[next_stack_entry].left = part_left; + partition_stack[next_stack_entry].right = pc_left - 1; +#ifdef QSORT_ORDER_GUESS + partition_stack[next_stack_entry].qsort_break_even = qsort_break_even; +#endif + part_left = pc_right + 1; + } + qsort_assert(next_stack_entry < QSORT_MAX_STACK); + ++next_stack_entry; + } else { + /* The elements on the left are the only remaining elements + that need sorting, arrange for them to be processed as the + next partition. + */ + part_right = pc_left - 1; + } + } else if (pc_right < part_right) { + /* There is only one chunk on the right to be sorted, make it + the new partition and loop back around. + */ + part_left = pc_right + 1; + } else { + /* This whole partition wound up in the pivot chunk, so + we need to get a new partition off the stack. + */ + if (next_stack_entry == 0) { + /* the stack is empty - we are done */ + break; + } + --next_stack_entry; + part_left = partition_stack[next_stack_entry].left; + part_right = partition_stack[next_stack_entry].right; +#ifdef QSORT_ORDER_GUESS + qsort_break_even = partition_stack[next_stack_entry].qsort_break_even; +#endif + } + } else { + /* This partition is too small to fool with qsort complexity, just + do an ordinary insertion sort to minimize overhead. + */ + int i; + /* Assume 1st element is in right place already, and start checking + at 2nd element to see where it should be inserted. + */ + for (i = part_left + 1; i <= part_right; ++i) { + int j; + /* Scan (backwards - just in case 'i' is already in right place) + through the elements already sorted to see if the ith element + belongs ahead of one of them. + */ + for (j = i - 1; j >= part_left; --j) { + if (qsort_cmp(i, j) >= 0) { + /* i belongs right after j + */ + break; + } + } + ++j; + if (j != i) { + /* Looks like we really need to move some things + */ + temp = array[i]; + for (--i; i >= j; --i) + array[i + 1] = array[i]; + array[j] = temp; + } + } + + /* That partition is now sorted, grab the next one, or get out + of the loop if there aren't any more. + */ + + if (next_stack_entry == 0) { + /* the stack is empty - we are done */ + break; + } + --next_stack_entry; + part_left = partition_stack[next_stack_entry].left; + part_right = partition_stack[next_stack_entry].right; +#ifdef QSORT_ORDER_GUESS + qsort_break_even = partition_stack[next_stack_entry].qsort_break_even; +#endif + } + } + + /* Believe it or not, the array is sorted at this point! */ +} @@ -183,8 +183,11 @@ PP(pp_padsv) if (op->op_flags & OPf_MOD) { if (op->op_private & OPpLVAL_INTRO) SAVECLEARSV(curpad[op->op_targ]); - else if (op->op_private & OPpDEREF) + else if (op->op_private & OPpDEREF) { + PUTBACK; vivify_ref(curpad[op->op_targ], op->op_private & OPpDEREF); + SPAGAIN; + } } RETURN; } @@ -295,8 +298,11 @@ PP(pp_print) gv = (GV*)*++MARK; else gv = defoutgv; - if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { + if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { if (MARK == ORIGMARK) { + /* If using default handle then we need to make space to + * pass object as 1st arg, so move other args up ... + */ MEXTEND(SP, 1); ++MARK; Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); @@ -443,8 +449,17 @@ PP(pp_rv2av) if (GIMME == G_ARRAY) { I32 maxarg = AvFILL(av) + 1; - EXTEND(SP, maxarg); - Copy(AvARRAY(av), SP+1, maxarg, SV*); + EXTEND(SP, maxarg); + if (SvRMAGICAL(av)) { + U32 i; + for (i=0; i < maxarg; i++) { + SV **svp = av_fetch(av, i, FALSE); + SP[i+1] = (svp) ? *svp : &sv_undef; + } + } + else { + Copy(AvARRAY(av), SP+1, maxarg, SV*); + } SP += maxarg; } else { @@ -983,7 +998,7 @@ do_readline(void) I32 gimme = GIMME_V; MAGIC *mg; - if (SvMAGICAL(last_in_gv) && (mg = mg_find((SV*)last_in_gv, 'q'))) { + if (SvRMAGICAL(last_in_gv) && (mg = mg_find((SV*)last_in_gv, 'q'))) { PUSHMARK(SP); XPUSHs(mg->mg_obj); PUTBACK; @@ -1378,7 +1393,9 @@ PP(pp_iter) SvREFCNT_dec(*cx->blk_loop.itervar); - if (sv = AvARRAY(av)[++cx->blk_loop.iterix]) + if (sv = (SvMAGICAL(av)) + ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) + : AvARRAY(av)[++cx->blk_loop.iterix]) SvTEMP_off(sv); else sv = &sv_undef; @@ -1439,11 +1456,13 @@ PP(pp_subst) else { TARG = DEFSV; EXTEND(SP,1); - } + } if (SvREADONLY(TARG) || (SvTYPE(TARG) > SVt_PVLV && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) croak(no_modify); + PUTBACK; + s = SvPV(TARG, len); if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV) force_on_match = 1; @@ -1519,6 +1538,7 @@ PP(pp_subst) if (c && clen <= rx->minlen && (once || !(safebase & REXEC_COPY_STR)) && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) { if (!regexec_flags(rx, s, strend, orig, 0, screamer, NULL, safebase)) { + SPAGAIN; PUSHs(&sv_no); LEAVE_SCOPE(oldsave); RETURN; @@ -1574,6 +1594,7 @@ PP(pp_subst) sv_chop(TARG, d); } TAINT_IF(rxtainted); + SPAGAIN; PUSHs(&sv_yes); } else { @@ -1602,10 +1623,15 @@ PP(pp_subst) Move(s, d, i+1, char); /* include the NUL */ } TAINT_IF(rxtainted); + SPAGAIN; PUSHs(sv_2mortal(newSViv((I32)iters))); } (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); + if (SvSMAGICAL(TARG)) { + PUTBACK; + mg_set(TARG); + SPAGAIN; + } SvTAINT(TARG); LEAVE_SCOPE(oldsave); RETURN; @@ -1618,11 +1644,12 @@ PP(pp_subst) goto force_it; } rxtainted = RX_MATCH_TAINTED(rx); - dstr = NEWSV(25, sv_len(TARG)); + dstr = NEWSV(25, len); sv_setpvn(dstr, m, s-m); curpm = pm; if (!c) { register PERL_CONTEXT *cx; + SPAGAIN; PUSHSUBST(cx); RETURNOP(cPMOP->op_pmreplroot); } @@ -1660,6 +1687,7 @@ PP(pp_subst) (void)SvPOK_only(TARG); SvSETMAGIC(TARG); SvTAINT(TARG); + SPAGAIN; PUSHs(sv_2mortal(newSViv((I32)iters))); LEAVE_SCOPE(oldsave); RETURN; @@ -1669,7 +1697,8 @@ PP(pp_subst) nope: ++BmUSEFUL(rx->check_substr); -ret_no: +ret_no: + SPAGAIN; PUSHs(&sv_no); LEAVE_SCOPE(oldsave); RETURN; @@ -2038,7 +2067,7 @@ PP(pp_entersub) #else av = GvAV(defgv); #endif /* USE_THREADS */ - items = AvFILL(av) + 1; + items = AvFILLp(av) + 1; /* @_ is not tieable */ if (items) { /* Mark is at the end of the stack. */ @@ -2085,11 +2114,11 @@ PP(pp_entersub) if (CvDEPTH(cv) == 100 && dowarn && !(PERLDB_SUB && cv == GvCV(DBsub))) sub_crush_depth(cv); - if (CvDEPTH(cv) > AvFILL(padlist)) { + if (CvDEPTH(cv) > AvFILLp(padlist)) { AV *av; AV *newpad = newAV(); SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); - I32 ix = AvFILL((AV*)svp[1]); + I32 ix = AvFILLp((AV*)svp[1]); svp = AvARRAY(svp[0]); for ( ;ix > 0; ix--) { if (svp[ix] != &sv_undef) { @@ -2119,7 +2148,7 @@ PP(pp_entersub) av_store(newpad, 0, (SV*)av); AvFLAGS(av) = AVf_REIFY; av_store(padlist, CvDEPTH(cv), (SV*)newpad); - AvFILL(padlist) = CvDEPTH(cv); + AvFILLp(padlist) = CvDEPTH(cv); svp = AvARRAY(padlist); } } @@ -2127,7 +2156,7 @@ PP(pp_entersub) if (!hasargs) { AV* av = (AV*)curpad[0]; - items = AvFILL(av) + 1; + items = AvFILLp(av) + 1; if (items) { /* Mark is at the end of the stack. */ EXTEND(sp, items); @@ -2176,7 +2205,7 @@ PP(pp_entersub) } } Copy(MARK,AvARRAY(av),items,SV*); - AvFILL(av) = items - 1; + AvFILLp(av) = items - 1; while (items--) { if (*MARK) @@ -516,62 +516,48 @@ PP(pp_tie) SV **mark = stack_base + ++*markstack_ptr; /* reuse in entersub */ I32 markoff = mark - stack_base - 1; char *methname; -#ifdef ORIGINAL_TIE - BINOP myop; - bool oldcatch = CATCH_GET; -#endif - - varsv = mark[0]; - if (SvTYPE(varsv) == SVt_PVHV) - methname = "TIEHASH"; - else if (SvTYPE(varsv) == SVt_PVAV) - methname = "TIEARRAY"; - else if (SvTYPE(varsv) == SVt_PVGV) - methname = "TIEHANDLE"; - else - methname = "TIESCALAR"; - - stash = gv_stashsv(mark[1], FALSE); - if (!stash || !(gv = gv_fetchmethod(stash, methname))) - DIE("Can't locate object method \"%s\" via package \"%s\"", - methname, SvPV(mark[1],na)); - -#ifdef ORIGINAL_TIE - Zero(&myop, 1, BINOP); - myop.op_last = (OP *) &myop; - myop.op_next = Nullop; - myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; - CATCH_SET(TRUE); + int how = 'P'; - ENTER; - SAVEOP(); - op = (OP *) &myop; - if (PERLDB_SUB && curstash != debstash) - op->op_private |= OPpENTERSUB_DB; - - XPUSHs((SV*)GvCV(gv)); - PUTBACK; + varsv = mark[0]; + switch(SvTYPE(varsv)) { + case SVt_PVHV: + methname = "TIEHASH"; + break; + case SVt_PVAV: + methname = "TIEARRAY"; + break; + case SVt_PVGV: + methname = "TIEHANDLE"; + how = 'q'; + break; + default: + methname = "TIESCALAR"; + how = 'q'; + break; + } - if (op = pp_entersub(ARGS)) - CALLRUNOPS(); + if (sv_isobject(mark[1])) { + ENTER; + perl_call_method(methname, G_SCALAR); + } + else { + /* Not clear why we don't call perl_call_method here too. + * perhaps to get different error message ? + */ + stash = gv_stashsv(mark[1], FALSE); + if (!stash || !(gv = gv_fetchmethod(stash, methname))) { + DIE("Can't locate object method \"%s\" via package \"%s\"", + methname, SvPV(mark[1],na)); + } + ENTER; + perl_call_sv((SV*)GvCV(gv), G_SCALAR); + } SPAGAIN; - CATCH_SET(oldcatch); -#else - ENTER; - perl_call_sv((SV*)GvCV(gv), G_SCALAR); - SPAGAIN; -#endif sv = TOPs; if (sv_isobject(sv)) { - if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) { - sv_unmagic(varsv, 'P'); - sv_magic(varsv, sv, 'P', Nullch, 0); - } - else { - sv_unmagic(varsv, 'q'); - sv_magic(varsv, sv, 'q', Nullch, 0); - } + sv_unmagic(varsv, how); + sv_magic(varsv, sv, how, Nullch, 0); } LEAVE; SP = stack_base + markoff; @@ -583,8 +569,7 @@ PP(pp_untie) { djSP; SV * sv ; - - sv = POPs; + sv = POPs; if (dowarn) { MAGIC * mg ; @@ -625,7 +610,6 @@ PP(pp_tied) RETURN ; } } - RETPUSHUNDEF; } @@ -637,10 +621,6 @@ PP(pp_dbmopen) HV* stash; GV *gv; SV *sv; -#ifdef ORIGINAL_TIE - BINOP myop; - bool oldcatch = CATCH_GET; -#endif hv = (HV*)POPs; @@ -655,24 +635,9 @@ PP(pp_dbmopen) DIE("No dbm on this machine"); } -#ifdef ORIGINAL_TIE - Zero(&myop, 1, BINOP); - myop.op_last = (OP *) &myop; - myop.op_next = Nullop; - myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; - CATCH_SET(TRUE); - - ENTER; - SAVEOP(); - op = (OP *) &myop; - if (PERLDB_SUB && curstash != debstash) - op->op_private |= OPpENTERSUB_DB; - PUTBACK; - pp_pushmark(ARGS); -#else ENTER; PUSHMARK(sp); -#endif + EXTEND(sp, 5); PUSHs(sv); PUSHs(left); @@ -681,51 +646,26 @@ PP(pp_dbmopen) else PUSHs(sv_2mortal(newSViv(O_RDWR))); PUSHs(right); -#ifdef ORIGINAL_TIE - PUSHs((SV*)GvCV(gv)); - PUTBACK; - - if (op = pp_entersub(ARGS)) - CALLRUNOPS(); -#else PUTBACK; perl_call_sv((SV*)GvCV(gv), G_SCALAR); -#endif SPAGAIN; if (!sv_isobject(TOPs)) { sp--; -#ifdef ORIGINAL_TIE - op = (OP *) &myop; - PUTBACK; - pp_pushmark(ARGS); -#else PUSHMARK(sp); -#endif - PUSHs(sv); PUSHs(left); PUSHs(sv_2mortal(newSViv(O_RDONLY))); PUSHs(right); -#ifdef ORIGINAL_TIE - PUSHs((SV*)GvCV(gv)); -#endif PUTBACK; - -#ifdef ORIGINAL_TIE - if (op = pp_entersub(ARGS)) - CALLRUNOPS(); -#else perl_call_sv((SV*)GvCV(gv), G_SCALAR); -#endif SPAGAIN; } -#ifdef ORIGINAL_TIE - CATCH_SET(oldcatch); -#endif - if (sv_isobject(TOPs)) + if (sv_isobject(TOPs)) { + sv_unmagic((SV *) hv, 'P'); sv_magic((SV*)hv, TOPs, 'P', Nullch, 0); + } LEAVE; RETURN; } @@ -927,7 +867,7 @@ PP(pp_getc) if (!gv) gv = argvgv; - if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { + if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { I32 gimme = GIMME_V; PUSHMARK(SP); XPUSHs(mg->mg_obj); @@ -1145,7 +1085,7 @@ PP(pp_prtf) else gv = defoutgv; - if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { + if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { if (MARK == ORIGMARK) { MEXTEND(SP, 1); ++MARK; @@ -1255,7 +1195,7 @@ PP(pp_sysread) gv = (GV*)*++MARK; if ((op->op_type == OP_READ || op->op_type == OP_SYSREAD) && - SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) + SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { SV *sv; @@ -3641,8 +3581,10 @@ PP(pp_ghostent) #if defined(HAS_GETHOSTENT) && !defined(DONT_DECLARE_STD) struct hostent *PerlSock_gethostbyname(const char *); struct hostent *PerlSock_gethostbyaddr(const Gethbadd_addr_t, Gethbadd_alen_t, int); +#ifndef PerlSock_gethostent struct hostent *PerlSock_gethostent(void); #endif +#endif struct hostent *hent; unsigned long len; @@ -3821,8 +3763,10 @@ PP(pp_gprotoent) #ifndef DONT_DECLARE_STD struct protoent *PerlSock_getprotobyname(const char *); struct protoent *PerlSock_getprotobynumber(int); +#ifndef PerlSock_getprotoent struct protoent *PerlSock_getprotoent(void); #endif +#endif struct protoent *pent; if (which == OP_GPBYNAME) @@ -3891,8 +3835,10 @@ PP(pp_gservent) #ifndef DONT_DECLARE_STD struct servent *PerlSock_getservbyname(const char *, const char *); struct servent *PerlSock_getservbynumber(); +#ifndef PerlSock_getservent struct servent *PerlSock_getservent(void); #endif +#endif struct servent *sent; if (which == OP_GSBYNAME) { @@ -499,54 +499,44 @@ VIRTUAL char* screaminstr _((SV* bigsv, SV* littlesv, I32 start_shift, I32 end_s #ifndef VMS VIRTUAL I32 setenv_getix _((char* nam)); #endif -VIRTUAL void setdefout _((GV* gv)); -VIRTUAL char* sharepvn _((char* sv, I32 len, U32 hash)); -VIRTUAL HEK* share_hek _((char* sv, I32 len, U32 hash)); -VIRTUAL Signal_t sighandler _((int sig)); -VIRTUAL SV** stack_grow _((SV** sp, SV**p, int n)); -VIRTUAL I32 start_subparse _((I32 is_format, U32 flags)); -VIRTUAL void sub_crush_depth _((CV* cv)); -VIRTUAL bool sv_2bool _((SV* sv)); -VIRTUAL CV* sv_2cv _((SV* sv, HV** st, GV** gvp, I32 lref)); -VIRTUAL IO* sv_2io _((SV* sv)); -VIRTUAL IV sv_2iv _((SV* sv)); -VIRTUAL SV* sv_2mortal _((SV* sv)); -VIRTUAL double sv_2nv _((SV* sv)); -VIRTUAL char* sv_2pv _((SV* sv, STRLEN* lp)); -VIRTUAL UV sv_2uv _((SV* sv)); -VIRTUAL IV sv_iv _((SV* sv)); -VIRTUAL UV sv_uv _((SV* sv)); -VIRTUAL double sv_nv _((SV* sv)); -VIRTUAL char * sv_pvn _((SV *, STRLEN *)); -VIRTUAL I32 sv_true _((SV *)); -VIRTUAL void sv_add_arena _((char* ptr, U32 size, U32 flags)); -VIRTUAL int sv_backoff _((SV* sv)); -VIRTUAL SV* sv_bless _((SV* sv, HV* stash)); -VIRTUAL void sv_catpvf _((SV* sv, const char* pat, ...)); -VIRTUAL void sv_catpv _((SV* sv, char* ptr)); -VIRTUAL void sv_catpvn _((SV* sv, char* ptr, STRLEN len)); -VIRTUAL void sv_catsv _((SV* dsv, SV* ssv)); -VIRTUAL void sv_chop _((SV* sv, char* ptr)); -VIRTUAL void sv_clean_all _((void)); -VIRTUAL void sv_clean_objs _((void)); -VIRTUAL void sv_clear _((SV* sv)); -VIRTUAL I32 sv_cmp _((SV* sv1, SV* sv2)); -VIRTUAL I32 sv_cmp_locale _((SV* sv1, SV* sv2)); +VIRTUAL int magic_setdefelem _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_setenv _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_setfm _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_setisa _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_setglob _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_setmglob _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_setnkeys _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_setpack _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_setpos _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_setsig _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_setsubstr _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_settaint _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_setuvar _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_setvec _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_set_all_env _((SV* sv, MAGIC* mg)); +VIRTUAL U32 magic_sizepack _((SV* sv, MAGIC* mg)); +VIRTUAL int magic_wipepack _((SV* sv, MAGIC* mg)); +VIRTUAL void magicname _((char* sym, char* name, I32 namlen)); +VIRTUAL int main _((int argc, char** argv, char** env)); +VIRTUAL void markstack_grow _((void)); #ifdef USE_LOCALE_COLLATE -VIRTUAL char* sv_collxfrm _((SV* sv, STRLEN* nxp)); +VIRTUAL char* mem_collxfrm _((const char* s, STRLEN len, STRLEN* xlen)); #endif -VIRTUAL OP* sv_compile_2op _((SV* sv, OP** startp, char* code, AV** avp)); -VIRTUAL void sv_dec _((SV* sv)); -VIRTUAL void sv_dump _((SV* sv)); -VIRTUAL bool sv_derived_from _((SV* sv, char* name)); -VIRTUAL I32 sv_eq _((SV* sv1, SV* sv2)); -VIRTUAL void sv_free _((SV* sv)); -VIRTUAL void sv_free_arenas _((void)); -VIRTUAL char* sv_gets _((SV* sv, PerlIO* fp, I32 append)); -#ifndef DOSISH -VIRTUAL char* sv_grow _((SV* sv, I32 newlen)); -#else -VIRTUAL char* sv_grow _((SV* sv, unsigned long newlen)); +VIRTUAL char* mess _((const char* pat, va_list* args)); +VIRTUAL int mg_clear _((SV* sv)); +VIRTUAL int mg_copy _((SV* , SV* , char* , I32)); +VIRTUAL MAGIC* mg_find _((SV* sv, int type)); +VIRTUAL int mg_free _((SV* sv)); +VIRTUAL int mg_get _((SV* sv)); +VIRTUAL U32 mg_len _((SV* sv)); +VIRTUAL void mg_magical _((SV* sv)); +VIRTUAL int mg_set _((SV* sv)); +VIRTUAL I32 mg_size _((SV* sv)); +VIRTUAL OP* mod _((OP* o, I32 type)); +VIRTUAL char* moreswitches _((char* s)); +VIRTUAL OP* my _((OP* o)); +#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) +VIRTUAL char* my_bcopy _((char* from, char* to, I32 len)); #endif VIRTUAL void sv_inc _((SV* sv)); VIRTUAL void sv_insert _((SV* bigsv, STRLEN offset, STRLEN len, char* little, STRLEN littlelen)); @@ -596,27 +586,42 @@ VIRTUAL I32 unlnk _((char* f)); #ifdef USE_THREADS VIRTUAL void unlock_condpair _((void* svv)); #endif -VIRTUAL void unsharepvn _((char* sv, I32 len, U32 hash)); -VIRTUAL void unshare_hek _((HEK* hek)); -VIRTUAL void utilize _((int aver, I32 floor, OP* version, OP* id, OP* arg)); -VIRTUAL void vivify_defelem _((SV* sv)); -VIRTUAL void vivify_ref _((SV* sv, U32 to_what)); -VIRTUAL I32 wait4pid _((int pid, int* statusp, int flags)); -VIRTUAL void warn _((const char* pat,...)); -VIRTUAL void watch _((char** addr)); -VIRTUAL I32 whichsig _((char* sig)); -VIRTUAL int yyerror _((char* s)); -VIRTUAL int yylex _((void)); -VIRTUAL int yyparse _((void)); -VIRTUAL int yywarn _((char* s)); - -#ifndef MYMALLOC -VIRTUAL Malloc_t safemalloc _((MEM_SIZE nbytes)); -VIRTUAL Malloc_t safecalloc _((MEM_SIZE elements, MEM_SIZE size)); -VIRTUAL Malloc_t saferealloc _((Malloc_t where, MEM_SIZE nbytes)); -VIRTUAL Free_t safefree _((Malloc_t where)); +VIRTUAL void my_unexec _((void)); +VIRTUAL OP* newANONLIST _((OP* o)); +VIRTUAL OP* newANONHASH _((OP* o)); +VIRTUAL OP* newANONSUB _((I32 floor, OP* proto, OP* block)); +VIRTUAL OP* newASSIGNOP _((I32 flags, OP* left, I32 optype, OP* right)); +VIRTUAL OP* newCONDOP _((I32 flags, OP* expr, OP* trueop, OP* falseop)); +VIRTUAL void newFORM _((I32 floor, OP* o, OP* block)); +VIRTUAL OP* newFOROP _((I32 flags, char* label, line_t forline, OP* scalar, OP* expr, OP*block, OP*cont)); +VIRTUAL OP* newLOGOP _((I32 optype, I32 flags, OP* left, OP* right)); +VIRTUAL OP* newLOOPEX _((I32 type, OP* label)); +VIRTUAL OP* newLOOPOP _((I32 flags, I32 debuggable, OP* expr, OP* block)); +VIRTUAL OP* newNULLLIST _((void)); +VIRTUAL OP* newOP _((I32 optype, I32 flags)); +VIRTUAL void newPROG _((OP* o)); +VIRTUAL OP* newRANGE _((I32 flags, OP* left, OP* right)); +VIRTUAL OP* newSLICEOP _((I32 flags, OP* subscript, OP* list)); +VIRTUAL OP* newSTATEOP _((I32 flags, char* label, OP* o)); +VIRTUAL CV* newSUB _((I32 floor, OP* o, OP* proto, OP* block)); +VIRTUAL CV* newXS _((char* name, void (*subaddr)(CV* cv), char* filename)); +VIRTUAL AV* newAV _((void)); +VIRTUAL OP* newAVREF _((OP* o)); +VIRTUAL OP* newBINOP _((I32 type, I32 flags, OP* first, OP* last)); +VIRTUAL OP* newCVREF _((I32 flags, OP* o)); +VIRTUAL OP* newGVOP _((I32 type, I32 flags, GV* gv)); +VIRTUAL GV* newGVgen _((char* pack)); +VIRTUAL OP* newGVREF _((I32 type, OP* o)); +VIRTUAL OP* newHVREF _((OP* o)); +VIRTUAL HV* newHV _((void)); +VIRTUAL IO* newIO _((void)); +VIRTUAL OP* newLISTOP _((I32 type, I32 flags, OP* first, OP* last)); +VIRTUAL OP* newPMOP _((I32 type, I32 flags)); +VIRTUAL OP* newPVOP _((I32 type, I32 flags, char* pv)); +VIRTUAL SV* newRV _((SV* ref)); +#if !defined(__GNUC__) && (defined(CRIPPLED_CC) || defined(USE_THREADS)) +VIRTUAL SV* newRV_noinc _((SV *)); #endif - #ifdef LEAKTEST VIRTUAL Malloc_t safexmalloc _((I32 x, MEM_SIZE size)); VIRTUAL Malloc_t safexcalloc _((I32 x, MEM_SIZE elements, MEM_SIZE size)); @@ -209,9 +209,9 @@ EXTCONST U8 regkind[] = { /* The following have no fixed length. char* since we do strchr on it. */ #ifndef DOINIT -EXT const char varies[]; +EXTCONST char varies[]; #else -EXT const char varies[] = { +EXTCONST char varies[] = { BRANCH, BACK, STAR, PLUS, CURLY, CURLYX, REF, REFF, REFFL, WHILEM, CURLYM, CURLYN, BRANCHJ, IFTHEN, SUSPEND, 0 }; @@ -219,9 +219,9 @@ EXT const char varies[] = { /* The following always have a length of 1. char* since we do strchr on it. */ #ifndef DOINIT -EXT const char simple[]; +EXTCONST char simple[]; #else -EXT const char simple[] = { +EXTCONST char simple[] = { ANY, SANY, ANYOF, ALNUM, ALNUML, NALNUM, NALNUML, SPACE, SPACEL, NSPACE, NSPACEL, @@ -1578,8 +1578,10 @@ regmatch(regnode *prog) logical = 0; sw = 1; } - if (OP(scan) == SUSPEND) + if (OP(scan) == SUSPEND) { locinput = reginput; + nextchar = UCHARAT(locinput); + } /* FALL THROUGH. */ case LONGJMP: do_longjump: @@ -19,8 +19,16 @@ SV** stack_grow(SV **sp, SV **p, int n) { dTHR; +#if defined(DEBUGGING) && !defined(USE_THREADS) + static int growing = 0; + if (growing++) + abort(); +#endif stack_sp = sp; av_extend(curstack, (p - stack_base) + (n) + 128); +#if defined(DEBUGGING) && !defined(USE_THREADS) + growing--; +#endif return stack_sp; } @@ -197,11 +205,14 @@ AV * save_ary(GV *gv) { dTHR; - AV *oav, *av; + AV *oav = GvAVn(gv); + AV *av; + if (!AvREAL(oav) && AvREIFY(oav)) + av_reify(oav); SSCHECK(3); SSPUSHPTR(gv); - SSPUSHPTR(oav = GvAVn(gv)); + SSPUSHPTR(oav); SSPUSHINT(SAVEt_AV); GvAV(gv) = Null(AV*); @@ -795,7 +795,7 @@ sv_upgrade(register SV *sv, U32 mt) Safefree(pv); SvPVX(sv) = 0; AvMAX(sv) = -1; - AvFILL(sv) = -1; + AvFILLp(sv) = -1; SvIVX(sv) = 0; SvNVX(sv) = 0.0; SvMAGIC(sv) = magic; @@ -3713,8 +3713,6 @@ sv_true(register SV *sv) dTHR; if (!sv) return 0; - if (SvGMAGICAL(sv)) - mg_get(sv); if (SvPOK(sv)) { register XPV* tXpv; if ((tXpv = (XPV*)SvANY(sv)) && @@ -3916,8 +3914,10 @@ newSVrv(SV *rv, char *classname) SV* sv_setref_pv(SV *rv, char *classname, void *pv) { - if (!pv) + if (!pv) { sv_setsv(rv, &sv_undef); + SvSETMAGIC(rv); + } else sv_setiv(newSVrv(rv,classname), (IV)pv); return rv; @@ -4782,7 +4782,7 @@ sv_dump(SV *sv) case SVt_PVAV: PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n", (long)AvARRAY(sv)); PerlIO_printf(Perl_debug_log, " ALLOC = 0x%lx\n", (long)AvALLOC(sv)); - PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILL(sv)); + PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILLp(sv)); PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)AvMAX(sv)); PerlIO_printf(Perl_debug_log, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv)); flags = AvFLAGS(sv); @@ -611,23 +611,28 @@ struct xpvio { # endif #endif /* __GNUC__ */ -/* the following macro updates any magic values this sv is associated with */ +/* the following macros updates any magic values this sv is associated with */ -#define SvSETMAGIC(x) if (SvSMAGICAL(x)) mg_set(x) +#define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +#define SvSETMAGIC(x) STMT_START { if (SvSMAGICAL(x)) mg_set(x); } STMT_END #define SvSetSV_and(dst,src,finally) \ + STMT_START { \ if ((dst) != (src)) { \ sv_setsv(dst, src); \ finally; \ - } + } \ + } STMT_END #define SvSetSV_nosteal_and(dst,src,finally) \ + STMT_START { \ if ((dst) != (src)) { \ U32 tMpF = SvFLAGS(src) & SVs_TEMP; \ SvTEMP_off(src); \ sv_setsv(dst, src); \ SvFLAGS(src) |= tMpF; \ finally; \ - } + } \ + } STMT_END #define SvSetSV(dst,src) \ SvSetSV_and(dst,src,/*nothing*/;) @@ -639,6 +644,27 @@ struct xpvio { #define SvSetMagicSV_nosteal(dst,src) \ SvSetSV_nosteal_and(dst,src,SvSETMAGIC(dst)) +#define SvSetMagicPV(dst,s) \ + STMT_START { sv_setpv(dst,s); SvSETMAGIC(dst); } STMT_END +#define SvSetMagicPVN(dst,s,l) \ + STMT_START { sv_setpvn(dst,s,l); SvSETMAGIC(dst); } STMT_END +#define SvSetMagicIV(dst,i) \ + STMT_START { sv_setiv(dst,i); SvSETMAGIC(dst); } STMT_END +#define SvSetMagicPVIV(dst,i) \ + STMT_START { sv_setpviv(dst,i); SvSETMAGIC(dst); } STMT_END +#define SvSetMagicUV(dst,u) \ + STMT_START { sv_setuv(dst,u); SvSETMAGIC(dst); } STMT_END +#define SvSetMagicNV(dst,n) \ + STMT_START { sv_setnv(dst,n); SvSETMAGIC(dst); } STMT_END +#define SvCatMagicPV(dst,s) \ + STMT_START { sv_catpv(dst,s); SvSETMAGIC(dst); } STMT_END +#define SvCatMagicPVN(dst,s,l) \ + STMT_START { sv_catpvn(dst,s,l); SvSETMAGIC(dst); } STMT_END +#define SvCatMagicSV(dst,src) \ + STMT_START { sv_catsv(dst,src); SvSETMAGIC(dst); } STMT_END +#define SvUseMagicPVN(dst,s,l) \ + STMT_START { sv_usepvn(dst,s,l); SvSETMAGIC(dst); } STMT_END + #define SvPEEK(sv) sv_peek(sv) #define SvIMMORTAL(sv) ((sv)==&sv_undef || (sv)==&sv_yes || (sv)==&sv_no) @@ -6,6 +6,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + $ENV{PERL5LIB} = '../lib'; # so children will see it too } use lib '../lib'; diff --git a/t/lib/tie-push.t b/t/lib/tie-push.t new file mode 100755 index 0000000000..dd718deb14 --- /dev/null +++ b/t/lib/tie-push.t @@ -0,0 +1,24 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +{ + package Basic; + use Tie::Array; + @ISA = qw(Tie::Array); + + sub TIEARRAY { return bless [], shift } + sub FETCH { $_[0]->[$_[1]] } + sub STORE { $_[0]->[$_[1]] = $_[2] } + sub FETCHSIZE { scalar(@{$_[0]}) } + sub STORESIZE { $#{$_[0]} = $_[1]-1 } +} + +tie @x,Basic; +tie @get,Basic; +tie @got,Basic; +tie @tests,Basic; +require "../t/op/push.t" diff --git a/t/lib/tie-stdarray.t b/t/lib/tie-stdarray.t new file mode 100755 index 0000000000..7ca4d76f11 --- /dev/null +++ b/t/lib/tie-stdarray.t @@ -0,0 +1,12 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Tie::Array; +tie @foo,Tie::StdArray; +tie @ary,Tie::StdArray; +tie @bar,Tie::StdArray; +require "../t/op/array.t" diff --git a/t/lib/tie-stdpush.t b/t/lib/tie-stdpush.t new file mode 100755 index 0000000000..34a69472f4 --- /dev/null +++ b/t/lib/tie-stdpush.t @@ -0,0 +1,10 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Tie::Array; +tie @x,Tie::StdArray; +require "../t/op/push.t" diff --git a/t/op/avhv.t b/t/op/avhv.t index 0390429d2b..a7ce58ab87 100755 --- a/t/op/avhv.t +++ b/t/op/avhv.t @@ -1,13 +1,23 @@ #!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +require Tie::Array; -package Tie::StdArray; +package Tie::BasicArray; +@ISA = 'Tie::Array'; sub TIEARRAY { bless [], $_[0] } -sub STORE { $_[0]->[$_[1]] = $_[2] } -sub FETCH { $_[0]->[$_[1]] } +sub STORE { $_[0]->[$_[1]] = $_[2] } +sub FETCH { $_[0]->[$_[1]] } +sub FETCHSIZE { scalar(@{$_[0]})} +sub STORESIZE { $#{$_[0]} = $_[1]+1 } package main; -print "1..4\n"; +print "1..5\n"; $sch = { 'abc' => 1, @@ -48,12 +58,19 @@ $a->[0] = $sch; $a->{'abc'} = 'ABC'; if ($a->{'abc'} eq 'ABC') {print "ok 3\n";} else {print "not ok 3\n";} +# quick check with tied array +tie @fake, 'Tie::BasicArray'; +$a = \@fake; +$a->[0] = $sch; + +$a->{'abc'} = 'ABC'; +if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";} + # quick check with tied array & tied hash -@INC = ("./lib", "../lib"); require Tie::Hash; tie %fake, Tie::StdHash; %fake = %$sch; $a->[0] = \%fake; $a->{'abc'} = 'ABC'; -if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";} +if ($a->{'abc'} eq 'ABC') {print "ok 5\n";} else {print "not ok 5\n";} diff --git a/t/op/push.t b/t/op/push.t index 68fab66af7..f62a4e9d8e 100755 --- a/t/op/push.t +++ b/t/op/push.t @@ -22,7 +22,7 @@ die "blech" unless @tests; @x = (1,2,3); push(@x,@x); if (join(':',@x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} -push(x,4); +push(@x,4); if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";} $test = 3; @@ -47,3 +47,4 @@ foreach $line (@tests) { } } +1; # this file is require'd by lib/tie-stdpush.t diff --git a/t/op/re_tests b/t/op/re_tests index 29a6518cd9..b688a167f2 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -430,4 +430,7 @@ $(?<=^(a)) a y $1 a (?{$a=2})a*aa(?{local$a=$a+1})k*c(?{$b=$a}) yaaxxaaaacd y $b 3 (?{$a=2})(a(?{local$a=$a+1}))*aak*c(?{$b=$a}) yaaxxaaaacd y $b 4 (>a+)ab aaab n - - +(?>a+)b aaab y - - +((?>a+)b) aaab y $1 aaab +(?>(a+))b aaab y $1 aaa ((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x diff --git a/t/op/tiearray.t b/t/op/tiearray.t new file mode 100755 index 0000000000..8e78b2f76b --- /dev/null +++ b/t/op/tiearray.t @@ -0,0 +1,210 @@ +#!./perl + + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +my %seen; + +package Implement; + +sub TIEARRAY +{ + $seen{'TIEARRAY'}++; + my ($class,@val) = @_; + return bless \@val,$class; +} + +sub STORESIZE +{ + $seen{'STORESIZE'}++; + my ($ob,$sz) = @_; + return $#{$ob} = $sz-1; +} + +sub EXTEND +{ + $seen{'EXTEND'}++; + my ($ob,$sz) = @_; + return @$ob = $sz; +} + +sub FETCHSIZE +{ + $seen{'FETCHSIZE'}++; + return scalar(@{$_[0]}); +} + +sub FETCH +{ + $seen{'FETCH'}++; + my ($ob,$id) = @_; + return $ob->[$id]; +} + +sub STORE +{ + $seen{'STORE'}++; + my ($ob,$id,$val) = @_; + $ob->[$id] = $val; +} + +sub UNSHIFT +{ + $seen{'UNSHIFT'}++; + my $ob = shift; + unshift(@$ob,@_); +} + +sub PUSH +{ + $seen{'PUSH'}++; + my $ob = shift;; + push(@$ob,@_); +} + +sub CLEAR +{ + $seen{'CLEAR'}++; + @{$_[0]} = (); +} + +sub DESTROY +{ + $seen{'DESTROY'}++; +} + +sub POP +{ + $seen{'POP'}++; + my ($ob) = @_; + return pop(@$ob); +} + +sub SHIFT +{ + $seen{'SHIFT'}++; + my ($ob) = @_; + return shift(@$ob); +} + +sub SPLICE +{ + $seen{'SPLICE'}++; + my $ob = shift; + my $off = @_ ? shift : 0; + my $len = @_ ? shift : @$ob-1; + return splice(@$ob,$off,$len,@_); +} + +package main; + +print "1..31\n"; +my $test = 1; + +{my @ary; + +{ my $ob = tie @ary,'Implement',3,2,1; + print "not " unless $ob; + print "ok ", $test++,"\n"; + print "not " unless tied(@ary) == $ob; + print "ok ", $test++,"\n"; +} + + +print "not " unless @ary == 3; +print "ok ", $test++,"\n"; + +print "not " unless $#ary == 2; +print "ok ", $test++,"\n"; + +print "not " unless join(':',@ary) eq '3:2:1'; +print "ok ", $test++,"\n"; + +print "not " unless $seen{'FETCH'} >= 3; +print "ok ", $test++,"\n"; + +@ary = (1,2,3); + +print "not " unless $seen{'STORE'} >= 3; +print "ok ", $test++,"\n"; +print "not " unless join(':',@ary) eq '1:2:3'; +print "ok ", $test++,"\n"; + +{my @thing = @ary; +print "not " unless join(':',@thing) eq '1:2:3'; +print "ok ", $test++,"\n"; + +tie @thing,'Implement'; +@thing = @ary; +print "not " unless join(':',@thing) eq '1:2:3'; +print "ok ", $test++,"\n"; +} + +print "not " unless pop(@ary) == 3; +print "ok ", $test++,"\n"; +print "not " unless $seen{'POP'} == 1; +print "ok ", $test++,"\n"; +print "not " unless join(':',@ary) eq '1:2'; +print "ok ", $test++,"\n"; + +push(@ary,4); +print "not " unless $seen{'PUSH'} == 1; +print "ok ", $test++,"\n"; +print "not " unless join(':',@ary) eq '1:2:4'; +print "ok ", $test++,"\n"; + +my @x = splice(@ary,1,1,7); + + +print "not " unless $seen{'SPLICE'} == 1; +print "ok ", $test++,"\n"; + +print "not " unless @x == 1; +print "ok ", $test++,"\n"; +print "not " unless $x[0] == 2; +print "ok ", $test++,"\n"; +print "not " unless join(':',@ary) eq '1:7:4'; +print "ok ", $test++,"\n"; + +print "not " unless shift(@ary) == 1; +print "ok ", $test++,"\n"; +print "not " unless $seen{'SHIFT'} == 1; +print "ok ", $test++,"\n"; +print "not " unless join(':',@ary) eq '7:4'; +print "ok ", $test++,"\n"; + +my $n = unshift(@ary,5,6); +print "not " unless $seen{'UNSHIFT'} == 1; +print "ok ", $test++,"\n"; +print "not " unless $n == 4; +print "ok ", $test++,"\n"; +print "not " unless join(':',@ary) eq '5:6:7:4'; +print "ok ", $test++,"\n"; + +@ary = split(/:/,'1:2:3'); +print "not " unless join(':',@ary) eq '1:2:3'; +print "ok ", $test++,"\n"; + +my $t = 0; +foreach $n (@ary) + { + print "not " unless $n == ++$t; + print "ok ", $test++,"\n"; + } + +@ary = qw(3 2 1); +print "not " unless join(':',@ary) eq '3:2:1'; +print "ok ", $test++,"\n"; + +untie @ary; + +} + +print "not " unless $seen{'DESTROY'} == 2; +print "ok ", $test++,"\n"; + + + diff --git a/t/pragma/locale.t b/t/pragma/locale.t index 8e296db8a7..d068465fb3 100755 --- a/t/pragma/locale.t +++ b/t/pragma/locale.t @@ -283,13 +283,13 @@ locatelocale(\$Spanish, \@Spanish, # Select the largest of the alpha(num)bets. ($Locale, @Locale) = ($English, @English) - if (length(@English) > length(@Locale)); + if (@English > @Locale); ($Locale, @Locale) = ($German, @German) - if (length(@German) > length(@Locale)); + if (@German > @Locale); ($Locale, @Locale) = ($French, @French) - if (length(@French) > length(@Locale)); + if (@French > @Locale); ($Locale, @Locale) = ($Spanish, @Spanish) - if (length(@Spanish) > length(@Locale)); + if (@Spanish > @Locale); print "# Locale = $Locale\n"; print "# Alnum_ = @Locale\n"; @@ -1132,10 +1132,10 @@ filter_del(filter_t funcp) { if (filter_debug) warn("filter_del func %p", funcp); - if (!rsfp_filters || AvFILL(rsfp_filters)<0) + if (!rsfp_filters || AvFILLp(rsfp_filters)<0) return; /* if filter is on top of stack (usual case) just pop it off */ - if (IoDIRP(FILTER_DATA(AvFILL(rsfp_filters))) == (void*)funcp){ + if (IoDIRP(FILTER_DATA(AvFILLp(rsfp_filters))) == (void*)funcp){ sv_free(av_pop(rsfp_filters)); return; @@ -1157,7 +1157,7 @@ filter_read(int idx, SV *buf_sv, int maxlen) if (!rsfp_filters) return -1; - if (idx > AvFILL(rsfp_filters)){ /* Any more filters? */ + if (idx > AvFILLp(rsfp_filters)){ /* Any more filters? */ /* Provide a default input filter to make life easy. */ /* Note that we append to the line. This is handy. */ if (filter_debug) @@ -1515,7 +1515,7 @@ yylex(void) if (SvCUR(linestr)) sv_catpv(linestr,";"); if (preambleav){ - while(AvFILL(preambleav) >= 0) { + while(AvFILLp(preambleav) >= 0) { SV *tmpsv = av_shift(preambleav); sv_catsv(linestr, tmpsv); sv_catpv(linestr, ";"); diff --git a/universal.c b/universal.c index 5ccd731a70..18989aaf02 100644 --- a/universal.c +++ b/universal.c @@ -47,7 +47,8 @@ isa_lookup(HV *stash, char *name, int len, int level) } if(hv) { SV** svp = AvARRAY(av); - I32 items = AvFILL(av) + 1; + /* NOTE: No support for tied ISA */ + I32 items = AvFILLp(av) + 1; while (items--) { SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); @@ -14,6 +14,7 @@ #include "EXTERN.h" #include "perl.h" +#include "perlmem.h" #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include <signal.h> @@ -2013,7 +2014,7 @@ rsignal_restore(int signo, Sigsave_t *save) /* VMS' my_pclose() is in VMS.c; same with OS/2 */ #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) I32 -my_pclose(FILE *ptr) +my_pclose(PerlIO *ptr) { Sigsave_t hstat, istat, qstat; int status; @@ -2543,7 +2544,7 @@ new_struct_thread(struct perl_thread *t) /* Initialise all per-thread SVs that the template thread used */ svp = AvARRAY(t->threadsv); - for (i = 0; i <= AvFILL(t->threadsv); i++, svp++) { + for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) { if (*svp && *svp != &sv_undef) { SV *sv = newSVsv(*svp); av_store(thr->threadsv, i, sv); diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 3acb461f98..76385e2c18 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -64,6 +64,7 @@ $global_target = ""; $Is_VMS = $^O eq 'VMS'; $Is_MSWin32 = $^O eq 'MSWin32'; +$Is_Dos = $^O eq 'dos'; sub usage{ warn "@_\n" if @_; @@ -111,7 +112,7 @@ usage if $opt_h || $opt_h; # avoid -w warning if ($opt_t + $opt_u + $opt_m + $opt_l > 1) { usage("only one of -t, -u, -m or -l") -} elsif ($Is_MSWin32) { +} elsif ($Is_MSWin32 || $Is_Dos) { $opt_t = 1 unless $opt_t + $opt_u + $opt_m + $opt_l; } @@ -151,7 +152,7 @@ sub containspod { sub minus_f_nocase { my($file) = @_; # on a case-forgiving file system we can simply use -f $file - if ($Is_VMS or $Is_MSWin32 or $^O eq 'os2') { + if ($Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') { return $file if -f $file and -r _; warn "Ignored $file: unreadable\n" if -f _; return ''; @@ -224,7 +225,7 @@ sub searchfor { $ret = check_file "$dir/$s.com") or ( $^O eq 'os2' and $ret = check_file "$dir/$s.cmd") - or ( ($Is_MSWin32 or $^O eq 'os2') and + or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and $ret = check_file "$dir/$s.bat") or ( $ret = check_file "$dir/pod/$s.pod") or ( $ret = check_file "$dir/pod/$s") @@ -320,6 +321,11 @@ if ($Is_MSWin32) { } elsif ($Is_VMS) { $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$; push @pagers, qw( most more less type/page ); +} elsif ($Is_Dos) { + $tmp = "$ENV{TEMP}/perldoc1.$$"; + $tmp =~ tr!\\/!//!s; + push @pagers, qw( less.exe more.com< ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } else { if ($^O eq 'os2') { require POSIX; diff --git a/vms/config.vms b/vms/config.vms index 9aad64e493..9c31ace90c 100644 --- a/vms/config.vms +++ b/vms/config.vms @@ -76,7 +76,8 @@ * when Perl is built. Please do not change it by hand; make * any changes to FndVers.Com instead. */ -#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00454" /**/ +#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00456" /**/ + #define ARCHLIB ARCHLIB_EXP /*config-skip*/ @@ -373,6 +374,20 @@ */ #undef HAS_POLL /**/ +/* HAS_PTHREAD_YIELD: + * This symbol, if defined, indicates that the pthread_yield routine is + * available to yield the execution of the current thread. + * VMS: pthread_yield_np is there, but we won't worry for now since it's + * set up already as sched_yield. + */ +#undef HAS_PTHREAD_YIELD /**/ + +/* HAS_SCHED_YIELD: + * This symbol, if defined, indicates that the sched_yield routine is + * available to yield the execution of the current thread. + */ +#define HAS_SCHED_YIELD /**/ + /* HAS_READDIR: * This symbol, if defined, indicates that the readdir routine is * available to read directory entries. You may have to include @@ -1757,6 +1772,12 @@ */ #undef USE_SFIO /**/ +/* PTHREADS_CREATED_JOINABLE: + * This symbol, if defined, indicates that pthreads are created + * in the joinable (aka undetached) state. + */ +#define PTHREADS_CREATED_JOINABLE /**/ + /* Sigjmp_buf: * This is the buffer type to be used with Sigsetjmp and Siglongjmp. */ @@ -1871,6 +1892,41 @@ */ #define HAS_GETHOSTENT /**/ /* config-skip */ +/* HAS_GETHBADD: + * This symbol, if defined, indicates that the gethostbyaddr routine is + * available to lookup host names by their IP addresses. + */ +#define HAS_GETHBADD /**/ /* config-skip */ + +/* Gethbadd_addr_t: + * This symbol holds the type used for the 1st argument + * to gethostbyaddr(). + */ +#define Gethbadd_addr_t char * /**/ /* config-skip */ + +/* Gethbadd_alen_t: + * This symbol holds the type used for the 2nd argument + * to gethostbyaddr(). + */ +#define Gethbadd_alen_t int /**/ /* config-skip */ + +#ifdef DECCRTL_SOCKETS +/* HAS_GETNBADD: + * This symbol, if defined, indicates that the getnetbyaddr routine is + * available to lookup networks by their IP addresses. + */ +#define HAS_GETNBADD /**/ /* config-skip */ + +/* Gethbadd_net_t: + * This symbol holds the type used for the 1st argument + * to getnetbyaddr(). + */ +#define Getnbadd_net_t long /**/ /* config-skip */ +#else +#undef HAS_GETNBADD /**/ /* config-skip */ +#undef Getnbadd_net_t long /**/ /* config-skip */ +#endif + /* VMS: In general, TCP/IP header files should be included from * sockadapt.h, instead of here, in order to keep the TCP/IP code * together as much as possible. @@ -1881,6 +1937,12 @@ */ #undef I_NETINET_IN /**/ /* config-skip */ +/* I_NETDB: + * This symbol, if defined, indicates that <netdb.h> exists and + * should be included. + */ +#undef I_NETDB /**/ /* config-skip */ + /* I_NET_ERRNO: * This symbol, if defined, indicates that <net/errno.h> exists and * should be included. @@ -1900,8 +1962,11 @@ #undef HAS_SOCKETPAIR /**/ /* config-skip */ #undef HAS_GETHOSTENT /**/ /* config-skip */ #undef I_NETINET_IN /**/ /* config-skip */ +#undef I_NETDB /**/ /* config-skip */ #undef I_NET_ERRNO /**/ /* config-skip */ #undef HAS_SELECT /**/ /* config-skip */ +#undef HAS_GETHBADD /**/ /* config-skip */ +#undef HAS_GETNBADD /**/ /* config-skip */ #endif /* !VMS_DO_SOCKETS */ diff --git a/vms/descrip.mms b/vms/descrip.mms index f26e0b6bb0..adbcb1cc75 100644 --- a/vms/descrip.mms +++ b/vms/descrip.mms @@ -1,5 +1,5 @@ # Descrip.MMS for perl5 on VMS -# Last revised 20-Mar-1997 by Charles Bailey bailey@genetics.upenn.edu +# Last revised 23-Dec-1997 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 @@ -74,7 +74,7 @@ OBJVAL = $(MMS$TARGET_NAME)$(O) .endif # Updated by fndvers.com -- do not edit by hand -PERL_VERSION = 5_00454# +PERL_VERSION = 5_00456# .ifdef DECC_SOCKETS SOCKET=1 @@ -208,18 +208,15 @@ SOCKOBJ = SOCKPM = .endif -THREADH = THREAD = .ifdef THREADED THREADDEF = ,USE_THREADS,MULTIPLICITY -THREADH = thread.h THREAD = THREAD .endif .ifdef OLDTHREADED THREADDEF = ,USE_THREADS,MULTIPLICITY,OLD_PTHREADS_API -THREADH = thread.h THREAD = THREAD LIBS2 = sys$share:cma$lib_shr/share,cma$rtl/share .ifdef __AXP__ @@ -229,8 +226,12 @@ LIBS2 = $(LIBS2),sys$share:cma$open_lib_shr/share,cma$open_rtl/share .ifdef FAKETHREADED THREADDEF = ,USE_THREADS,MULTIPLICITY,FAKE_THREADS -THREADH = thread.h fakethr.h +THREADH = fakethr.h +acth = $(ARCHCORE)fakethr.h THREAD = THREAD +.else +THREADH = +acth = .endif # C preprocessor manifest "DEBUGGING" ==> perl -D, not the VMS debugger @@ -274,10 +275,11 @@ extobj = $(myextobj) h1 = EXTERN.h, INTERN.h, XSUB.h, av.h, config.h, cop.h, cv.h -h2 = embed.h, form.h, gv.h, handy.h, hv.h, keywords.h, mg.h, op.h +h2 = embed.h, form.h, gv.h, handy.h, hv.h, keywords.h, mg.h, op.h, thread.h 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, perlio.h, perlsdio.h -h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS) $(THREADH) +h5 = embedvar.h, intrpvar.h, perlvars.h, thrdvar.h +h = $(h1), $(h2), $(h3), $(h4), $(h5) $(SOCKHLIS) $(THREADH) c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c, universal.c, perlio.c c2 = perl.c, perly.c, pp.c, pp_hot.c, pp_ctl.c, pp_sys.c, regcomp.c, regexec.c @@ -295,11 +297,12 @@ 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 +ac5 = $(ARCHCORE)patchlevel.h $(ARCHCORE)perl.h $(ARCHCORE)perly.h $(ARCHCORE)thread.h ac6 = $(ARCHCORE)pp.h $(ARCHCORE)proto.h $(ARCHCORE)regcomp.h $(ARCHCORE)perlio.h $(ARCHCORE)perlsdio.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 +ac8 = $(ARCHCORE)embedvar.h $(ARCHCORE)intrpvar.h $(ARCHCORE)perlvars.h $(ARCHCORE)thrdvar.h +ac9 = $(ARCHCORE)vmsish.h $(ARCHCORE)$(DBG)libperl$(OLB) $(ARCHCORE)perlshr_attr.opt +ac10 = $(ARCHCORE)$(DBG)perlshr_bld.opt .ifdef SOCKET acs = $(ARCHCORE)$(SOCKH) .else @@ -365,7 +368,7 @@ pod8 = [.lib.pod]perltrap.pod [.lib.pod]perlvar.pod [.lib.pod]perlxs.pod [.lib.p perlpods : $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) [.lib.pod]perlvms.pod @ $(NOOP) -archcorefiles : $(ac1) $(ac2) $(ac3) $(ac4) $(ac5) $(ac6) $(ac7) $(ac8) $(ac9) $(acs) $(ARCHAUTO)time.stamp +archcorefiles : $(ac1) $(ac2) $(ac3) $(ac4) $(ac5) $(ac6) $(ac7) $(ac8) $(ac9) $(ac10) $(acs) $(acth) $(ARCHAUTO)time.stamp @ $(NOOP) miniperl : $(DBG)miniperl$(E) @@ -853,8 +856,6 @@ printconfig : .ifdef LINK_ONLY .else -$(SOCKOBJ) : $(SOCKC) $(SOCKH) - [.ext.Socket]Socket$(O) : [.ext.Socket]Socket.c $(CC) $(CFLAGS) /Object=$(MMS$TARGET) $(MMS$SOURCE) @@ -864,6 +865,8 @@ $(SOCKOBJ) : $(SOCKC) $(SOCKH) vmsish.h : $(SOCKH) +$(SOCKOBJ) : $(SOCKC) EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h + $(SOCKC) : [.vms]$(SOCKC) Copy/Log/NoConfirm [.vms]$(SOCKC) []$(SOCKC) @@ -958,6 +961,14 @@ $(ARCHCORE)cv.h : cv.h $(ARCHCORE)embed.h : embed.h @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) Copy/Log $(MMS$SOURCE) $(MMS$TARGET) +$(ARCHCORE)embedvar.h : embedvar.h + @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) + Copy/Log $(MMS$SOURCE) $(MMS$TARGET) +.ifdef FAKETHREADED +$(ARCHCORE)fakethr.h : fakethr.h + @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) + Copy/Log $(MMS$SOURCE) $(MMS$TARGET) +.endif $(ARCHCORE)form.h : form.h @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) Copy/Log $(MMS$SOURCE) $(MMS$TARGET) @@ -970,6 +981,9 @@ $(ARCHCORE)handy.h : handy.h $(ARCHCORE)hv.h : hv.h @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) Copy/Log $(MMS$SOURCE) $(MMS$TARGET) +$(ARCHCORE)intrpvar.h : intrpvar.h + @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) + Copy/Log $(MMS$SOURCE) $(MMS$TARGET) $(ARCHCORE)keywords.h : keywords.h @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) Copy/Log $(MMS$SOURCE) $(MMS$TARGET) @@ -994,6 +1008,9 @@ $(ARCHCORE)perlio.h : perlio.h $(ARCHCORE)perlsdio.h : perlsdio.h @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) Copy/Log $(MMS$SOURCE) $(MMS$TARGET) +$(ARCHCORE)perlvars.h : perlvars.h + @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) + Copy/Log $(MMS$SOURCE) $(MMS$TARGET) $(ARCHCORE)perly.h : perly.h @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) Copy/Log $(MMS$SOURCE) $(MMS$TARGET) @@ -1015,6 +1032,12 @@ $(ARCHCORE)scope.h : scope.h $(ARCHCORE)sv.h : sv.h @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) Copy/Log $(MMS$SOURCE) $(MMS$TARGET) +$(ARCHCORE)thrdvar.h : thrdvar.h + @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) + Copy/Log $(MMS$SOURCE) $(MMS$TARGET) +$(ARCHCORE)thread.h : thread.h + @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) + Copy/Log $(MMS$SOURCE) $(MMS$TARGET) $(ARCHCORE)util.h : util.h @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE) Copy/Log $(MMS$SOURCE) $(MMS$TARGET) @@ -1046,713 +1069,41 @@ $(ARCHAUTO)time.stamp : util$(O) : util.c $(CC) $(CFLAGS) util.c # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE -av$(O) : EXTERN.h -av$(O) : av.c -av$(O) : av.h -av$(O) : config.h -av$(O) : cop.h -av$(O) : cv.h -av$(O) : embed.h -av$(O) : form.h -av$(O) : gv.h -av$(O) : handy.h -av$(O) : hv.h -av$(O) : mg.h -av$(O) : op.h -av$(O) : opcode.h -av$(O) : perl.h -av$(O) : perly.h -av$(O) : pp.h -av$(O) : proto.h -av$(O) : regexp.h -av$(O) : scope.h -av$(O) : sv.h -av$(O) : vmsish.h -av$(O) : util.h -scope$(O) : EXTERN.h -scope$(O) : av.h -scope$(O) : config.h -scope$(O) : cop.h -scope$(O) : cv.h -scope$(O) : embed.h -scope$(O) : form.h -scope$(O) : gv.h -scope$(O) : handy.h -scope$(O) : hv.h -scope$(O) : mg.h -scope$(O) : op.h -scope$(O) : opcode.h -scope$(O) : perl.h -scope$(O) : perly.h -scope$(O) : pp.h -scope$(O) : proto.h -scope$(O) : regexp.h -scope$(O) : scope.c -scope$(O) : scope.h -scope$(O) : sv.h -scope$(O) : vmsish.h -scope$(O) : util.h -op$(O) : EXTERN.h -op$(O) : av.h -op$(O) : config.h -op$(O) : cop.h -op$(O) : cv.h -op$(O) : embed.h -op$(O) : form.h -op$(O) : gv.h -op$(O) : handy.h -op$(O) : hv.h -op$(O) : mg.h -op$(O) : op.c -op$(O) : op.h -op$(O) : opcode.h -op$(O) : perl.h -op$(O) : perly.h -op$(O) : pp.h -op$(O) : proto.h -op$(O) : regexp.h -op$(O) : scope.h -op$(O) : sv.h -op$(O) : vmsish.h -op$(O) : util.h -doop$(O) : EXTERN.h -doop$(O) : av.h -doop$(O) : config.h -doop$(O) : cop.h -doop$(O) : cv.h -doop$(O) : doop.c -doop$(O) : embed.h -doop$(O) : form.h -doop$(O) : gv.h -doop$(O) : handy.h -doop$(O) : hv.h -doop$(O) : mg.h -doop$(O) : op.h -doop$(O) : opcode.h -doop$(O) : perl.h -doop$(O) : perly.h -doop$(O) : pp.h -doop$(O) : proto.h -doop$(O) : regexp.h -doop$(O) : scope.h -doop$(O) : sv.h -doop$(O) : vmsish.h -doop$(O) : util.h -doio$(O) : EXTERN.h -doio$(O) : av.h -doio$(O) : config.h -doio$(O) : cop.h -doio$(O) : cv.h -doio$(O) : doio.c -doio$(O) : embed.h -doio$(O) : form.h -doio$(O) : gv.h -doio$(O) : handy.h -doio$(O) : hv.h -doio$(O) : mg.h -doio$(O) : op.h -doio$(O) : opcode.h -doio$(O) : perl.h -doio$(O) : perly.h -doio$(O) : pp.h -doio$(O) : proto.h -doio$(O) : regexp.h -doio$(O) : scope.h -doio$(O) : sv.h -doio$(O) : vmsish.h -doio$(O) : util.h -dump$(O) : EXTERN.h -dump$(O) : av.h -dump$(O) : config.h -dump$(O) : cop.h -dump$(O) : cv.h -dump$(O) : dump.c -dump$(O) : embed.h -dump$(O) : form.h -dump$(O) : gv.h -dump$(O) : handy.h -dump$(O) : hv.h -dump$(O) : mg.h -dump$(O) : op.h -dump$(O) : opcode.h -dump$(O) : perl.h -dump$(O) : perly.h -dump$(O) : pp.h -dump$(O) : proto.h -dump$(O) : regexp.h -dump$(O) : scope.h -dump$(O) : sv.h -dump$(O) : vmsish.h -dump$(O) : util.h -hv$(O) : EXTERN.h -hv$(O) : av.h -hv$(O) : config.h -hv$(O) : cop.h -hv$(O) : cv.h -hv$(O) : embed.h -hv$(O) : form.h -hv$(O) : gv.h -hv$(O) : handy.h -hv$(O) : hv.c -hv$(O) : hv.h -hv$(O) : mg.h -hv$(O) : op.h -hv$(O) : opcode.h -hv$(O) : perl.h -hv$(O) : perly.h -hv$(O) : pp.h -hv$(O) : proto.h -hv$(O) : regexp.h -hv$(O) : scope.h -hv$(O) : sv.h -hv$(O) : vmsish.h -hv$(O) : util.h -mg$(O) : EXTERN.h -mg$(O) : av.h -mg$(O) : config.h -mg$(O) : cop.h -mg$(O) : cv.h -mg$(O) : embed.h -mg$(O) : form.h -mg$(O) : gv.h -mg$(O) : handy.h -mg$(O) : hv.h -mg$(O) : mg.c -mg$(O) : mg.h -mg$(O) : op.h -mg$(O) : opcode.h -mg$(O) : perl.h -mg$(O) : perly.h -mg$(O) : pp.h -mg$(O) : proto.h -mg$(O) : regexp.h -mg$(O) : scope.h -mg$(O) : sv.h -mg$(O) : vmsish.h -mg$(O) : util.h -universal$(O) : EXTERN.h -universal$(O) : av.h -universal$(O) : config.h -universal$(O) : cop.h -universal$(O) : cv.h -universal$(O) : embed.h -universal$(O) : form.h -universal$(O) : gv.h -universal$(O) : handy.h -universal$(O) : hv.h -universal$(O) : mg.h -universal$(O) : op.h -universal$(O) : opcode.h -universal$(O) : perl.h -universal$(O) : perly.h -universal$(O) : pp.h -universal$(O) : proto.h -universal$(O) : regexp.h -universal$(O) : scope.h -universal$(O) : sv.h -universal$(O) : vmsish.h -universal$(O) : util.h -universal$(O) : universal.c -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) : perly.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 -perly$(O) : cop.h -perly$(O) : cv.h -perly$(O) : embed.h -perly$(O) : form.h -perly$(O) : gv.h -perly$(O) : handy.h -perly$(O) : hv.h -perly$(O) : mg.h -perly$(O) : op.h -perly$(O) : opcode.h -perly$(O) : perl.h -perly$(O) : perly.h -perly$(O) : perly.c -perly$(O) : pp.h -perly$(O) : proto.h -perly$(O) : regexp.h -perly$(O) : scope.h -perly$(O) : sv.h -perly$(O) : vmsish.h -perly$(O) : util.h -pp$(O) : EXTERN.h -pp$(O) : av.h -pp$(O) : config.h -pp$(O) : cop.h -pp$(O) : cv.h -pp$(O) : embed.h -pp$(O) : form.h -pp$(O) : gv.h -pp$(O) : handy.h -pp$(O) : hv.h -pp$(O) : mg.h -pp$(O) : op.h -pp$(O) : opcode.h -pp$(O) : perl.h -pp$(O) : perly.h -pp$(O) : pp.c -pp$(O) : pp.h -pp$(O) : proto.h -pp$(O) : regexp.h -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) : perly.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) : perly.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) : perly.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 -regcomp$(O) : config.h -regcomp$(O) : cop.h -regcomp$(O) : cv.h -regcomp$(O) : embed.h -regcomp$(O) : form.h -regcomp$(O) : gv.h -regcomp$(O) : handy.h -regcomp$(O) : hv.h -regcomp$(O) : mg.h -regcomp$(O) : op.h -regcomp$(O) : opcode.h -regcomp$(O) : perl.h -regcomp$(O) : perly.h -regcomp$(O) : pp.h -regcomp$(O) : proto.h -regcomp$(O) : regcomp.c -regcomp$(O) : regcomp.h -regcomp$(O) : regexp.h -regcomp$(O) : scope.h -regcomp$(O) : sv.h -regcomp$(O) : vmsish.h -regcomp$(O) : util.h -regexec$(O) : EXTERN.h -regexec$(O) : av.h -regexec$(O) : config.h -regexec$(O) : cop.h -regexec$(O) : cv.h -regexec$(O) : embed.h -regexec$(O) : form.h -regexec$(O) : gv.h -regexec$(O) : handy.h -regexec$(O) : hv.h -regexec$(O) : mg.h -regexec$(O) : op.h -regexec$(O) : opcode.h -regexec$(O) : perl.h -regexec$(O) : perly.h -regexec$(O) : pp.h -regexec$(O) : proto.h -regexec$(O) : regcomp.h -regexec$(O) : regexec.c -regexec$(O) : regexp.h -regexec$(O) : scope.h -regexec$(O) : sv.h -regexec$(O) : vmsish.h -regexec$(O) : util.h -gv$(O) : EXTERN.h -gv$(O) : av.h -gv$(O) : config.h -gv$(O) : cop.h -gv$(O) : cv.h -gv$(O) : embed.h -gv$(O) : form.h -gv$(O) : gv.c -gv$(O) : gv.h -gv$(O) : handy.h -gv$(O) : hv.h -gv$(O) : mg.h -gv$(O) : op.h -gv$(O) : opcode.h -gv$(O) : perl.h -gv$(O) : perly.h -gv$(O) : pp.h -gv$(O) : proto.h -gv$(O) : regexp.h -gv$(O) : scope.h -gv$(O) : sv.h -gv$(O) : vmsish.h -gv$(O) : util.h -sv$(O) : EXTERN.h -sv$(O) : av.h -sv$(O) : config.h -sv$(O) : cop.h -sv$(O) : cv.h -sv$(O) : embed.h -sv$(O) : form.h -sv$(O) : gv.h -sv$(O) : handy.h -sv$(O) : hv.h -sv$(O) : mg.h -sv$(O) : op.h -sv$(O) : opcode.h -sv$(O) : perl.h -sv$(O) : perly.h -sv$(O) : pp.h -sv$(O) : proto.h -sv$(O) : regexp.h -sv$(O) : scope.h -sv$(O) : sv.c -sv$(O) : sv.h -sv$(O) : vmsish.h -sv$(O) : util.h -taint$(O) : EXTERN.h -taint$(O) : av.h -taint$(O) : config.h -taint$(O) : cop.h -taint$(O) : cv.h -taint$(O) : embed.h -taint$(O) : form.h -taint$(O) : gv.h -taint$(O) : handy.h -taint$(O) : hv.h -taint$(O) : mg.h -taint$(O) : op.h -taint$(O) : opcode.h -taint$(O) : perl.h -taint$(O) : perly.h -taint$(O) : pp.h -taint$(O) : proto.h -taint$(O) : regexp.h -taint$(O) : scope.h -taint$(O) : sv.h -taint$(O) : taint.c -taint$(O) : vmsish.h -taint$(O) : util.h -toke$(O) : EXTERN.h -toke$(O) : av.h -toke$(O) : config.h -toke$(O) : cop.h -toke$(O) : cv.h -toke$(O) : embed.h -toke$(O) : form.h -toke$(O) : gv.h -toke$(O) : handy.h -toke$(O) : hv.h -toke$(O) : keywords.h -toke$(O) : mg.h -toke$(O) : op.h -toke$(O) : opcode.h -toke$(O) : perl.h -toke$(O) : perly.h -toke$(O) : pp.h -toke$(O) : proto.h -toke$(O) : regexp.h -toke$(O) : scope.h -toke$(O) : sv.h -toke$(O) : toke.c -toke$(O) : vmsish.h -toke$(O) : util.h -util$(O) : EXTERN.h -util$(O) : av.h -util$(O) : config.h -util$(O) : cop.h -util$(O) : cv.h -util$(O) : embed.h -util$(O) : form.h -util$(O) : gv.h -util$(O) : handy.h -util$(O) : hv.h -util$(O) : mg.h -util$(O) : op.h -util$(O) : opcode.h -util$(O) : perl.h -util$(O) : perly.h -util$(O) : pp.h -util$(O) : proto.h -util$(O) : regexp.h -util$(O) : scope.h -util$(O) : sv.h -util$(O) : vmsish.h -util$(O) : util.c -util$(O) : util.h -deb$(O) : EXTERN.h -deb$(O) : av.h -deb$(O) : config.h -deb$(O) : cop.h -deb$(O) : cv.h -deb$(O) : deb.c -deb$(O) : embed.h -deb$(O) : form.h -deb$(O) : gv.h -deb$(O) : handy.h -deb$(O) : hv.h -deb$(O) : mg.h -deb$(O) : op.h -deb$(O) : opcode.h -deb$(O) : perl.h -deb$(O) : perly.h -deb$(O) : pp.h -deb$(O) : proto.h -deb$(O) : regexp.h -deb$(O) : scope.h -deb$(O) : sv.h -deb$(O) : vmsish.h -deb$(O) : util.h -run$(O) : EXTERN.h -run$(O) : av.h -run$(O) : config.h -run$(O) : cop.h -run$(O) : cv.h -run$(O) : embed.h -run$(O) : form.h -run$(O) : gv.h -run$(O) : handy.h -run$(O) : hv.h -run$(O) : mg.h -run$(O) : op.h -run$(O) : opcode.h -run$(O) : perl.h -run$(O) : perly.h -run$(O) : pp.h -run$(O) : proto.h -run$(O) : regexp.h -run$(O) : run.c -run$(O) : scope.h -run$(O) : sv.h -run$(O) : vmsish.h -run$(O) : util.h -vms$(O) : EXTERN.h -vms$(O) : av.h -vms$(O) : config.h -vms$(O) : cop.h -vms$(O) : cv.h -vms$(O) : embed.h -vms$(O) : form.h -vms$(O) : gv.h -vms$(O) : handy.h -vms$(O) : hv.h -vms$(O) : mg.h -vms$(O) : op.h -vms$(O) : opcode.h -vms$(O) : perl.h -vms$(O) : perly.h -vms$(O) : pp.h -vms$(O) : proto.h -vms$(O) : regexp.h -vms$(O) : vms.c -vms$(O) : scope.h -vms$(O) : sv.h -vms$(O) : vmsish.h -vms$(O) : util.h -perlio$(O) : EXTERN.h -perlio$(O) : av.h -perlio$(O) : config.h -perlio$(O) : cop.h -perlio$(O) : cv.h -perlio$(O) : embed.h -perlio$(O) : form.h -perlio$(O) : gv.h -perlio$(O) : handy.h -perlio$(O) : hv.h -perlio$(O) : mg.h -perlio$(O) : op.h -perlio$(O) : opcode.h -perlio$(O) : perl.h -perlio$(O) : perly.h -perlio$(O) : pp.h -perlio$(O) : proto.h -perlio$(O) : regexp.h -perlio$(O) : perlio.c -perlio$(O) : scope.h -perlio$(O) : sv.h -perlio$(O) : vmsish.h -perlio$(O) : util.h -miniperlmain$(O) : EXTERN.h -miniperlmain$(O) : av.h -miniperlmain$(O) : config.h -miniperlmain$(O) : cop.h -miniperlmain$(O) : cv.h -miniperlmain$(O) : embed.h -miniperlmain$(O) : form.h -miniperlmain$(O) : gv.h -miniperlmain$(O) : handy.h -miniperlmain$(O) : hv.h -miniperlmain$(O) : mg.h -miniperlmain$(O) : miniperlmain.c -miniperlmain$(O) : op.h -miniperlmain$(O) : opcode.h -miniperlmain$(O) : perl.h -miniperlmain$(O) : perly.h -miniperlmain$(O) : pp.h -miniperlmain$(O) : proto.h -miniperlmain$(O) : regexp.h -miniperlmain$(O) : scope.h -miniperlmain$(O) : sv.h -miniperlmain$(O) : vmsish.h -miniperlmain$(O) : util.h -perlmain$(O) : EXTERN.h -perlmain$(O) : av.h -perlmain$(O) : config.h -perlmain$(O) : cop.h -perlmain$(O) : cv.h -perlmain$(O) : embed.h -perlmain$(O) : form.h -perlmain$(O) : gv.h -perlmain$(O) : handy.h -perlmain$(O) : hv.h -perlmain$(O) : mg.h -perlmain$(O) : op.h -perlmain$(O) : opcode.h -perlmain$(O) : perl.h -perlmain$(O) : perly.h -perlmain$(O) : perlmain.c -perlmain$(O) : pp.h -perlmain$(O) : proto.h -perlmain$(O) : regexp.h -perlmain$(O) : scope.h -perlmain$(O) : sv.h -perlmain$(O) : vmsish.h -perlmain$(O) : util.h -globals$(O) : INTERN.h -globals$(O) : av.h -globals$(O) : config.h -globals$(O) : cop.h -globals$(O) : cv.h -globals$(O) : embed.h -globals$(O) : form.h -globals$(O) : gv.h -globals$(O) : handy.h -globals$(O) : hv.h -globals$(O) : mg.h -globals$(O) : op.h -globals$(O) : opcode.h -globals$(O) : perl.h -globals$(O) : perly.h -globals$(O) : globals.c -globals$(O) : pp.h -globals$(O) : proto.h -globals$(O) : regexp.h -globals$(O) : scope.h -globals$(O) : sv.h -globals$(O) : vmsish.h -globals$(O) : util.h -[.x2p]a2p$(O) : [.x2p]a2p.c -[.x2p]a2p$(O) : [.x2p]a2py.c -[.x2p]a2p$(O) : [.x2p]INTERN.h -[.x2p]a2p$(O) : [.x2p]a2p.h -[.x2p]a2p$(O) : [.x2p]hash.h -[.x2p]a2p$(O) : [.x2p]str.h -[.x2p]a2p$(O) : handy.h -[.x2p]hash$(O) : [.x2p]hash.c -[.x2p]hash$(O) : [.x2p]EXTERN.h -[.x2p]hash$(O) : [.x2p]a2p.h -[.x2p]hash$(O) : [.x2p]hash.h -[.x2p]hash$(O) : [.x2p]str.h -[.x2p]hash$(O) : handy.h -[.x2p]hash$(O) : [.x2p]util.h -[.x2p]str$(O) : [.x2p]str.c -[.x2p]str$(O) : [.x2p]EXTERN.h -[.x2p]str$(O) : [.x2p]a2p.h -[.x2p]str$(O) : [.x2p]hash.h -[.x2p]str$(O) : [.x2p]str.h -[.x2p]str$(O) : handy.h -[.x2p]str$(O) : [.x2p]util.h -[.x2p]util$(O) : [.x2p]util.c -[.x2p]util$(O) : [.x2p]EXTERN.h -[.x2p]util$(O) : [.x2p]a2p.h -[.x2p]util$(O) : [.x2p]hash.h -[.x2p]util$(O) : [.x2p]str.h -[.x2p]util$(O) : handy.h -[.x2p]util$(O) : [.x2p]INTERN.h -[.x2p]util$(O) : [.x2p]util.h -[.x2p]walk$(O) : [.x2p]walk.c -[.x2p]walk$(O) : [.x2p]EXTERN.h -[.x2p]walk$(O) : [.x2p]a2p.h -[.x2p]walk$(O) : [.x2p]hash.h -[.x2p]walk$(O) : [.x2p]str.h -[.x2p]walk$(O) : handy.h -[.x2p]walk$(O) : [.x2p]util.h +av$(O) : av.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +deb$(O) : deb.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +doio$(O) : doio.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +doop$(O) : doop.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +dump$(O) : dump.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +globals$(O) : globals.c INTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +gv$(O) : gv.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +hv$(O) : hv.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +malloc$(O) : malloc.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +mg$(O) : mg.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +miniperlmain$(O) : miniperlmain.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +op$(O) : op.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +perl$(O) : perl.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h patchlevel.h +perlio$(O) : perlio.c config.h EXTERN.h perl.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +perlmain$(O) : perlmain.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +perly$(O) : perly.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +pp$(O) : pp.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +pp_ctl$(O) : pp_ctl.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +pp_hot$(O) : pp_hot.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +pp_sys$(O) : pp_sys.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +regcomp$(O) : regcomp.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h INTERN.h regcomp.h +regexec$(O) : regexec.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h regcomp.h +run$(O) : run.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +scope$(O) : scope.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +sv$(O) : sv.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +taint$(O) : taint.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +toke$(O) : toke.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h keywords.h +universal$(O) : universal.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h XSUB.h +util$(O) : util.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h +vms$(O) : vms.c EXTERN.h perl.h config.h embed.h perlio.h perlsdio.h handy.h vmsish.h regexp.h sv.h util.h form.h gv.h cv.h opcode.h op.h cop.h av.h hv.h mg.h scope.h perly.h thread.h pp.h proto.h embedvar.h perlvars.h thrdvar.h intrpvar.h XSUB.h +[.x2p]a2p$(O) : [.x2p]a2p.c [.x2p]a2py.c [.x2p]INTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h config.h handy.h +[.x2p]hash$(O) : [.x2p]hash.c [.x2p]EXTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h [.x2p]util.h config.h handy.h +[.x2p]str$(O) : [.x2p]str.c [.x2p]EXTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h [.x2p]util.h config.h handy.h +[.x2p]util$(O) : [.x2p]util.c [.x2p]EXTERN.h [.x2p]INTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h [.x2p]util.h config.h handy.h +[.x2p]walk$(O) : [.x2p]walk.c [.x2p]EXTERN.h [.x2p]a2p.h [.x2p]hash.h [.x2p]str.h [.x2p]util.h config.h handy.h .endif # !LINK_ONLY config.h : [.vms]config.vms diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl index 807ce59a90..0a8d7e60dc 100644 --- a/vms/gen_shrfls.pl +++ b/vms/gen_shrfls.pl @@ -39,7 +39,7 @@ require 5.000; $debug = $ENV{'GEN_SHRFLS_DEBUG'}; -print "gen_shrfls.pl Rev. 03-Nov-1997\n" if $debug; +print "gen_shrfls.pl Rev. 14-Dec-1997\n" if $debug; if ($ARGV[0] eq '-f') { open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n"; @@ -399,8 +399,6 @@ __END__ # Oddball cases, so we can keep the perl.h scan above simple rcsid=vars # declared in perl.c -regarglen=vars # declared in regcomp.h -regdummy=vars # declared in regcomp.h regkind=vars # declared in regcomp.h simple=vars # declared in regcomp.h varies=vars # declared in regcomp.h diff --git a/vms/genconfig.pl b/vms/genconfig.pl index 3b88be529b..d2da57262c 100644 --- a/vms/genconfig.pl +++ b/vms/genconfig.pl @@ -67,17 +67,17 @@ package='perl5' CONFIG='true' cf_time='$time' cf_by='$cf_by' -ccdlflags='' -cccdlflags='' -mab='' +ccdlflags='undef' +cccdlflags='undef' +mab='undef' libpth='/sys\$share /sys\$library' ld='Link' lddlflags='/Share' -ranlib='' -ar='' +ranlib='undef' +ar='undef' eunicefix=':' hint='none' -hintfile='' +hintfile='undef' useshrplib='define' usemymalloc='n' usevfork='true' @@ -167,12 +167,23 @@ foreach (@ARGV) { print OUT "d_sockpair=",$dosock ? "'define'\n" : "'undef'\n"; print OUT "d_gethent=",$dosock ? "'define'\n" : "'undef'\n"; print OUT "d_select=",$dosock ? "'define'\n" : "'undef'\n"; + print OUT "i_netdb=",$dosock ? "'define'\n" : "'undef'\n"; print OUT "i_niin=",$dosock ? "'define'\n" : "'undef'\n"; print OUT "i_neterrno=",$dosock ? "'define'\n" : "'undef'\n"; + print OUT "d_gethbadd=",$dosock ? "'define'\n" : "'undef'\n"; + print OUT "gethbadd_addr_type=",$dosock ? "'char *'\n" : "'undef'\n"; + print OUT "gethbadd_alen_type=",$dosock ? "'int'\n" : "'undef'\n"; + if ($dosock and $cctype eq 'decc' and $ccflags =~ /DECCRTL_SOCKETS/) { - print OUT "selecttype=fd_set\n"; + print OUT "selecttype='fd_set'\n"; + print OUT "d_getnbadd='define'\n"; + print OUT "getnbadd_net_type='long'\n"; + } + else { + print OUT "selecttype='int'\n"; + print OUT "d_getnbadd='undef'\n"; + print OUT "getnbadd_net_type='undef'\n"; } - else { print OUT "selecttype=int\n"; } if ($cctype eq 'decc') { $rtlhas = 'define'; print OUT "useposix='true'\n"; } else { $rtlhas = 'undef'; print OUT "useposix='false'\n"; } diff --git a/vms/perly_c.vms b/vms/perly_c.vms index 7514f16803..8495c4d955 100644 --- a/vms/perly_c.vms +++ b/vms/perly_c.vms @@ -1353,6 +1353,7 @@ yyparse(void) if (yyn >= '0' && yyn <= '9') yydebug = yyn - '0'; } + else SETERRNO(0,SS$_NORMAL); #endif yynerrs = 0; @@ -1019,6 +1019,14 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts) if (*(cp1+2) == '.') cp1++; if (*(cp1+2) == '/' || *(cp1+2) == '\0') { if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL; + if (strchr(vmsdir,'/') != NULL) { + /* If do_tovmsspec() returned it, it must have VMS syntax + * delimiters in it, so it's a mixed VMS/Unix spec. We take + * the time to check this here only so we avoid a recursion + * loop; otherwise, gigo. + */ + set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL; + } if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL; return do_tounixspec(trndir,buf,ts); } diff --git a/vms/vmsish.h b/vms/vmsish.h index c994140dab..cc08f39574 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -237,7 +237,7 @@ #endif #define BIT_BUCKET "_NLA0:" -#define PERL_SYS_INIT(c,v) vms_image_init((c),(v)), MALLOC_INIT +#define PERL_SYS_INIT(c,v) vms_image_init((c),(v)); MALLOC_INIT #define PERL_SYS_TERM() MALLOC_TERM #define dXSUB_SYS #define HAS_KILL diff --git a/win32/Makefile b/win32/Makefile index b5413bdf46..058099fe55 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -11,10 +11,10 @@ # newly built perl. INST_DRV=c: INST_TOP=$(INST_DRV)\perl5004.5x -BUILDOPT=-DUSE_THREADS -#BUILDOPT=-DMULTIPLICITY -#BUILDOPT=-DMULTIPLICITY -DUSE_THREADS -#BUILDOPT=-DPERL_GLOBAL_STRUCT -DMULTIPLICITY + +# +# uncomment to enable threads-capabilities +#USE_THREADS=-DUSE_THREADS # # uncomment next line if you are using Visual C++ 2.x @@ -59,6 +59,24 @@ D_CRYPT=define CRYPT_FLAG=-DHAVE_DES_FCRYPT !ENDIF +BUILDOPT = $(USE_THREADS) +#BUILDOPT = $(USE_THREADS) -DMULTIPLICITY +#BUILDOPT = $(USE_THREADS) -DPERL_GLOBAL_STRUCT -DMULTIPLICITY +# -DUSE_PERLIO -D__STDC__=1 -DUSE_SFIO -DI_SFIO -I\sfio97\include + +!IF "$(PROCESSOR_ARCHITECTURE)" == "" +PROCESSOR_ARCHITECTURE = x86 +!ENDIF + +!IF "$(USE_THREADS)" == "" +ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE) +!ELSE +ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-thread +!ENDIF + +ARCHDIR = ..\lib\$(ARCHNAME) +COREDIR = ..\lib\CORE + # # Programs to compile, build .lib files and link # @@ -129,12 +147,15 @@ o = .obj .SUFFIXES : .c $(o) .dll .lib .exe .c$(o): - $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $< + $(CC) -c -I$(<D) $(CFLAGS) $(OBJOUT_FLAG)$@ $< $(o).dll: $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \ -out:$@ $(LINK_FLAGS) $(LIBFILES) $< $(LIBPERL) +.y.c: + $(NOOP) + # INST_BIN=$(INST_TOP)\bin INST_LIB=$(INST_TOP)\lib @@ -154,6 +175,7 @@ PERLEXE=..\perl.exe GLOBEXE=..\perlglob.exe CONFIGPM=..\lib\Config.pm MINIMOD=..\lib\ExtUtils\Miniperl.pm +X2P=..\x2p\a2p.exe PL2BAT=bin\pl2bat.pl GLOBBAT = bin\perlglob.bat @@ -164,6 +186,7 @@ CFGH_TMPL = config_H.vc PERL95EXE=..\perl95.exe XCOPY=xcopy /f /r /i /d RCOPY=xcopy /f /r /i /e /d +NOOP=@echo NULL= !IF "$(CRYPT_SRC)" != "" @@ -249,6 +272,12 @@ PERL95_OBJ = perl95$(o) \ DLL_OBJ = perllib$(o) $(DYNALOADER)$(o) +X2P_OBJ = ..\x2p\a2p$(o) \ + ..\x2p\hash$(o) \ + ..\x2p\str$(o) \ + ..\x2p\util$(o) \ + ..\x2p\walk$(o) + CORE_H = ..\av.h \ ..\cop.h \ ..\cv.h \ @@ -325,7 +354,8 @@ POD2TEXT=$(PODDIR)\pod2text # Top targets # -all: $(PERLEXE) $(PERL95EXE) $(GLOBEXE) $(DYNALOADMODULES) $(MINIMOD) $(GLOBBAT) +all: $(PERLEXE) $(PERL95EXE) $(GLOBEXE) $(DYNALOADMODULES) $(MINIMOD) \ + $(X2P) $(DYNALOADER)$(o) : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c @@ -335,9 +365,6 @@ $(GLOBEXE): perlglob$(o) $(LINK32) $(LINK_FLAGS) $(LIBFILES) -out:$@ -subsystem:$(SUBSYS) \ perlglob$(o) setargv$(o) -$(GLOBBAT) : ..\lib\File\DosGlob.pm $(MINIPERL) - $(MINIPERL) $(PL2BAT) - < ..\lib\File\DosGlob.pm > $(GLOBBAT) - perlglob$(o) : perlglob.c ..\miniperlmain$(o) : ..\miniperlmain.c $(CORE_H) @@ -353,6 +380,7 @@ config.w32 : $(CFGSH_TMPL) $(MINIPERL) -I..\lib config_sh.PL \ "INST_DRV=$(INST_DRV)" \ "INST_TOP=$(INST_TOP)" \ + "archname=$(ARCHNAME)" \ "cc=$(CC)" \ "ccflags=$(OPTIMIZE) $(DEFINES)" \ "cf_email=$(EMAIL)" \ @@ -370,9 +398,9 @@ config.w32 : $(CFGSH_TMPL) $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl cd .. && miniperl configpm if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL) - $(XCOPY) ..\*.h ..\lib\CORE\*.* - $(XCOPY) *.h ..\lib\CORE\*.* - $(RCOPY) include ..\lib\CORE\*.* + $(XCOPY) ..\*.h $(COREDIR)\*.* + $(XCOPY) *.h $(COREDIR)\*.* + $(RCOPY) include $(COREDIR)\*.* $(MINIPERL) -I..\lib config_h.PL || $(MAKE) CCTYPE=$(CCTYPE) \ RUNTIME=$(RUNTIME) CFG=$(CFG) $(CONFIGPM) @@ -385,6 +413,7 @@ $(WIN32_OBJ) : $(CORE_H) $(CORE_OBJ) : $(CORE_H) $(DLL_OBJ) : $(CORE_H) $(PERL95_OBJ) : $(CORE_H) +$(X2P_OBJ) : $(CORE_H) perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym makedef.pl $(MINIPERL) -w makedef.pl $(OPTIMIZE) $(DEFINES) \ @@ -394,7 +423,7 @@ $(PERLDLL): perldll.def $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ) $(LINK32) -dll -def:perldll.def -out:$@ @<< $(LINK_FLAGS) $(LIBFILES) $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ) << - $(XCOPY) $(PERLIMPLIB) ..\lib\CORE + $(XCOPY) $(PERLIMPLIB) $(COREDIR) perl.def : $(MINIPERL) makeperldef.pl $(MINIPERL) -I..\lib makeperldef.pl $(NULL) > perl.def @@ -402,6 +431,11 @@ perl.def : $(MINIPERL) makeperldef.pl $(MINIMOD) : $(MINIPERL) ..\minimod.pl cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm +$(X2P) : $(X2P_OBJ) + $(LINK32) -subsystem:console -out:$@ @<< + $(LINK_FLAGS) $(LIBFILES) $(X2P_OBJ) +<< + perlmain.c : runperl.c copy runperl.c perlmain.c @@ -494,19 +528,19 @@ doc: $(PERLEXE) $(XCOPY) *.bat ..\win32\bin\*.* cd ..\win32 copy ..\README.win32 ..\pod\perlwin32.pod - $(PERLEXE) ..\installhtml --podroot=.. --htmldir=./html \ + $(PERLEXE) -I..\lib ..\installhtml --podroot=.. --htmldir=./html \ --podpath=pod:lib:ext:utils --htmlroot="//$(INST_HTML::=|)" \ --libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse utils: $(PERLEXE) cd ..\utils nmake PERL=$(MINIPERL) - $(PERLEXE) ..\win32\$(PL2BAT) h2ph splain perlbug pl2pm c2ph + $(PERLEXE) -I..\lib ..\win32\$(PL2BAT) h2ph splain perlbug pl2pm c2ph $(PERLEXE) ..\win32\$(PL2BAT) h2xs perldoc pstruct $(XCOPY) *.bat ..\win32\bin\*.* cd ..\win32 $(PERLEXE) $(PL2BAT) bin\network.pl bin\www.pl bin\runperl.pl \ - bin\pl2bat.pl + bin\pl2bat.pl bin\perlglob.pl distclean: clean -del /f $(MINIPERL) $(PERLEXE) $(PERL95EXE) $(PERLDLL) $(GLOBEXE) \ @@ -521,23 +555,18 @@ distclean: clean -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c \ config.h.new perl95.c -del /f bin\*.bat - -rmdir /s /q ..\lib\auto - -rmdir /s /q ..\lib\CORE + -rmdir /s /q ..\lib\auto || rmdir /s ..\lib\auto + -rmdir /s /q $(COREDIR) || rmdir /s $(COREDIR) cd $(EXTDIR) -del /s *.lib *.def *.map *.bs Makefile *$(o) pm_to_blib cd ..\win32 install : all doc utils - if not exist $(INST_TOP) mkdir $(INST_TOP) - echo I $(INST_TOP) L $(LIBDIR) - $(XCOPY) $(PERLEXE) $(INST_BIN)\*.* + $(PERLEXE) ..\installperl $(XCOPY) $(PERL95EXE) $(INST_BIN)\*.* $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.* - $(XCOPY) $(PERLDLL) $(INST_BIN)\*.* $(XCOPY) bin\*.bat $(INST_BIN)\*.* - $(RCOPY) ..\lib $(INST_LIB)\*.* $(XCOPY) ..\pod\*.bat $(INST_BIN)\*.* - $(XCOPY) ..\pod\*.pod $(INST_POD)\*.* $(RCOPY) html\*.* $(INST_HTML)\*.* inst_lib : $(CONFIGPM) @@ -545,7 +574,7 @@ inst_lib : $(CONFIGPM) $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto" $(RCOPY) ..\lib $(INST_LIB)\*.* -minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) +minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) utils $(XCOPY) $(MINIPERL) ..\t\perl.exe $(XCOPY) $(GLOBEXE) ..\t\$(NULL) attrib -r ..\t\*.* @@ -554,7 +583,7 @@ minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) $(MINIPERL) -I..\lib test base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t cd ..\win32 -test-prep : all +test-prep : all utils $(XCOPY) $(PERLEXE) ..\t\$(NULL) $(XCOPY) $(PERLDLL) ..\t\$(NULL) $(XCOPY) $(GLOBEXE) ..\t\$(NULL) @@ -583,8 +612,10 @@ clean : -@erase $(CORE_OBJ) -@erase $(WIN32_OBJ) -@erase $(DLL_OBJ) + -@erase $(X2P_OBJ) -@erase ..\*$(o) ..\*.lib ..\*.exp *$(o) *.lib *.exp -@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat + -@erase ..\x2p\*.exe ..\x2p\*.bat -@erase *.ilk -@erase *.pdb diff --git a/win32/bin/perlglob.pl b/win32/bin/perlglob.pl new file mode 100644 index 0000000000..6467e573b5 --- /dev/null +++ b/win32/bin/perlglob.pl @@ -0,0 +1,53 @@ +#!perl -w +use File::DosGlob; +$| = 1; +while (@ARGV) { + my $arg = shift; + my @m = File::DosGlob::doglob(1,$arg); + print (@m ? join("\0", sort @m) : $arg); + print "\0" if @ARGV; +} +__END__ + +=head1 NAME + +perlglob.bat - a more capable perlglob.exe replacement + +=head1 SYNOPSIS + + @perlfiles = glob "..\\pe?l/*.p?"; + print <..\\pe?l/*.p?>; + + # more efficient version + > perl -MFile::DosGlob=glob -e "print <../pe?l/*.p?>" + +=head1 DESCRIPTION + +This file is a portable replacement for perlglob.exe. It +is largely compatible with perlglob.exe (the Microsoft setargv.obj +version) in all but one respect--it understands wildcards in +directory components. + +It prints null-separated filenames to standard output. + +For details of the globbing features implemented, see +L<File::DosGlob>. + +While one may replace perlglob.exe with this, usage by overriding +CORE::glob with File::DosGlob::glob should be much more efficient, +because it avoids launching a separate process, and is therefore +strongly recommended. See L<perlsub> for details of overriding +builtins. + +=head1 AUTHOR + +Gurusamy Sarathy <gsar@umich.edu> + +=head1 SEE ALSO + +perl + +File::DosGlob + +=cut + diff --git a/win32/config.bc b/win32/config.bc index 97cee6a476..b656184872 100644 --- a/win32/config.bc +++ b/win32/config.bc @@ -357,7 +357,7 @@ installbin='~INST_TOP~\bin' installman1dir='~INST_TOP~\man\man1' installman3dir='~INST_TOP~\man\man3' installscript='~INST_TOP~\bin' -installsitearch='~INST_TOP~\lib\site' +installsitearch='~INST_TOP~\lib\site\~archname~' installsitelib='~INST_TOP~\lib\site' intsize='4' known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket IO attrs Thread' @@ -369,6 +369,7 @@ ldflags='' less='less' lib_ext='.lib' libc='cw32mti.lib' +libperl='perl.lib' libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x' line='line' lint='' @@ -450,8 +451,8 @@ shortsize='2' shrpdir='none' sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 6 18 22' signal_t='void' -sitearch='~INST_TOP~\lib\site' -sitearchexp='~INST_TOP~\lib\site' +sitearch='~INST_TOP~\lib\site\~archname~' +sitearchexp='~INST_TOP~\lib\site\~archname~' sitelib='~INST_TOP~\lib\site' sitelibexp='~INST_TOP~\lib\site' sizetype='size_t' diff --git a/win32/config.gc b/win32/config.gc index 3c9acbeda6..d32c1e91b8 100644 --- a/win32/config.gc +++ b/win32/config.gc @@ -5,7 +5,7 @@ ## Target system: WIN32 # -archlibexp='~INST_TOP~\lib' +archlibexp='~INST_TOP~\lib\~archname~' archname='MSWin32' cc='gcc' ccflags='-DWIN32' @@ -13,7 +13,7 @@ cppflags='-DWIN32' dlsrc='dl_win32.xs' dynamic_ext='Socket IO Fcntl Opcode SDBM_File attrs Thread' extensions='~static_ext~ ~dynamic_ext~' -installarchlib='~INST_TOP~\lib' +installarchlib='~INST_TOP~\lib\~archname~' installprivlib='~INST_TOP~\lib' libpth='' libs=' ' @@ -46,7 +46,7 @@ afs='false' alignbytes='8' aphostname='' ar='ar' -archlib='~INST_TOP~\lib' +archlib='~INST_TOP~\lib\~archname~' archobjs='' awk='awk' baserev='5.0' @@ -357,7 +357,7 @@ installbin='~INST_TOP~\bin' installman1dir='~INST_TOP~\man\man1' installman3dir='~INST_TOP~\man\man3' installscript='~INST_TOP~\bin' -installsitearch='~INST_TOP~\lib\site' +installsitearch='~INST_TOP~\lib\site\~archname~' installsitelib='~INST_TOP~\lib\site' intsize='4' known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket IO attrs Thread' @@ -369,6 +369,7 @@ ldflags='' less='less' lib_ext='.lib' libc='msvcrt.lib' +libperl='libperl.a' libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x' line='line' lint='' @@ -450,8 +451,8 @@ shortsize='2' shrpdir='none' sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 6 18 22' signal_t='void' -sitearch='~INST_TOP~\lib\site' -sitearchexp='~INST_TOP~\lib\site' +sitearch='~INST_TOP~\lib\site\~archname~' +sitearchexp='~INST_TOP~\lib\site\~archname~' sitelib='~INST_TOP~\lib\site' sitelibexp='~INST_TOP~\lib\site' sizetype='size_t' diff --git a/win32/config.vc b/win32/config.vc index 09573225fb..a1b5bc34a0 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -5,7 +5,7 @@ ## Target system: WIN32 # -archlibexp='~INST_TOP~\lib' +archlibexp='~INST_TOP~\lib\~archname~' archname='MSWin32' cc='cl' ccflags='-MD -DWIN32' @@ -13,7 +13,7 @@ cppflags='-DWIN32' dlsrc='dl_win32.xs' dynamic_ext='Socket IO Fcntl Opcode SDBM_File attrs Thread' extensions='~static_ext~ ~dynamic_ext~' -installarchlib='~INST_TOP~\lib' +installarchlib='~INST_TOP~\lib\~archname~' installprivlib='~INST_TOP~\lib' libpth='' libs='' @@ -46,7 +46,7 @@ afs='false' alignbytes='8' aphostname='' ar='lib' -archlib='~INST_TOP~\lib' +archlib='~INST_TOP~\lib\~archname~' archobjs='' awk='awk' baserev='5.0' @@ -357,7 +357,7 @@ installbin='~INST_TOP~\bin' installman1dir='~INST_TOP~\man\man1' installman3dir='~INST_TOP~\man\man3' installscript='~INST_TOP~\bin' -installsitearch='~INST_TOP~\lib\site' +installsitearch='~INST_TOP~\lib\site\~archname~' installsitelib='~INST_TOP~\lib\site' intsize='4' known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket IO attrs Thread' @@ -369,6 +369,7 @@ ldflags='-nologo -subsystem:windows' less='less' lib_ext='.lib' libc='msvcrt.lib' +libperl='perl.lib' libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x' line='line' lint='' @@ -450,8 +451,8 @@ shortsize='2' shrpdir='none' sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 6 18 22' signal_t='void' -sitearch='~INST_TOP~\lib\site' -sitearchexp='~INST_TOP~\lib\site' +sitearch='~INST_TOP~\lib\site\~archname~' +sitearchexp='~INST_TOP~\lib\site\~archname~' sitelib='~INST_TOP~\lib\site' sitelibexp='~INST_TOP~\lib\site' sizetype='size_t' diff --git a/win32/config_sh.PL b/win32/config_sh.PL index 5f3f157a0c..0c3713cb2e 100644 --- a/win32/config_sh.PL +++ b/win32/config_sh.PL @@ -5,17 +5,6 @@ while (@ARGV && $ARGV[0] =~ /^([\w_]+)=(.*)$/) shift(@ARGV); } -$opt{'archname'} = 'MSWin32'; -if (defined $ENV{'PROCESSOR_ARCHITECTURE'}) - { - $opt{'archname'} .= '-'.$ENV{'PROCESSOR_ARCHITECTURE'}; - } - -if ($opt{'ccflags'} =~ /USE_THREADS/) - { - $opt{'archname'} .= '-thread'; - } - if ($] =~ /\.(\d\d\d)?(\d\d)?$/) { # should always be true $opt{PATCHLEVEL} = int($1 || 0); $opt{SUBVERSION} = $2 || '00'; diff --git a/win32/makefile.mk b/win32/makefile.mk index 916d73c526..245d904439 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -16,13 +16,8 @@ INST_DRV *= c: INST_TOP *= $(INST_DRV)\perl5004.5x # -# -BUILDOPT *= -DUSE_THREADS -#BUILDOPT *= -DMULTIPLICITY -#BUILDOPT *=-DMULTIPLICITY -DUSE_THREADS -#BUILDOPT *=-DPERL_GLOBAL_STRUCT -DMULTIPLICITY - -# -DUSE_PERLIO -D__STDC__=1 -DUSE_SFIO -DI_SFIO -I\sfio97\include +# uncomment to enable threads-capabilities +#USE_THREADS *= -DUSE_THREADS # # uncomment one @@ -72,6 +67,24 @@ D_CRYPT=define CRYPT_FLAG=-DHAVE_DES_FCRYPT .ENDIF +BUILDOPT *= $(USE_THREADS) +#BUILDOPT *= $(USE_THREADS) -DMULTIPLICITY +#BUILDOPT *= $(USE_THREADS) -DPERL_GLOBAL_STRUCT -DMULTIPLICITY +# -DUSE_PERLIO -D__STDC__=1 -DUSE_SFIO -DI_SFIO -I\sfio97\include + +.IMPORT .IGNORE : PROCESSOR_ARCHITECTURE + +PROCESSOR_ARCHITECTURE *= x86 + +.IF "$(USE_THREADS)" == "" +ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE) +.ELSE +ARCHNAME = MSWin32-$(PROCESSOR_ARCHITECTURE)-thread +.ENDIF + +ARCHDIR = ..\lib\$(ARCHNAME) +COREDIR = ..\lib\CORE + # # Programs to compile, build .lib files and link # @@ -189,10 +202,6 @@ OPTIMIZE = -Od $(RUNTIME) -DNDEBUG LINK_DBG = -release .ENDIF -.IMPORT .IGNORE : PROCESSOR_ARCHITECTURE - -PROCESSOR_ARCHITECTURE *= x86 - # we don't add LIBC here, the compiler do it based on -MD/-MT LIBFILES = $(CRYPT_LIB) oldnames.lib kernel32.lib user32.lib gdi32.lib \ winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib \ @@ -218,7 +227,10 @@ o *= .obj .SUFFIXES : .c $(o) .dll .lib .exe .a .c$(o): - $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $< + $(CC) -c -I$(<:d) $(CFLAGS) $(OBJOUT_FLAG)$@ $< + +.y.c: + $(NOOP) $(o).dll: .IF "$(CCTYPE)" == "BORLAND" @@ -251,6 +263,7 @@ PERLEXE=..\perl.exe GLOBEXE=..\perlglob.exe CONFIGPM=..\lib\Config.pm MINIMOD=..\lib\ExtUtils\Miniperl.pm +X2P=..\x2p\a2p.exe PL2BAT=bin\pl2bat.pl GLOBBAT = bin\perlglob.bat @@ -276,6 +289,7 @@ PERL95EXE=..\perl95.exe XCOPY=xcopy /f /r /i /d RCOPY=xcopy /f /r /i /e /d +NOOP=@echo #NULL= .IF "$(CRYPT_SRC)" != "" @@ -361,6 +375,12 @@ PERL95_OBJ = perl95$(o) \ DLL_OBJ = perllib$(o) $(DYNALOADER)$(o) +X2P_OBJ = ..\x2p\a2p$(o) \ + ..\x2p\hash$(o) \ + ..\x2p\str$(o) \ + ..\x2p\util$(o) \ + ..\x2p\walk$(o) + CORE_H = ..\av.h \ ..\cop.h \ ..\cv.h \ @@ -437,7 +457,8 @@ POD2TEXT=$(PODDIR)\pod2text # Top targets # -all: $(PERLEXE) $(PERL95EXE) $(GLOBEXE) $(DYNALOADMODULES) $(MINIMOD) $(GLOBBAT) +all: $(PERLEXE) $(PERL95EXE) $(GLOBEXE) $(DYNALOADMODULES) $(MINIMOD) \ + $(X2P) $(DYNALOADER)$(o) : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c @@ -455,9 +476,6 @@ $(GLOBEXE): perlglob$(o) perlglob$(o) setargv$(o) .ENDIF -$(GLOBBAT) : ..\lib\File\DosGlob.pm $(MINIPERL) - $(MINIPERL) $(PL2BAT) - < ..\lib\File\DosGlob.pm > $(GLOBBAT) - perlglob$(o) : perlglob.c ..\miniperlmain$(o) : ..\miniperlmain.c $(CORE_H) @@ -473,6 +491,7 @@ config.w32 : $(CFGSH_TMPL) $(MINIPERL) -I..\lib config_sh.PL \ "INST_DRV=$(INST_DRV)" \ "INST_TOP=$(INST_TOP)" \ + "archname=$(ARCHNAME)" \ "cc=$(CC)" \ "ccflags=$(OPTIMIZE) $(DEFINES)" \ "cf_email=$(EMAIL)" \ @@ -490,9 +509,9 @@ config.w32 : $(CFGSH_TMPL) $(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl cd .. && miniperl configpm if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL) - $(XCOPY) ..\*.h ..\lib\CORE\*.* - $(XCOPY) *.h ..\lib\CORE\*.* - $(RCOPY) include ..\lib\CORE\*.* + $(XCOPY) ..\*.h $(COREDIR)\*.* + $(XCOPY) *.h $(COREDIR)\*.* + $(RCOPY) include $(COREDIR)\*.* $(MINIPERL) -I..\lib config_h.PL || $(MAKE) CCTYPE=$(CCTYPE) \ CFG=$(CFG) $(CONFIGPM) @@ -503,7 +522,7 @@ $(MINIPERL) : ..\miniperlmain$(o) $(CORE_OBJ) $(WIN32_OBJ) .IF "$(CCTYPE)" == "BORLAND" $(LINK32) -Tpe -ap $(LINK_FLAGS) \ @$(mktmp c0x32$(o) ..\miniperlmain$(o) \ - $(CORE_OBJ:s,\,\\) $(WIN32_OBJ:s,\,\\),$@,,$(LIBFILES),) + $(CORE_OBJ:s,\,\\) $(WIN32_OBJ:s,\,\\),$(@:s,\,\\),,$(LIBFILES),) .ELIF "$(CCTYPE)" == "GCC" $(LINK32) -v -o $@ $(LINK_FLAGS) \ $(mktmp $(LKPRE) ..\miniperlmain$(o) \ @@ -517,6 +536,7 @@ $(MINIPERL) : ..\miniperlmain$(o) $(CORE_OBJ) $(WIN32_OBJ) $(WIN32_OBJ) : $(CORE_H) $(CORE_OBJ) : $(CORE_H) $(DLL_OBJ) : $(CORE_H) +$(X2P_OBJ) : $(CORE_H) perldll.def : $(MINIPERL) $(CONFIGPM) ..\global.sym makedef.pl $(MINIPERL) -w makedef.pl $(OPTIMIZE) $(DEFINES) \ @@ -548,7 +568,7 @@ $(PERLDLL): perldll.def $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ) @$(mktmp $(LINK_FLAGS) $(LIBFILES) $(CORE_OBJ:s,\,\\) \ $(WIN32_OBJ:s,\,\\) $(DLL_OBJ:s,\,\\)) .ENDIF - $(XCOPY) $(PERLIMPLIB) ..\lib\CORE + $(XCOPY) $(PERLIMPLIB) $(COREDIR) perl.def : $(MINIPERL) makeperldef.pl $(MINIPERL) -I..\lib makeperldef.pl $(NULL) > perl.def @@ -556,6 +576,20 @@ perl.def : $(MINIPERL) makeperldef.pl $(MINIMOD) : $(MINIPERL) ..\minimod.pl cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm +$(X2P) : $(X2P_OBJ) + $(MINIPERL) ..\x2p\find2perl.PL + $(MINIPERL) ..\x2p\s2p.PL +.IF "$(CCTYPE)" == "BORLAND" + $(LINK32) -Tpe -ap $(LINK_FLAGS) \ + @$(mktmp c0x32$(o) $(X2P_OBJ:s,\,\\),$(@:s,\,\\),,$(LIBFILES),) +.ELIF "$(CCTYPE)" == "GCC" + $(LINK32) -v -o $@ $(LINK_FLAGS) \ + $(mktmp $(LKPRE) $(X2P_OBJ:s,\,\\) $(LIBFILES) $(LKPOST)) +.ELSE + $(LINK32) -subsystem:console -out:$@ \ + @$(mktmp $(LINK_FLAGS) $(LIBFILES) $(X2P_OBJ:s,\,\\) +.ENDIF + perlmain.c : runperl.c copy runperl.c perlmain.c @@ -649,7 +683,7 @@ doc: $(PERLEXE) pod2html pod2latex pod2man pod2text cd ..\pod && $(XCOPY) *.bat ..\win32\bin\*.* copy ..\README.win32 ..\pod\perlwin32.pod - $(PERLEXE) ..\installhtml --podroot=.. --htmldir=./html \ + $(PERLEXE) -I..\lib ..\installhtml --podroot=.. --htmldir=./html \ --podpath=pod:lib:ext:utils --htmlroot="//$(INST_HTML:s,:,|,)" \ --libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse @@ -658,8 +692,8 @@ utils: $(PERLEXE) cd ..\utils && $(PERLEXE) ..\win32\$(PL2BAT) h2ph splain perlbug \ pl2pm c2ph h2xs perldoc pstruct $(XCOPY) ..\utils\*.bat bin\*.* - $(PERLEXE) $(PL2BAT) bin\network.pl bin\www.pl bin\runperl.pl \ - bin\pl2bat.pl + $(PERLEXE) -I..\lib $(PL2BAT) bin\network.pl bin\www.pl bin\runperl.pl \ + bin\pl2bat.pl bin\perlglob.pl distclean: clean -del /f $(MINIPERL) $(PERLEXE) $(PERL95EXE) $(PERLDLL) $(GLOBEXE) \ @@ -677,22 +711,17 @@ distclean: clean .ENDIF -del /f bin\*.bat -cd $(EXTDIR) && del /s *.lib *.def *.map *.bs Makefile *$(o) pm_to_blib - -rmdir /s /q ..\lib\auto - -rmdir /s /q ..\lib\CORE + -rmdir /s /q ..\lib\auto || rmdir /s ..\lib\auto + -rmdir /s /q $(COREDIR) || rmdir /s $(COREDIR) install : all doc utils - if not exist $(INST_TOP) mkdir $(INST_TOP) - echo I $(INST_TOP) L $(LIBDIR) - $(XCOPY) $(PERLEXE) $(INST_BIN)\*.* + $(PERLEXE) ..\installperl .IF "$(PERL95EXE)" != "" $(XCOPY) $(PERL95EXE) $(INST_BIN)\*.* .ENDIF $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.* - $(XCOPY) $(PERLDLL) $(INST_BIN)\*.* $(XCOPY) bin\*.bat $(INST_BIN)\*.* - $(RCOPY) ..\lib $(INST_LIB)\*.* $(XCOPY) ..\pod\*.bat $(INST_BIN)\*.* - $(XCOPY) ..\pod\*.pod $(INST_POD)\*.* $(RCOPY) html\*.* $(INST_HTML)\*.* inst_lib : $(CONFIGPM) @@ -700,7 +729,7 @@ inst_lib : $(CONFIGPM) $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto" $(RCOPY) ..\lib $(INST_LIB)\*.* -minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) +minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) utils $(XCOPY) $(MINIPERL) ..\t\perl.exe .IF "$(CCTYPE)" == "BORLAND" $(XCOPY) $(GLOBBAT) ..\t\$(NULL) @@ -712,7 +741,7 @@ minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM) cd ..\t && \ $(MINIPERL) -I..\lib test base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t -test-prep : all +test-prep : all utils $(XCOPY) $(PERLEXE) ..\t\$(NULL) $(XCOPY) $(PERLDLL) ..\t\$(NULL) .IF "$(CCTYPE)" == "BORLAND" @@ -741,8 +770,10 @@ clean : -@erase $(CORE_OBJ) -@erase $(WIN32_OBJ) -@erase $(DLL_OBJ) + -@erase $(X2P_OBJ) -@erase ..\*$(o) ..\*.lib ..\*.exp *$(o) *.lib *.exp -@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat + -@erase ..\x2p\*.exe ..\x2p\*.bat -@erase *.ilk -@erase *.pdb diff --git a/win32/win32.h b/win32/win32.h index 5a7c89bf97..8d6b04197d 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -109,15 +109,15 @@ struct tms { #define DllMain DllEntryPoint #endif -#pragma warn -ccc -#pragma warn -rch -#pragma warn -sig -#pragma warn -pia -#pragma warn -par -#pragma warn -aus -#pragma warn -use -#pragma warn -csu -#pragma warn -pro +#pragma warn -ccc /* "condition is always true/false" */ +#pragma warn -rch /* "unreachable code" */ +#pragma warn -sig /* "conversion may lose significant digits" */ +#pragma warn -pia /* "possibly incorrect assignment" */ +#pragma warn -par /* "parameter 'foo' is never used" */ +#pragma warn -aus /* "'foo' is assigned a value that is never used" */ +#pragma warn -use /* "'foo' is declared but never used" */ +#pragma warn -csu /* "comparing signed and unsigned values" */ +#pragma warn -pro /* "call to function with no prototype" */ #endif @@ -9,12 +9,37 @@ */ #define VOIDUSED 1 + +#ifdef WIN32 +#define _INC_WIN32_PERL5 /* kludge around win32 stdio layer */ +#endif + #ifdef VMS # include "config.h" #else # include "../config.h" #endif +#ifdef WIN32 +#undef USE_STDIO_PTR /* XXX fast gets won't work, must investigate */ +# ifndef STANDARD_C +# define STANDARD_C +# endif +# if defined(__BORLANDC__) +# pragma warn -ccc +# pragma warn -rch +# pragma warn -sig +# pragma warn -pia +# pragma warn -par +# pragma warn -aus +# pragma warn -use +# pragma warn -csu +# pragma warn -pro +# elif defined(_MSC_VER) +# elif defined(__MINGW32__) +# endif +#endif + #if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) # define STANDARD_C 1 #endif diff --git a/x2p/a2py.c b/x2p/a2py.c index 202d5921e0..fefa81da7e 100644 --- a/x2p/a2py.c +++ b/x2p/a2py.c @@ -8,7 +8,7 @@ * $Log: a2py.c,v $ */ -#ifdef OS2 +#if defined(OS2) || defined(WIN32) #include "../patchlevel.h" #endif #include "util.h" @@ -26,7 +26,9 @@ int oper4(int type, int arg1, int arg2, int arg3, int arg4); int oper5(int type, int arg1, int arg2, int arg3, int arg4, int arg5); STR *walk(int useval, int level, register int node, int *numericptr, int minprec); -#ifdef OS2 +#if defined(OS2) || defined(WIN32) +static void usage(void); + static void usage() { @@ -86,9 +88,11 @@ main(register int argc, register char **argv, register char **env) case 0: break; default: - fatal("Unrecognized switch: %s\n",argv[0]); -#ifdef OS2 +#if defined(OS2) || defined(WIN32) + fprintf(stderr, "Unrecognized switch: %s\n",argv[0]); usage(); +#else + fatal("Unrecognized switch: %s\n",argv[0]); #endif } } @@ -97,7 +101,7 @@ main(register int argc, register char **argv, register char **env) /* open script */ if (argv[0] == Nullch) { -#ifdef OS2 +#if defined(OS2) || defined(WIN32) if ( isatty(fileno(stdin)) ) usage(); #endif diff --git a/x2p/s2p.PL b/x2p/s2p.PL index 73f67872de..fa0d567b6c 100644 --- a/x2p/s2p.PL +++ b/x2p/s2p.PL @@ -135,7 +135,7 @@ while ($ARGV[0] =~ /^-/) { } unless ($debug) { - open(BODY,">/tmp/sperl$$") || + open(BODY,"+>/tmp/sperl$$") || &Die("Can't open temp file: $!\n"); } @@ -343,26 +343,7 @@ print BODY &q(<<'EOT'); EOT } -close BODY; - unless ($debug) { - open(HEAD,">/tmp/sperl2$$.c") - || &Die("Can't open temp file 2: $!\n"); - print HEAD "#define PRINTIT\n" if $printit; - print HEAD "#define APPENDSEEN\n" if $appendseen; - print HEAD "#define TSEEN\n" if $tseen; - print HEAD "#define DSEEN\n" if $dseen; - print HEAD "#define ASSUMEN\n" if $assumen; - print HEAD "#define ASSUMEP\n" if $assumep; - print HEAD "#define TOPLABEL\n" if $toplabel; - print HEAD "#define SAWNEXT\n" if $sawnext; - if ($opens) {print HEAD "$opens\n";} - open(BODY,"/tmp/sperl$$") - || &Die("Can't reopen temp file: $!\n"); - while (<BODY>) { - print HEAD $_; - } - close HEAD; print &q(<<"EOT"); : $startperl @@ -370,11 +351,13 @@ unless ($debug) { : if \$running_under_some_shell; : EOT - open(BODY,"cc -E /tmp/sperl2$$.c |") || - &Die("Can't reopen temp file: $!\n"); + print"$opens\n" if $opens; + seek(BODY, 0, 0) || die "Can't rewind temp file: $!\n"; while (<BODY>) { - /^# [0-9]/ && next; /^[ \t]*$/ && next; + /^#ifdef (\w+)/ && ((${lc $1} || &skip), next); + /^#else/ && (&skip, next); + /^#endif/ && next; s/^<><>//; print; } @@ -384,8 +367,7 @@ EOT exit; sub Cleanup { - chdir "/tmp"; - unlink "sperl$$", "sperl2$$", "sperl2$$.c"; + unlink "/tmp/sperl$$"; } sub Die { &Cleanup; @@ -603,7 +585,6 @@ EOT $repl = substr($_, $repl+1, $end-$repl-1); $end = substr($_, $end + 1, 1000); &simplify($pat); - $dol = '$'; $subst = "$pat$repl$delim"; $cmd = ''; while ($end) { @@ -846,6 +827,17 @@ sub simplify { $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g; } +sub skip { + local($level) = 0; + + while(<BODY>) { + /^#ifdef/ && $level++; + /^#else/ && !$level && return; + /^#endif/ && !$level-- && return; + } + + die "Unterminated `#ifdef' conditional\n"; +} !NO!SUBS! close OUT or die "Can't close $file: $!"; |