This patch describes the changes made in ActivePerl build 618 over the official Perl v5.6.0 sources. Summary of changes in build 618: * Make "perl -V" output reflect ActiveState build. * Add Win32::BuildNumber() for compatibility. * Add resources to perl.exe and perl56.dll. The ActivePerl Release Notes contain an informal summary of these changes. These can be viewed at: http://www.ActiveState.com/ActivePerl/docs/CHANGES.html The included patch may be applied to Perl v5.6.0 sources using the GNU patch utility. e.g: % cd perl-5.6.0 % patch -lNp1 < this_file --------------------------------------------------------------------------- diff -ruN perl-5.6.0/BuildInfo.h AP618_source/BuildInfo.h --- perl-5.6.0/BuildInfo.h Wed Dec 31 16:00:00 1969 +++ AP618_source/BuildInfo.h Wed Sep 13 15:48:54 2000 @@ -0,0 +1,24 @@ +/* BuildInfo.h + * + * (c) 1998 ActiveState Tool Corp. All rights reserved. + * + */ + +#ifndef ___BuildInfo__h___ +#define ___BuildInfo__h___ + +#define PRODUCT_BUILD_NUMBER "618" +#define PERLFILEVERSION "5,6,0,618\0" +#define PERLRC_VERSION 5,6,0,618 +#define PERLPRODUCTVERSION "Build " PRODUCT_BUILD_NUMBER "\0" +#define PERLPRODUCTNAME "ActivePerl\0" + +#define PERL_VENDORLIB_NAME "ActiveState" + +#define ACTIVEPERL_VERSION "Built "##__TIME__##" "##__DATE__##"\n" +#define ACTIVEPERL_LOCAL_PATCHES_ENTRY "ActivePerl Build " PRODUCT_BUILD_NUMBER +#define BINARY_BUILD_NOTICE printf("\n\ +Binary build "##PRODUCT_BUILD_NUMBER##" provided by ActiveState Tool Corp. http://www.ActiveState.com\n\ +" ACTIVEPERL_VERSION "\n"); + +#endif /* ___BuildInfo__h___ */ diff -ruN perl-5.6.0/Configure AP618_source/Configure --- perl-5.6.0/Configure Wed Jul 5 14:34:01 2000 +++ AP618_source/Configure Wed Aug 23 15:14:42 2000 @@ -992,7 +992,11 @@ : List of libraries we want. : If anyone needs -lnet, put it in a hint file. -libswanted='sfio socket bind inet nsl nm ndbm gdbm dbm db malloc dl' +# XXX These libs are not used by perl itself. They were initially +# added to help platforms like SunOS that have funky dynamic loading +# requirements, but most modern platforms can cope without them. +#libswanted='ndbm gdbm dbm db' +libswanted='sfio socket bind inet nsl nm malloc dl' libswanted="$libswanted dld ld sun m c cposix posix" libswanted="$libswanted ndir dir crypt sec" libswanted="$libswanted ucb bsd BSD PW x iconv" diff -ruN perl-5.6.0/MANIFEST AP618_source/MANIFEST --- perl-5.6.0/MANIFEST Wed Jul 5 14:34:01 2000 +++ AP618_source/MANIFEST Wed Aug 23 15:14:42 2000 @@ -1295,6 +1295,7 @@ t/lib/soundex.t See if Soundex works t/lib/symbol.t See if Symbol works t/lib/syslfs.t See if large files work for sysio +t/lib/syslog.t See if Sys::Syslog works t/lib/textfill.t See if Text::Wrap::fill works t/lib/texttabs.t See if Text::Tabs works t/lib/textwrap.t See if Text::Wrap::wrap works diff -ruN perl-5.6.0/README.win32 AP618_source/README.win32 --- perl-5.6.0/README.win32 Wed Jul 5 14:34:03 2000 +++ AP618_source/README.win32 Wed Aug 23 15:14:42 2000 @@ -193,9 +193,9 @@ Type "dmake test" (or "nmake test"). This will run most of the tests from the testsuite (many tests will be skipped). -No tests should typically fail when running Windows NT 4.0. Under Windows -2000, test 22 in lib/open3.t is known to fail (cause still unknown). Many -tests will fail under Windows 9x due to the inferior command shell. +There should be no test failures when running under Windows NT 4.0 or +Windows 2000. Many tests I fail under Windows 9x due to the inferior +command shell. Some test failures may occur if you use a command shell other than the native "cmd.exe", or if you are building from a path that contains diff -ruN perl-5.6.0/av.h AP618_source/av.h --- perl-5.6.0/av.h Wed Jul 5 14:34:03 2000 +++ AP618_source/av.h Wed Aug 23 15:14:42 2000 @@ -32,8 +32,8 @@ * real if the array needs to be modified in some way. Functions that * modify fake AVs check both flags to call av_reify() as appropriate. * - * Note that the Perl stack has neither flag set. (Thus, items that go - * on the stack are never refcounted.) + * Note that the Perl stack and @DB::args have neither flag set. (Thus, + * items that go on the stack are never refcounted.) * * These internal details are subject to change any time. AV * manipulations external to perl should not care about any of this. diff -ruN perl-5.6.0/cop.h AP618_source/cop.h --- perl-5.6.0/cop.h Wed Jul 5 14:34:04 2000 +++ AP618_source/cop.h Thu Aug 31 08:59:56 2000 @@ -29,32 +29,33 @@ # define CopFILE(c) ((c)->cop_file) # define CopFILEGV(c) (CopFILE(c) \ ? gv_fetchfile(CopFILE(c)) : Nullgv) -# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) /* XXX */ +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) # define CopFILESV(c) (CopFILE(c) \ ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) # define CopFILEAV(c) (CopFILE(c) \ ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) # define CopSTASHPV(c) ((c)->cop_stashpv) -# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = savepv(pv)) /* XXX */ +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) # define CopSTASH(c) (CopSTASHPV(c) \ ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) -# define CopSTASH_set(c,hv) CopSTASHPV_set(c, HvNAME(hv)) -# define CopSTASH_eq(c,hv) (hv \ +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +# define CopSTASH_eq(c,hv) ((hv) \ && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #else # define CopFILEGV(c) ((c)->cop_filegv) -# define CopFILEGV_set(c,gv) ((c)->cop_filegv = gv) -# define CopFILE_set(c,pv) ((c)->cop_filegv = gv_fetchfile(pv)) +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) # define CopSTASH(c) ((c)->cop_stash) -# define CopSTASH_set(c,hv) ((c)->cop_stash = hv) +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) -# define CopSTASHPV_set(c,pv) CopSTASH_set(c, gv_stashpv(pv,GV_ADD)) -# define CopSTASH_eq(c,hv) (CopSTASH(c) == hv) + /* cop_stash is not refcounted */ +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif /* USE_ITHREADS */ #define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv)) @@ -79,6 +80,7 @@ U16 olddepth; U8 hasargs; U8 lval; /* XXX merge lval and hasargs? */ + SV ** oldcurpad; }; #define PUSHSUB(cx) \ @@ -105,13 +107,14 @@ } STMT_END #endif /* USE_THREADS */ -#ifdef USE_ITHREADS - /* junk in @_ spells trouble when cloning CVs, so don't leave any */ -# define CLEAR_ARGARRAY() av_clear(cx->blk_sub.argarray) -#else -# define CLEAR_ARGARRAY() NOOP -#endif /* USE_ITHREADS */ - +/* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't + * leave any (a fast av_clear(ary), basically) */ +#define CLEAR_ARGARRAY(ary) \ + STMT_START { \ + AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary); \ + SvPVX(ary) = (char*)AvALLOC(ary); \ + AvFILLp(ary) = -1; \ + } STMT_END #define POPSUB(cx,sv) \ STMT_START { \ @@ -124,10 +127,10 @@ cx->blk_sub.argarray = newAV(); \ av_extend(cx->blk_sub.argarray, fill); \ AvFLAGS(cx->blk_sub.argarray) = AVf_REIFY; \ - PL_curpad[0] = (SV*)cx->blk_sub.argarray; \ + cx->blk_sub.oldcurpad[0] = (SV*)cx->blk_sub.argarray; \ } \ else { \ - CLEAR_ARGARRAY(); \ + CLEAR_ARGARRAY(cx->blk_sub.argarray); \ } \ } \ sv = (SV*)cx->blk_sub.cv; \ @@ -423,6 +426,7 @@ #define G_NOARGS 8 /* Don't construct a @_ array. */ #define G_KEEPERR 16 /* Append errors to $@, don't overwrite it */ #define G_NODEBUG 32 /* Disable debugging at toplevel. */ +#define G_METHOD 64 /* Calling method. */ /* flag bits for PL_in_eval */ #define EVAL_NULL 0 /* not in an eval */ diff -ruN perl-5.6.0/doop.c AP618_source/doop.c --- perl-5.6.0/doop.c Wed Jul 5 14:34:04 2000 +++ AP618_source/doop.c Wed Aug 23 15:14:43 2000 @@ -660,12 +660,9 @@ if (items-- > 0) { char *s; - if (*mark) { - s = SvPV(*mark, tmplen); - sv_setpvn(sv, s, tmplen); - } - else - sv_setpv(sv, ""); + sv_setpv(sv, ""); + if (*mark) + sv_catsv(sv, *mark); mark++; } else @@ -697,6 +694,7 @@ SvTAINTED_on(sv); } +/* XXX SvUTF8 support missing! */ UV Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) { @@ -829,6 +827,7 @@ return retnum; } +/* XXX SvUTF8 support missing! */ void Perl_do_vecset(pTHX_ SV *sv) { @@ -844,6 +843,7 @@ if (!targ) return; s = (unsigned char*)SvPV_force(targ, targlen); + (void)SvPOK_only(targ); lval = SvUV(sv); offset = LvTARGOFF(sv); size = LvTARGLEN(sv); diff -ruN perl-5.6.0/dump.c AP618_source/dump.c --- perl-5.6.0/dump.c Wed Jul 5 14:34:04 2000 +++ AP618_source/dump.c Tue Aug 29 21:57:51 2000 @@ -279,9 +279,12 @@ } } else if (SvNOKp(sv)) { - RESTORE_NUMERIC_STANDARD(); + bool was_local = PL_numeric_local; + if (!was_local) + SET_NUMERIC_STANDARD(); Perl_sv_catpvf(aTHX_ t, "(%g)",SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); + if (was_local) + SET_NUMERIC_LOCAL(); } else if (SvIOKp(sv)) { if (SvIsUV(sv)) @@ -927,14 +930,17 @@ PerlIO_putc(file, '\n'); } if (type >= SVt_PVNV || type == SVt_NV) { - RESTORE_NUMERIC_STANDARD(); + bool was_local = PL_numeric_local; + if (!was_local) + SET_NUMERIC_STANDARD(); /* %Vg doesn't work? --jhi */ #ifdef USE_LONG_DOUBLE Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv)); #else Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); #endif - RESTORE_NUMERIC_LOCAL(); + if (was_local) + SET_NUMERIC_LOCAL(); } if (SvROK(sv)) { Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv))); diff -ruN perl-5.6.0/embed.h AP618_source/embed.h --- perl-5.6.0/embed.h Wed Jul 5 14:34:06 2000 +++ AP618_source/embed.h Wed Aug 23 15:14:44 2000 @@ -269,6 +269,7 @@ #define instr Perl_instr #define io_close Perl_io_close #define invert Perl_invert +#define is_gv_magical Perl_is_gv_magical #define is_uni_alnum Perl_is_uni_alnum #define is_uni_alnumc Perl_is_uni_alnumc #define is_uni_idfirst Perl_is_uni_idfirst @@ -570,6 +571,7 @@ #define save_freeop Perl_save_freeop #define save_freepv Perl_save_freepv #define save_generic_svref Perl_save_generic_svref +#define save_generic_pvref Perl_save_generic_pvref #define save_gp Perl_save_gp #define save_hash Perl_save_hash #define save_helem Perl_save_helem @@ -830,6 +832,10 @@ #define ptr_table_store Perl_ptr_table_store #define ptr_table_split Perl_ptr_table_split #endif +#if defined(HAVE_INTERP_INTERN) +#define sys_intern_clear Perl_sys_intern_clear +#define sys_intern_init Perl_sys_intern_init +#endif #if defined(PERL_OBJECT) #else #endif @@ -1716,6 +1722,7 @@ #define instr(a,b) Perl_instr(aTHX_ a,b) #define io_close(a,b) Perl_io_close(aTHX_ a,b) #define invert(a) Perl_invert(aTHX_ a) +#define is_gv_magical(a,b,c) Perl_is_gv_magical(aTHX_ a,b,c) #define is_uni_alnum(a) Perl_is_uni_alnum(aTHX_ a) #define is_uni_alnumc(a) Perl_is_uni_alnumc(aTHX_ a) #define is_uni_idfirst(a) Perl_is_uni_idfirst(aTHX_ a) @@ -2014,6 +2021,7 @@ #define save_freeop(a) Perl_save_freeop(aTHX_ a) #define save_freepv(a) Perl_save_freepv(aTHX_ a) #define save_generic_svref(a) Perl_save_generic_svref(aTHX_ a) +#define save_generic_pvref(a) Perl_save_generic_pvref(aTHX_ a) #define save_gp(a,b) Perl_save_gp(aTHX_ a,b) #define save_hash(a) Perl_save_hash(aTHX_ a) #define save_helem(a,b,c) Perl_save_helem(aTHX_ a,b,c) @@ -2266,6 +2274,10 @@ #define ptr_table_store(a,b,c) Perl_ptr_table_store(aTHX_ a,b,c) #define ptr_table_split(a) Perl_ptr_table_split(aTHX_ a) #endif +#if defined(HAVE_INTERP_INTERN) +#define sys_intern_clear() Perl_sys_intern_clear(aTHX) +#define sys_intern_init() Perl_sys_intern_init(aTHX) +#endif #if defined(PERL_OBJECT) #else #endif @@ -3361,6 +3373,8 @@ #define io_close Perl_io_close #define Perl_invert CPerlObj::Perl_invert #define invert Perl_invert +#define Perl_is_gv_magical CPerlObj::Perl_is_gv_magical +#define is_gv_magical Perl_is_gv_magical #define Perl_is_uni_alnum CPerlObj::Perl_is_uni_alnum #define is_uni_alnum Perl_is_uni_alnum #define Perl_is_uni_alnumc CPerlObj::Perl_is_uni_alnumc @@ -3944,6 +3958,8 @@ #define save_freepv Perl_save_freepv #define Perl_save_generic_svref CPerlObj::Perl_save_generic_svref #define save_generic_svref Perl_save_generic_svref +#define Perl_save_generic_pvref CPerlObj::Perl_save_generic_pvref +#define save_generic_pvref Perl_save_generic_pvref #define Perl_save_gp CPerlObj::Perl_save_gp #define save_gp Perl_save_gp #define Perl_save_hash CPerlObj::Perl_save_hash @@ -4440,6 +4456,12 @@ #define ptr_table_store Perl_ptr_table_store #define Perl_ptr_table_split CPerlObj::Perl_ptr_table_split #define ptr_table_split Perl_ptr_table_split +#endif +#if defined(HAVE_INTERP_INTERN) +#define Perl_sys_intern_clear CPerlObj::Perl_sys_intern_clear +#define sys_intern_clear Perl_sys_intern_clear +#define Perl_sys_intern_init CPerlObj::Perl_sys_intern_init +#define sys_intern_init Perl_sys_intern_init #endif #if defined(PERL_OBJECT) #else diff -ruN perl-5.6.0/embed.pl AP618_source/embed.pl --- perl-5.6.0/embed.pl Wed Jul 5 14:34:06 2000 +++ AP618_source/embed.pl Wed Aug 23 15:14:44 2000 @@ -1447,7 +1447,7 @@ Ap |void |dounwind |I32 cxix p |bool |do_aexec |SV* really|SV** mark|SV** sp p |bool |do_aexec5 |SV* really|SV** mark|SV** sp|int fd|int flag -Ap |int |do_binmode |PerlIO *fp|int iotype|int flag +Ap |int |do_binmode |PerlIO *fp|int iotype|int mode p |void |do_chop |SV* asv|SV* sv Ap |bool |do_close |GV* gv|bool not_implicit p |bool |do_eof |GV* gv @@ -1464,7 +1464,7 @@ p |I32 |do_semop |SV** mark|SV** sp p |I32 |do_shmio |I32 optype|SV** mark|SV** sp #endif -p |void |do_join |SV* sv|SV* del|SV** mark|SV** sp +Ap |void |do_join |SV* sv|SV* del|SV** mark|SV** sp p |OP* |do_kv Ap |bool |do_open |GV* gv|char* name|I32 len|int as_raw \ |int rawmode|int rawperm|PerlIO* supplied_fp @@ -1567,6 +1567,7 @@ Ap |char* |instr |const char* big|const char* little p |bool |io_close |IO* io|bool not_implicit p |OP* |invert |OP* cmd +dp |bool |is_gv_magical |char *name|STRLEN len|U32 flags Ap |bool |is_uni_alnum |U32 c Ap |bool |is_uni_alnumc |U32 c Ap |bool |is_uni_idfirst |U32 c @@ -1860,7 +1861,7 @@ Ap |void |repeatcpy |char* to|const char* from|I32 len|I32 count Ap |char* |rninstr |const char* big|const char* bigend \ |const char* little|const char* lend -p |Sighandler_t|rsignal |int i|Sighandler_t t +Ap |Sighandler_t|rsignal |int i|Sighandler_t t p |int |rsignal_restore|int i|Sigsave_t* t p |int |rsignal_save |int i|Sighandler_t t1|Sigsave_t* t2 p |Sighandler_t|rsignal_state|int i @@ -1885,6 +1886,7 @@ p |void |save_freeop |OP* o Ap |void |save_freepv |char* pv Ap |void |save_generic_svref|SV** sptr +Ap |void |save_generic_pvref|char** str Ap |void |save_gp |GV* gv|I32 empty Ap |HV* |save_hash |GV* gv Ap |void |save_helem |HV* hv|SV *key|SV **sptr @@ -2055,7 +2057,7 @@ Afp |void |warner |U32 err|const char* pat|... Ap |void |vwarner |U32 err|const char* pat|va_list* args p |void |watch |char** addr -p |I32 |whichsig |char* sig +Ap |I32 |whichsig |char* sig p |int |yyerror |char* s #if defined(USE_PURE_BISON) p |int |yylex |YYSTYPE *lvalp|int *lcharp @@ -2160,6 +2162,10 @@ Ap |void* |ptr_table_fetch|PTR_TBL_t *tbl|void *sv Ap |void |ptr_table_store|PTR_TBL_t *tbl|void *oldsv|void *newsv Ap |void |ptr_table_split|PTR_TBL_t *tbl +#endif +#if defined(HAVE_INTERP_INTERN) +Ap |void |sys_intern_clear +Ap |void |sys_intern_init #endif #if defined(PERL_OBJECT) diff -ruN perl-5.6.0/embedvar.h AP618_source/embedvar.h --- perl-5.6.0/embedvar.h Wed Jul 5 14:34:07 2000 +++ AP618_source/embedvar.h Wed Aug 23 15:14:44 2000 @@ -254,6 +254,7 @@ #define PL_gid (PERL_GET_INTERP->Igid) #define PL_glob_index (PERL_GET_INTERP->Iglob_index) #define PL_globalstash (PERL_GET_INTERP->Iglobalstash) +#define PL_he_arenaroot (PERL_GET_INTERP->Ihe_arenaroot) #define PL_he_root (PERL_GET_INTERP->Ihe_root) #define PL_hintgv (PERL_GET_INTERP->Ihintgv) #define PL_hints (PERL_GET_INTERP->Ihints) @@ -322,6 +323,7 @@ #define PL_nomemok (PERL_GET_INTERP->Inomemok) #define PL_nthreads (PERL_GET_INTERP->Inthreads) #define PL_nthreads_cond (PERL_GET_INTERP->Inthreads_cond) +#define PL_nullstash (PERL_GET_INTERP->Inullstash) #define PL_numeric_local (PERL_GET_INTERP->Inumeric_local) #define PL_numeric_name (PERL_GET_INTERP->Inumeric_name) #define PL_numeric_radix (PERL_GET_INTERP->Inumeric_radix) @@ -414,16 +416,27 @@ #define PL_widesyscalls (PERL_GET_INTERP->Iwidesyscalls) #define PL_xiv_arenaroot (PERL_GET_INTERP->Ixiv_arenaroot) #define PL_xiv_root (PERL_GET_INTERP->Ixiv_root) +#define PL_xnv_arenaroot (PERL_GET_INTERP->Ixnv_arenaroot) #define PL_xnv_root (PERL_GET_INTERP->Ixnv_root) +#define PL_xpv_arenaroot (PERL_GET_INTERP->Ixpv_arenaroot) #define PL_xpv_root (PERL_GET_INTERP->Ixpv_root) +#define PL_xpvav_arenaroot (PERL_GET_INTERP->Ixpvav_arenaroot) #define PL_xpvav_root (PERL_GET_INTERP->Ixpvav_root) +#define PL_xpvbm_arenaroot (PERL_GET_INTERP->Ixpvbm_arenaroot) #define PL_xpvbm_root (PERL_GET_INTERP->Ixpvbm_root) +#define PL_xpvcv_arenaroot (PERL_GET_INTERP->Ixpvcv_arenaroot) #define PL_xpvcv_root (PERL_GET_INTERP->Ixpvcv_root) +#define PL_xpvhv_arenaroot (PERL_GET_INTERP->Ixpvhv_arenaroot) #define PL_xpvhv_root (PERL_GET_INTERP->Ixpvhv_root) +#define PL_xpviv_arenaroot (PERL_GET_INTERP->Ixpviv_arenaroot) #define PL_xpviv_root (PERL_GET_INTERP->Ixpviv_root) +#define PL_xpvlv_arenaroot (PERL_GET_INTERP->Ixpvlv_arenaroot) #define PL_xpvlv_root (PERL_GET_INTERP->Ixpvlv_root) +#define PL_xpvmg_arenaroot (PERL_GET_INTERP->Ixpvmg_arenaroot) #define PL_xpvmg_root (PERL_GET_INTERP->Ixpvmg_root) +#define PL_xpvnv_arenaroot (PERL_GET_INTERP->Ixpvnv_arenaroot) #define PL_xpvnv_root (PERL_GET_INTERP->Ixpvnv_root) +#define PL_xrv_arenaroot (PERL_GET_INTERP->Ixrv_arenaroot) #define PL_xrv_root (PERL_GET_INTERP->Ixrv_root) #define PL_yychar (PERL_GET_INTERP->Iyychar) #define PL_yydebug (PERL_GET_INTERP->Iyydebug) @@ -518,6 +531,7 @@ #define PL_gid (vTHX->Igid) #define PL_glob_index (vTHX->Iglob_index) #define PL_globalstash (vTHX->Iglobalstash) +#define PL_he_arenaroot (vTHX->Ihe_arenaroot) #define PL_he_root (vTHX->Ihe_root) #define PL_hintgv (vTHX->Ihintgv) #define PL_hints (vTHX->Ihints) @@ -586,6 +600,7 @@ #define PL_nomemok (vTHX->Inomemok) #define PL_nthreads (vTHX->Inthreads) #define PL_nthreads_cond (vTHX->Inthreads_cond) +#define PL_nullstash (vTHX->Inullstash) #define PL_numeric_local (vTHX->Inumeric_local) #define PL_numeric_name (vTHX->Inumeric_name) #define PL_numeric_radix (vTHX->Inumeric_radix) @@ -678,16 +693,27 @@ #define PL_widesyscalls (vTHX->Iwidesyscalls) #define PL_xiv_arenaroot (vTHX->Ixiv_arenaroot) #define PL_xiv_root (vTHX->Ixiv_root) +#define PL_xnv_arenaroot (vTHX->Ixnv_arenaroot) #define PL_xnv_root (vTHX->Ixnv_root) +#define PL_xpv_arenaroot (vTHX->Ixpv_arenaroot) #define PL_xpv_root (vTHX->Ixpv_root) +#define PL_xpvav_arenaroot (vTHX->Ixpvav_arenaroot) #define PL_xpvav_root (vTHX->Ixpvav_root) +#define PL_xpvbm_arenaroot (vTHX->Ixpvbm_arenaroot) #define PL_xpvbm_root (vTHX->Ixpvbm_root) +#define PL_xpvcv_arenaroot (vTHX->Ixpvcv_arenaroot) #define PL_xpvcv_root (vTHX->Ixpvcv_root) +#define PL_xpvhv_arenaroot (vTHX->Ixpvhv_arenaroot) #define PL_xpvhv_root (vTHX->Ixpvhv_root) +#define PL_xpviv_arenaroot (vTHX->Ixpviv_arenaroot) #define PL_xpviv_root (vTHX->Ixpviv_root) +#define PL_xpvlv_arenaroot (vTHX->Ixpvlv_arenaroot) #define PL_xpvlv_root (vTHX->Ixpvlv_root) +#define PL_xpvmg_arenaroot (vTHX->Ixpvmg_arenaroot) #define PL_xpvmg_root (vTHX->Ixpvmg_root) +#define PL_xpvnv_arenaroot (vTHX->Ixpvnv_arenaroot) #define PL_xpvnv_root (vTHX->Ixpvnv_root) +#define PL_xrv_arenaroot (vTHX->Ixrv_arenaroot) #define PL_xrv_root (vTHX->Ixrv_root) #define PL_yychar (vTHX->Iyychar) #define PL_yydebug (vTHX->Iyydebug) @@ -919,6 +945,7 @@ #define PL_gid (aTHXo->interp.Igid) #define PL_glob_index (aTHXo->interp.Iglob_index) #define PL_globalstash (aTHXo->interp.Iglobalstash) +#define PL_he_arenaroot (aTHXo->interp.Ihe_arenaroot) #define PL_he_root (aTHXo->interp.Ihe_root) #define PL_hintgv (aTHXo->interp.Ihintgv) #define PL_hints (aTHXo->interp.Ihints) @@ -987,6 +1014,7 @@ #define PL_nomemok (aTHXo->interp.Inomemok) #define PL_nthreads (aTHXo->interp.Inthreads) #define PL_nthreads_cond (aTHXo->interp.Inthreads_cond) +#define PL_nullstash (aTHXo->interp.Inullstash) #define PL_numeric_local (aTHXo->interp.Inumeric_local) #define PL_numeric_name (aTHXo->interp.Inumeric_name) #define PL_numeric_radix (aTHXo->interp.Inumeric_radix) @@ -1079,16 +1107,27 @@ #define PL_widesyscalls (aTHXo->interp.Iwidesyscalls) #define PL_xiv_arenaroot (aTHXo->interp.Ixiv_arenaroot) #define PL_xiv_root (aTHXo->interp.Ixiv_root) +#define PL_xnv_arenaroot (aTHXo->interp.Ixnv_arenaroot) #define PL_xnv_root (aTHXo->interp.Ixnv_root) +#define PL_xpv_arenaroot (aTHXo->interp.Ixpv_arenaroot) #define PL_xpv_root (aTHXo->interp.Ixpv_root) +#define PL_xpvav_arenaroot (aTHXo->interp.Ixpvav_arenaroot) #define PL_xpvav_root (aTHXo->interp.Ixpvav_root) +#define PL_xpvbm_arenaroot (aTHXo->interp.Ixpvbm_arenaroot) #define PL_xpvbm_root (aTHXo->interp.Ixpvbm_root) +#define PL_xpvcv_arenaroot (aTHXo->interp.Ixpvcv_arenaroot) #define PL_xpvcv_root (aTHXo->interp.Ixpvcv_root) +#define PL_xpvhv_arenaroot (aTHXo->interp.Ixpvhv_arenaroot) #define PL_xpvhv_root (aTHXo->interp.Ixpvhv_root) +#define PL_xpviv_arenaroot (aTHXo->interp.Ixpviv_arenaroot) #define PL_xpviv_root (aTHXo->interp.Ixpviv_root) +#define PL_xpvlv_arenaroot (aTHXo->interp.Ixpvlv_arenaroot) #define PL_xpvlv_root (aTHXo->interp.Ixpvlv_root) +#define PL_xpvmg_arenaroot (aTHXo->interp.Ixpvmg_arenaroot) #define PL_xpvmg_root (aTHXo->interp.Ixpvmg_root) +#define PL_xpvnv_arenaroot (aTHXo->interp.Ixpvnv_arenaroot) #define PL_xpvnv_root (aTHXo->interp.Ixpvnv_root) +#define PL_xrv_arenaroot (aTHXo->interp.Ixrv_arenaroot) #define PL_xrv_root (aTHXo->interp.Ixrv_root) #define PL_yychar (aTHXo->interp.Iyychar) #define PL_yydebug (aTHXo->interp.Iyydebug) @@ -1184,6 +1223,7 @@ #define PL_Igid PL_gid #define PL_Iglob_index PL_glob_index #define PL_Iglobalstash PL_globalstash +#define PL_Ihe_arenaroot PL_he_arenaroot #define PL_Ihe_root PL_he_root #define PL_Ihintgv PL_hintgv #define PL_Ihints PL_hints @@ -1252,6 +1292,7 @@ #define PL_Inomemok PL_nomemok #define PL_Inthreads PL_nthreads #define PL_Inthreads_cond PL_nthreads_cond +#define PL_Inullstash PL_nullstash #define PL_Inumeric_local PL_numeric_local #define PL_Inumeric_name PL_numeric_name #define PL_Inumeric_radix PL_numeric_radix @@ -1344,16 +1385,27 @@ #define PL_Iwidesyscalls PL_widesyscalls #define PL_Ixiv_arenaroot PL_xiv_arenaroot #define PL_Ixiv_root PL_xiv_root +#define PL_Ixnv_arenaroot PL_xnv_arenaroot #define PL_Ixnv_root PL_xnv_root +#define PL_Ixpv_arenaroot PL_xpv_arenaroot #define PL_Ixpv_root PL_xpv_root +#define PL_Ixpvav_arenaroot PL_xpvav_arenaroot #define PL_Ixpvav_root PL_xpvav_root +#define PL_Ixpvbm_arenaroot PL_xpvbm_arenaroot #define PL_Ixpvbm_root PL_xpvbm_root +#define PL_Ixpvcv_arenaroot PL_xpvcv_arenaroot #define PL_Ixpvcv_root PL_xpvcv_root +#define PL_Ixpvhv_arenaroot PL_xpvhv_arenaroot #define PL_Ixpvhv_root PL_xpvhv_root +#define PL_Ixpviv_arenaroot PL_xpviv_arenaroot #define PL_Ixpviv_root PL_xpviv_root +#define PL_Ixpvlv_arenaroot PL_xpvlv_arenaroot #define PL_Ixpvlv_root PL_xpvlv_root +#define PL_Ixpvmg_arenaroot PL_xpvmg_arenaroot #define PL_Ixpvmg_root PL_xpvmg_root +#define PL_Ixpvnv_arenaroot PL_xpvnv_arenaroot #define PL_Ixpvnv_root PL_xpvnv_root +#define PL_Ixrv_arenaroot PL_xrv_arenaroot #define PL_Ixrv_root PL_xrv_root #define PL_Iyychar PL_yychar #define PL_Iyydebug PL_yydebug diff -ruN perl-5.6.0/ext/B/B/Deparse.pm AP618_source/ext/B/B/Deparse.pm --- perl-5.6.0/ext/B/B/Deparse.pm Wed Jul 5 14:34:08 2000 +++ AP618_source/ext/B/B/Deparse.pm Wed Aug 23 15:14:44 2000 @@ -1,5 +1,5 @@ # B::Deparse.pm -# Copyright (c) 1998, 1999 Stephen McCamant. All rights reserved. +# Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved. # This module is free software; you can redistribute and/or modify # it under the same terms as Perl itself. @@ -8,7 +8,6 @@ package B::Deparse; use Carp 'cluck', 'croak'; -use Config; use B qw(class main_root main_start main_cv svref_2object opnumber OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL @@ -17,7 +16,7 @@ SVf_IOK SVf_NOK SVf_ROK SVf_POK PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = 0.59; +$VERSION = 0.591; use strict; # Changes between 0.50 and 0.51: @@ -252,17 +251,17 @@ walk_tree($op, sub { my $op = shift; if ($op->name eq "gv") { - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); if ($op->next->name eq "entersub") { - next if $self->{'subs_done'}{$$gv}++; - next if class($gv->CV) eq "SPECIAL"; + return if $self->{'subs_done'}{$$gv}++; + return if class($gv->CV) eq "SPECIAL"; $self->todo($gv, $gv->CV, 0); $self->walk_sub($gv->CV); } elsif ($op->next->name eq "enterwrite" or ($op->next->name eq "rv2gv" and $op->next->next->name eq "enterwrite")) { - next if $self->{'forms_done'}{$$gv}++; - next if class($gv->FORM) eq "SPECIAL"; + return if $self->{'forms_done'}{$$gv}++; + return if class($gv->FORM) eq "SPECIAL"; $self->todo($gv, $gv->FORM, 1); $self->walk_sub($gv->FORM); } @@ -378,7 +377,7 @@ while (scalar(@{$self->{'subs_todo'}})) { push @text, $self->next_todo; } - print indent(join("", @text)), "\n" if @text; + print $self->indent(join("", @text)), "\n" if @text; } } @@ -1653,6 +1652,13 @@ } } +sub is_ifelse_cont { + my $op = shift; + return ($op->name eq "null" and class($op) eq "UNOP" + and $op->first->name =~ /^(and|cond_expr)$/ + and is_scope($op->first->first->sibling)); +} + sub pp_cond_expr { my $self = shift; my($op, $cx) = @_; @@ -1660,36 +1666,34 @@ my $true = $cond->sibling; my $false = $true->sibling; my $cuddle = $self->{'cuddle'}; - unless ($cx == 0 and is_scope($true) and is_scope($false)) { + unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and + (is_scope($false) || is_ifelse_cont($false))) { $cond = $self->deparse($cond, 8); $true = $self->deparse($true, 8); $false = $self->deparse($false, 8); return $self->maybe_parens("$cond ? $true : $false", $cx, 8); - } + } + $cond = $self->deparse($cond, 1); $true = $self->deparse($true, 0); - if ($false->name eq "lineseq") { # braces w/o scope => elsif - my $head = "if ($cond) {\n\t$true\n\b}"; - my @elsifs; - while (!null($false) and $false->name eq "lineseq") { - my $newop = $false->first->sibling->first; - my $newcond = $newop->first; - my $newtrue = $newcond->sibling; - $false = $newtrue->sibling; # last in chain is OP_AND => no else - $newcond = $self->deparse($newcond, 1); - $newtrue = $self->deparse($newtrue, 0); - push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}"; - } - if (!null($false)) { - $false = $cuddle . "else {\n\t" . - $self->deparse($false, 0) . "\n\b}\cK"; - } else { - $false = "\cK"; - } - return $head . join($cuddle, "", @elsifs) . $false; + my $head = "if ($cond) {\n\t$true\n\b}"; + my @elsifs; + while (!null($false) and is_ifelse_cont($false)) { + my $newop = $false->first; + my $newcond = $newop->first; + my $newtrue = $newcond->sibling; + $false = $newtrue->sibling; # last in chain is OP_AND => no else + $newcond = $self->deparse($newcond, 1); + $newtrue = $self->deparse($newtrue, 0); + push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}"; + } + if (!null($false)) { + $false = $cuddle . "else {\n\t" . + $self->deparse($false, 0) . "\n\b}\cK"; + } else { + $false = "\cK"; } - $false = $self->deparse($false, 0); - return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK"; + return $head . join($cuddle, "", @elsifs) . $false; } sub pp_leaveloop { @@ -1814,7 +1818,7 @@ } elsif ($op->first->name eq "enter") { return $self->pp_leave($op, $cx); } elsif ($op->targ == OP_STRINGIFY) { - return $self->dquote($op); + return $self->dquote($op, $cx); } elsif (!null($op->first->sibling) and $op->first->sibling->name eq "readline" and $op->first->sibling->flags & OPf_STACKED) { @@ -1879,37 +1883,34 @@ return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]); } -sub maybe_padgv { +sub gv_or_padgv { my $self = shift; my $op = shift; - my $gv; - if ($Config{useithreads}) { - $gv = $self->padval($op->padix); + if (class($op) eq "PADOP") { + return $self->padval($op->padix); + } else { # class($op) eq "SVOP" + return $op->gv; } - else { - $gv = $op->gv; - } - return $gv; } sub pp_gvsv { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv)); } sub pp_gv { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return $self->gv_name($gv); } sub pp_aelemfast { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return "\$" . $self->gv_name($gv) . "[" . $op->private . "]"; } @@ -2220,7 +2221,7 @@ $amper = "&"; $kid = "{" . $self->deparse($kid, 0) . "}"; } elsif ($kid->first->name eq "gv") { - my $gv = $self->maybe_padgv($kid->first); + my $gv = $self->gv_or_padgv($kid->first); if (class($gv->CV) ne "SPECIAL") { $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; } @@ -2252,9 +2253,9 @@ } else { if (defined $proto and $proto eq "") { return $kid; - } elsif ($proto eq "\$") { + } elsif (defined $proto and $proto eq "\$") { return $self->maybe_parens_func($kid, $args, $cx, 16); - } elsif ($proto or $simple) { + } elsif (defined($proto) && $proto or $simple) { return $self->maybe_parens_func($kid, $args, $cx, 5); } else { return "$kid(" . $args . ")"; @@ -2418,7 +2419,7 @@ sub dquote { my $self = shift; - my($op, $cx) = shift; + my($op, $cx) = @_; my $kid = $op->first->sibling; # skip ex-stringify, pushmark return $self->deparse($kid, $cx) if $self->{'unquote'}; $self->maybe_targmy($kid, $cx, diff -ruN perl-5.6.0/ext/Data/Dumper/Dumper.xs AP618_source/ext/Data/Dumper/Dumper.xs --- perl-5.6.0/ext/Data/Dumper/Dumper.xs Wed Jul 5 14:34:09 2000 +++ AP618_source/ext/Data/Dumper/Dumper.xs Wed Aug 23 15:14:46 2000 @@ -584,8 +584,7 @@ if (SvIOK(val)) { STRLEN len; - i = SvIV(val); - (void) sprintf(tmpbuf, "%"IVdf, (IV)i); + (void) sprintf(tmpbuf, "%"IVdf, SvIV(val)); len = strlen(tmpbuf); sv_catpvn(retval, tmpbuf, len); } diff -ruN perl-5.6.0/ext/File/Glob/Glob.pm AP618_source/ext/File/Glob/Glob.pm --- perl-5.6.0/ext/File/Glob/Glob.pm Wed Jul 5 14:34:09 2000 +++ AP618_source/ext/File/Glob/Glob.pm Wed Aug 23 15:14:47 2000 @@ -11,8 +11,12 @@ @ISA = qw(Exporter AutoLoader); +# NOTE: The glob() export is only here for compatibility with 5.6.0. +# csh_glob() should not be used directly, unless you know what you're doing. + @EXPORT_OK = qw( csh_glob + bsd_glob glob GLOB_ABEND GLOB_ALTDIRFUNC @@ -47,6 +51,7 @@ GLOB_QUOTE GLOB_TILDE glob + bsd_glob ) ], ); @@ -108,12 +113,18 @@ # Autoload methods go after =cut, and are processed by the autosplit program. -sub glob { +sub bsd_glob { my ($pat,$flags) = @_; $flags = $DEFAULT_FLAGS if @_ < 2; return doglob($pat,$flags); } +# File::Glob::glob() is deprecated because its prototype is different from +# CORE::glob() (use bsd_glob() instead) +sub glob { + goto &bsd_glob; +} + ## borrowed heavily from gsar's File::DosGlob my %iter; my %entries; @@ -177,13 +188,13 @@ =head1 SYNOPSIS use File::Glob ':glob'; - @list = glob('*.[ch]'); - $homedir = glob('~gnat', GLOB_TILDE | GLOB_ERR); + @list = bsd_glob('*.[ch]'); + $homedir = bsd_glob('~gnat', GLOB_TILDE | GLOB_ERR); if (GLOB_ERROR) { # an error occurred reading $homedir } - ## override the core glob (core glob() does this automatically + ## override the core glob (CORE::glob() does this automatically ## by default anyway, since v5.6.0) use File::Glob ':globally'; my @sources = <*.{c,h,y}> @@ -198,19 +209,27 @@ =head1 DESCRIPTION -File::Glob implements the FreeBSD glob(3) routine, which is a superset -of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2"). The -glob() routine takes a mandatory C argument, and an optional +File::Glob::bsd_glob() implements the FreeBSD glob(3) routine, which is +a superset of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2"). +bsd_glob() takes a mandatory C argument, and an optional C argument, and returns a list of filenames matching the pattern, with interpretation of the pattern modified by the C -variable. The POSIX defined flags are: +variable. + +Since v5.6.0, Perl's CORE::glob() is implemented in terms of bsd_glob(). +Note that they don't share the same prototype--CORE::glob() only accepts +a single argument. Due to historical reasons, CORE::glob() will also +split its argument on whitespace, treating it as multiple patterns, +whereas bsd_glob() considers them as one pattern. + +The POSIX defined flags for bsd_glob() are: =over 4 =item C -Force glob() to return an error when it encounters a directory it -cannot open or read. Ordinarily glob() continues to find matches. +Force bsd_glob() to return an error when it encounters a directory it +cannot open or read. Ordinarily bsd_glob() continues to find matches. =item C @@ -220,18 +239,18 @@ =item C By default, file names are assumed to be case sensitive; this flag -makes glob() treat case differences as not significant. +makes bsd_glob() treat case differences as not significant. =item C -If the pattern does not match any pathname, then glob() returns a list +If the pattern does not match any pathname, then bsd_glob() returns a list consisting of only the pattern. If C is set, its effect is present in the pattern returned. =item C By default, the pathnames are sorted in ascending ASCII order; this -flag prevents that sorting (speeding up glob()). +flag prevents that sorting (speeding up bsd_glob()). =back @@ -277,7 +296,7 @@ =head1 DIAGNOSTICS -glob() returns a list of matching paths, possibly zero length. If an +bsd_glob() returns a list of matching paths, possibly zero length. If an error occurred, &File::Glob::GLOB_ERROR will be non-zero and C<$!> will be set. &File::Glob::GLOB_ERROR is guaranteed to be zero if no error occurred, or one of the following values otherwise: @@ -294,12 +313,12 @@ =back -In the case where glob() has found some matching paths, but is -interrupted by an error, glob() will return a list of filenames B +In the case where bsd_glob() has found some matching paths, but is +interrupted by an error, it will return a list of filenames B set &File::Glob::ERROR. -Note that glob() deviates from POSIX and FreeBSD glob(3) behaviour by -not considering C and C as errors - glob() will +Note that bsd_glob() deviates from POSIX and FreeBSD glob(3) behaviour +by not considering C and C as errors - bsd_glob() will continue processing despite those errors, unless the C flag is set. @@ -311,10 +330,10 @@ =item * -If you want to use multiple patterns, e.g. C, you should -probably throw them in a set as in C. This is because -the argument to glob isn't subjected to parsing by the C shell. Remember -that you can use a backslash to escape things. +If you want to use multiple patterns, e.g. C, you should +probably throw them in a set as in C. This is because +the argument to bsd_glob() isn't subjected to parsing by the C shell. +Remember that you can use a backslash to escape things. =item * diff -ruN perl-5.6.0/ext/IO/lib/IO/Poll.pm AP618_source/ext/IO/lib/IO/Poll.pm --- perl-5.6.0/ext/IO/lib/IO/Poll.pm Wed Jul 5 14:34:10 2000 +++ AP618_source/ext/IO/lib/IO/Poll.pm Wed Aug 23 15:14:47 2000 @@ -1,3 +1,4 @@ + # IO::Poll.pm # # Copyright (c) 1997-8 Graham Barr . All rights reserved. @@ -12,28 +13,31 @@ our(@ISA, @EXPORT_OK, @EXPORT, $VERSION); @ISA = qw(Exporter); -$VERSION = "0.01"; +$VERSION = "0.05"; -@EXPORT = qw(poll); +@EXPORT = qw( POLLIN + POLLOUT + POLLERR + POLLHUP + POLLNVAL + ); @EXPORT_OK = qw( - POLLIN POLLPRI - POLLOUT POLLRDNORM POLLWRNORM POLLRDBAND POLLWRBAND POLLNORM - POLLERR - POLLHUP - POLLNVAL -); + ); +# [0] maps fd's to requested masks +# [1] maps fd's to returned masks +# [2] maps fd's to handles sub new { my $class = shift; - my $self = bless [{},{}], $class; + my $self = bless [{},{},{}], $class; $self; } @@ -42,20 +46,21 @@ my $self = shift; my $io = shift; my $fd = fileno($io); - if(@_) { + if (@_) { my $mask = shift; - $self->[0]{$fd} ||= {}; if($mask) { - $self->[0]{$fd}{$io} = $mask; - } - else { + $self->[0]{$fd}{$io} = $mask; # the error events are always returned + $self->[1]{$fd} = 0; # output mask + $self->[2]{$io} = $io; # remember handle + } else { delete $self->[0]{$fd}{$io}; + delete $self->[1]{$fd} unless %{$self->[0]{$fd}}; + delete $self->[2]{$io}; } } - elsif(exists $self->[0]{$fd}{$io}) { + + return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{$io}; return $self->[0]{$fd}{$io}; - } - return; } @@ -64,13 +69,13 @@ $self->[1] = {}; - my($fd,$ref); + my($fd,$mask,$iom); my @poll = (); - while(($fd,$ref) = each %{$self->[0]}) { - my $events = 0; - map { $events |= $_ } values %{$ref}; - push(@poll,$fd, $events); + while(($fd,$iom) = each %{$self->[0]}) { + $mask = 0; + $mask |= $_ for values(%$iom); + push(@poll,$fd => $mask); } my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0; @@ -80,8 +85,7 @@ while(@poll) { my($fd,$got) = splice(@poll,0,2); - $self->[1]{$fd} = $got - if $got; + $self->[1]{$fd} = $got if $got; } return $ret; @@ -91,9 +95,8 @@ my $self = shift; my $io = shift; my $fd = fileno($io); - - exists $self->[1]{$fd} && exists $self->[0]{$fd}{$io} - ? $self->[1]{$fd} & $self->[0]{$fd}{$io} + exists $self->[1]{$fd} and exists $self->[0]{$fd}{$io} + ? $self->[1]{$fd} & ($self->[0]{$fd}{$io}|POLLHUP|POLLERR|POLLNVAL) : 0; } @@ -105,20 +108,16 @@ sub handles { my $self = shift; - - return map { keys %$_ } values %{$self->[0]} - unless(@_); + return values %{$self->[2]} unless @_; my $events = shift || 0; my($fd,$ev,$io,$mask); my @handles = (); while(($fd,$ev) = each %{$self->[1]}) { - if($ev & $events) { - while(($io,$mask) = each %{$self->[0][$fd]}) { - push(@handles, $io) - if $events & $mask; - } + while (($io,$mask) = each %{$self->[0]{$fd}}) { + $mask |= POLLHUP|POLLERR|POLLNVAL; # must allow these + push @handles,$self->[2]{$io} if ($ev & $mask) & $events; } } return @handles; @@ -138,8 +137,8 @@ $poll = new IO::Poll; - $poll->mask($input_handle => POLLRDNORM | POLLIN | POLLHUP); - $poll->mask($output_handle => POLLWRNORM); + $poll->mask($input_handle => POLLIN); + $poll->mask($output_handle => POLLOUT); $poll->poll($timeout); diff -ruN perl-5.6.0/ext/IO/lib/IO/Socket/INET.pm AP618_source/ext/IO/lib/IO/Socket/INET.pm --- perl-5.6.0/ext/IO/lib/IO/Socket/INET.pm Wed Jul 5 14:34:10 2000 +++ AP618_source/ext/IO/lib/IO/Socket/INET.pm Wed Aug 23 15:14:47 2000 @@ -34,6 +34,7 @@ sub _sock_info { my($addr,$port,$proto) = @_; + my $origport = $port; my @proto = (); my @serv = (); @@ -59,14 +60,14 @@ my $defport = $1 || undef; my $pnum = ($port =~ m,^(\d+)$,)[0]; - if ($port =~ m,\D,) { - unless (@serv = getservbyname($port, $proto[0] || "")) { - $@ = "Bad service '$port'"; - return; - } - } + @serv = getservbyname($port, $proto[0] || "") + if ($port =~ m,\D,); $port = $pnum || $serv[2] || $defport || undef; + unless (defined $port) { + $@ = "Bad service '$origport'"; + return; + } $proto = (getprotobyname($serv[3]))[2] || undef if @serv && !$proto; diff -ruN perl-5.6.0/ext/POSIX/POSIX.pm AP618_source/ext/POSIX/POSIX.pm --- perl-5.6.0/ext/POSIX/POSIX.pm Wed Jul 5 14:34:10 2000 +++ AP618_source/ext/POSIX/POSIX.pm Wed Aug 23 15:14:49 2000 @@ -565,9 +565,9 @@ sub fstat { usage "fstat(fd)" if @_ != 1; local *TMP; - open(TMP, "<&$_[0]"); # Gross. + CORE::open(TMP, "<&$_[0]"); # Gross. my @l = CORE::stat(TMP); - close(TMP); + CORE::close(TMP); @l; } diff -ruN perl-5.6.0/ext/Sys/Syslog/Syslog.pm AP618_source/ext/Sys/Syslog/Syslog.pm --- perl-5.6.0/ext/Sys/Syslog/Syslog.pm Wed Jul 5 14:34:11 2000 +++ AP618_source/ext/Sys/Syslog/Syslog.pm Wed Aug 23 15:14:50 2000 @@ -70,9 +70,11 @@ C or C and returns TRUE on success, undef on failure. -A value of 'unix' will connect to the UNIX domain socket returned by -C<_PATH_LOG> in F. A value of 'inet' will connect to an -INET socket returned by getservbyname(). Any other value croaks. +A value of 'unix' will connect to the UNIX domain socket returned by the +C<_PATH_LOG> macro (if you system defines it) in F. A value of +'inet' will connect to an INET socket returned by getservbyname(). If +C<_PATH_LOG> is unavailable or if getservbyname() fails, returns undef. Any +other value croaks. The default is for the INET socket to be used. @@ -107,10 +109,15 @@ =head1 AUTHOR -Tom Christiansen EFE and Larry Wall EFE. -UNIX domain sockets added by Sean Robinson EFE -with support from Tim Bunce and the perl5-porters mailing list. -Dependency on F replaced with XS code bu Tom Hughes EFE. +Tom Christiansen EFE and Larry Wall +EFE. + +UNIX domain sockets added by Sean Robinson +EFE with support from Tim Bunce +EFE and the perl5-porters mailing list. + +Dependency on F replaced with XS code by Tom Hughes +EFE. =cut @@ -159,7 +166,7 @@ local($setsock) = shift; &disconnect if $connected; if (lc($setsock) eq 'unix') { - if (defined &_PATH_LOG) { + if (length _PATH_LOG()) { $sock_type = 1; } else { return undef; @@ -244,9 +251,9 @@ else { if (open(CONS,">/dev/console")) { print CONS "<$facility.$priority>$whoami: $message\r"; - exit if defined $pid; # if fork failed, we're parent close CONS; } + exit if defined $pid; # if fork failed, we're parent } } } @@ -274,7 +281,8 @@ socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; connect(SYSLOG,$that) || croak "connect: $!"; } else { - my $syslog = &_PATH_LOG || croak "_PATH_LOG not found in syslog.ph"; + my $syslog = _PATH_LOG(); + length($syslog) || croak "_PATH_LOG unavailable in syslog.h"; my $that = sockaddr_un($syslog) || croak "Can't locate $syslog"; socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) || croak "socket: $!"; if (!connect(SYSLOG,$that)) { diff -ruN perl-5.6.0/ext/Sys/Syslog/Syslog.xs AP618_source/ext/Sys/Syslog/Syslog.xs --- perl-5.6.0/ext/Sys/Syslog/Syslog.xs Wed Jul 5 14:34:11 2000 +++ AP618_source/ext/Sys/Syslog/Syslog.xs Wed Aug 23 15:14:50 2000 @@ -550,8 +550,7 @@ #ifdef _PATH_LOG RETVAL = _PATH_LOG; #else - croak("Your vendor has not defined the Sys::Syslog macro _PATH_LOG"); - RETVAL = NULL; + RETVAL = ""; #endif OUTPUT: RETVAL diff -ruN perl-5.6.0/global.sym AP618_source/global.sym --- perl-5.6.0/global.sym Wed Jul 5 14:34:12 2000 +++ AP618_source/global.sym Wed Aug 23 15:14:51 2000 @@ -88,6 +88,7 @@ Perl_dounwind Perl_do_binmode Perl_do_close +Perl_do_join Perl_do_open Perl_do_open9 Perl_dowantarray @@ -320,6 +321,7 @@ Perl_regnext Perl_repeatcpy Perl_rninstr +Perl_rsignal Perl_savepv Perl_savepvn Perl_savestack_grow @@ -334,6 +336,7 @@ Perl_save_freesv Perl_save_freepv Perl_save_generic_svref +Perl_save_generic_pvref Perl_save_gp Perl_save_hash Perl_save_helem @@ -463,6 +466,7 @@ Perl_vwarn Perl_warner Perl_vwarner +Perl_whichsig Perl_dump_mstats Perl_get_mstats Perl_safesysmalloc @@ -537,3 +541,5 @@ Perl_ptr_table_fetch Perl_ptr_table_store Perl_ptr_table_split +Perl_sys_intern_clear +Perl_sys_intern_init diff -ruN perl-5.6.0/gv.c AP618_source/gv.c --- perl-5.6.0/gv.c Wed Jul 5 14:34:12 2000 +++ AP618_source/gv.c Wed Aug 23 15:14:51 2000 @@ -520,7 +520,6 @@ I32 len; register const char *namend; HV *stash = 0; - U32 add_gvflags = 0; if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ name++; @@ -653,8 +652,10 @@ : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" : ""), name)); + stash = PL_nullstash; } - return Nullgv; + else + return Nullgv; } if (!SvREFCNT(stash)) /* symbol table under destruction */ @@ -680,7 +681,6 @@ Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg); gv_init(gv, stash, name, len, add & GV_ADDMULTI); gv_init_sv(gv, sv_type); - GvFLAGS(gv) |= add_gvflags; if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE)) GvMULTI_on(gv) ; @@ -1579,4 +1579,111 @@ return res; } } +} + +/* +=for apidoc is_gv_magical + +Returns C if given the name of a magical GV. + +Currently only useful internally when determining if a GV should be +created even in rvalue contexts. + +C is not used at present but available for future extension to +allow selecting particular classes of magical variable. + +=cut +*/ +bool +Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) +{ + if (!len) + return FALSE; + + switch (*name) { + case 'I': + if (len == 3 && strEQ(name, "ISA")) + goto yes; + break; + case 'O': + if (len == 8 && strEQ(name, "OVERLOAD")) + goto yes; + break; + case 'S': + if (len == 3 && strEQ(name, "SIG")) + goto yes; + break; + case '\027': /* $^W & $^WARNING_BITS */ + if (len == 1 + || (len == 12 && strEQ(name, "\027ARNING_BITS")) + || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS"))) + { + goto yes; + } + break; + + case '&': + case '`': + case '\'': + case ':': + case '?': + case '!': + case '-': + case '#': + case '*': + case '[': + case '^': + case '~': + case '=': + case '%': + case '.': + case '(': + case ')': + case '<': + case '>': + case ',': + case '\\': + case '/': + case '|': + case '+': + case ';': + case ']': + case '\001': /* $^A */ + case '\003': /* $^C */ + case '\004': /* $^D */ + case '\005': /* $^E */ + case '\006': /* $^F */ + case '\010': /* $^H */ + case '\011': /* $^I, NOT \t in EBCDIC */ + case '\014': /* $^L */ + case '\017': /* $^O */ + case '\020': /* $^P */ + case '\023': /* $^S */ + case '\024': /* $^T */ + case '\026': /* $^V */ + if (len == 1) + goto yes; + break; + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + if (len > 1) { + char *end = name + len; + while (--end > name) { + if (!isDIGIT(*end)) + return FALSE; + } + } + yes: + return TRUE; + default: + break; + } + return FALSE; } diff -ruN perl-5.6.0/hv.c AP618_source/hv.c --- perl-5.6.0/hv.c Wed Jul 5 14:34:13 2000 +++ AP618_source/hv.c Wed Aug 23 15:14:51 2000 @@ -42,9 +42,14 @@ { register HE* he; register HE* heend; - New(54, PL_he_root, 1008/sizeof(HE), HE); - he = PL_he_root; + XPV *ptr; + New(54, ptr, 1008/sizeof(XPV), XPV); + ptr->xpv_pv = (char*)PL_he_arenaroot; + PL_he_arenaroot = ptr; + + he = (HE*)ptr; heend = &he[1008 / sizeof(HE) - 1]; + PL_he_root = ++he; while (he < heend) { HeNEXT(he) = (HE*)(he + 1); he++; diff -ruN perl-5.6.0/intrpvar.h AP618_source/intrpvar.h --- perl-5.6.0/intrpvar.h Wed Jul 5 14:34:13 2000 +++ AP618_source/intrpvar.h Wed Aug 23 15:14:51 2000 @@ -245,19 +245,19 @@ PERLVAR(Isighandlerp, Sighandler_t) PERLVAR(Ixiv_arenaroot, XPV*) /* list of allocated xiv areas */ -PERLVAR(Ixiv_root, IV *) /* free xiv list--shared by interpreters */ -PERLVAR(Ixnv_root, NV *) /* free xnv list--shared by interpreters */ -PERLVAR(Ixrv_root, XRV *) /* free xrv list--shared by interpreters */ -PERLVAR(Ixpv_root, XPV *) /* free xpv list--shared by interpreters */ -PERLVAR(Ixpviv_root, XPVIV *) /* free xpviv list--shared by interpreters */ -PERLVAR(Ixpvnv_root, XPVNV *) /* free xpvnv list--shared by interpreters */ -PERLVAR(Ixpvcv_root, XPVCV *) /* free xpvcv list--shared by interpreters */ -PERLVAR(Ixpvav_root, XPVAV *) /* free xpvav list--shared by interpreters */ -PERLVAR(Ixpvhv_root, XPVHV *) /* free xpvhv list--shared by interpreters */ -PERLVAR(Ixpvmg_root, XPVMG *) /* free xpvmg list--shared by interpreters */ -PERLVAR(Ixpvlv_root, XPVLV *) /* free xpvlv list--shared by interpreters */ -PERLVAR(Ixpvbm_root, XPVBM *) /* free xpvbm list--shared by interpreters */ -PERLVAR(Ihe_root, HE *) /* free he list--shared by interpreters */ +PERLVAR(Ixiv_root, IV *) /* free xiv list */ +PERLVAR(Ixnv_root, NV *) /* free xnv list */ +PERLVAR(Ixrv_root, XRV *) /* free xrv list */ +PERLVAR(Ixpv_root, XPV *) /* free xpv list */ +PERLVAR(Ixpviv_root, XPVIV *) /* free xpviv list */ +PERLVAR(Ixpvnv_root, XPVNV *) /* free xpvnv list */ +PERLVAR(Ixpvcv_root, XPVCV *) /* free xpvcv list */ +PERLVAR(Ixpvav_root, XPVAV *) /* free xpvav list */ +PERLVAR(Ixpvhv_root, XPVHV *) /* free xpvhv list */ +PERLVAR(Ixpvmg_root, XPVMG *) /* free xpvmg list */ +PERLVAR(Ixpvlv_root, XPVLV *) /* free xpvlv list */ +PERLVAR(Ixpvbm_root, XPVBM *) /* free xpvbm list */ +PERLVAR(Ihe_root, HE *) /* free he list */ PERLVAR(Inice_chunk, char *) /* a nice chunk of memory to reuse */ PERLVAR(Inice_chunk_size, U32) /* how nice the chunk of memory is */ @@ -443,3 +443,22 @@ #if defined(USE_ITHREADS) PERLVAR(Iptr_table, PTR_TBL_t*) #endif + +PERLVAR(Inullstash, HV *) /* illegal symbols end up here */ + +PERLVAR(Ixnv_arenaroot, XPV*) /* list of allocated xnv areas */ +PERLVAR(Ixrv_arenaroot, XPV*) /* list of allocated xrv areas */ +PERLVAR(Ixpv_arenaroot, XPV*) /* list of allocated xpv areas */ +PERLVAR(Ixpviv_arenaroot,XPVIV*) /* list of allocated xpviv areas */ +PERLVAR(Ixpvnv_arenaroot,XPVNV*) /* list of allocated xpvnv areas */ +PERLVAR(Ixpvcv_arenaroot,XPVCV*) /* list of allocated xpvcv areas */ +PERLVAR(Ixpvav_arenaroot,XPVAV*) /* list of allocated xpvav areas */ +PERLVAR(Ixpvhv_arenaroot,XPVHV*) /* list of allocated xpvhv areas */ +PERLVAR(Ixpvmg_arenaroot,XPVMG*) /* list of allocated xpvmg areas */ +PERLVAR(Ixpvlv_arenaroot,XPVLV*) /* list of allocated xpvlv areas */ +PERLVAR(Ixpvbm_arenaroot,XPVBM*) /* list of allocated xpvbm areas */ +PERLVAR(Ihe_arenaroot, XPV*) /* list of allocated he areas */ + +/* New variables must be added to the very end for binary compatibility. + * XSUB.h provides wrapper functions via perlapi.h that make this + * irrelevant, but not all code may be expected to #include XSUB.h. */ diff -ruN perl-5.6.0/lib/Carp/Heavy.pm AP618_source/lib/Carp/Heavy.pm --- perl-5.6.0/lib/Carp/Heavy.pm Wed Jul 5 14:34:15 2000 +++ AP618_source/lib/Carp/Heavy.pm Wed Aug 23 15:14:52 2000 @@ -42,7 +42,7 @@ # # if the $error error string is newline terminated then it # is copied into $mess. Otherwise, $mess gets set (at the end of - # the 'else {' section below) to one of two things. The first time + # the 'else' section below) to one of two things. The first time # through, it is set to the "$error at $file line $line" message. # $error is then set to 'called' which triggers subsequent loop # iterations to append $sub to $mess before appending the "$error @@ -121,10 +121,7 @@ # $line" makes sense as "called at $file line $line". $error = "called"; } - # this kludge circumvents die's incorrect handling of NUL - my $msg = \($mess || $error); - $$msg =~ tr/\0//d; - $$msg; + $mess || $error; } @@ -227,9 +224,7 @@ } else { # OK! We've got a candidate package. Time to construct the - # relevant error message and return it. die() doesn't like - # to be given NUL characters (which $msg may contain) so we - # remove them first. + # relevant error message and return it. my $msg; $msg = "$error at $file line $line"; if (defined &Thread::tid) { @@ -237,7 +232,6 @@ $mess .= " thread $tid" if $tid; } $msg .= "\n"; - $msg =~ tr/\0//d; return $msg; } } diff -ruN perl-5.6.0/lib/Cwd.pm AP618_source/lib/Cwd.pm --- perl-5.6.0/lib/Cwd.pm Wed Jul 5 14:34:15 2000 +++ AP618_source/lib/Cwd.pm Wed Aug 23 15:14:52 2000 @@ -156,7 +156,7 @@ my $chdir_init = 0; sub chdir_init { - if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos') { + if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { @@ -164,10 +164,12 @@ } } else { - $ENV{'PWD'} = cwd(); + my $wd = cwd(); + $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32'; + $ENV{'PWD'} = $wd; } # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) - if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { + if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { my($pd,$pi) = stat($2); my($dd,$di) = stat($1); if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { @@ -179,10 +181,16 @@ sub chdir { my $newdir = shift || ''; # allow for no arg (chdir to HOME dir) - $newdir =~ s|///*|/|g; + $newdir =~ s|///*|/|g unless $^O eq 'MSWin32'; chdir_init() unless $chdir_init; return 0 unless CORE::chdir $newdir; - if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} } + if ($^O eq 'VMS') { + return $ENV{'PWD'} = $ENV{'DEFAULT'} + } + elsif ($^O eq 'MSWin32') { + $ENV{'PWD'} = Win32::GetFullPathName($newdir); + return 1; + } if ($newdir =~ m#^/#s) { $ENV{'PWD'} = $newdir; diff -ruN perl-5.6.0/lib/English.pm AP618_source/lib/English.pm --- perl-5.6.0/lib/English.pm Wed Jul 5 14:34:15 2000 +++ AP618_source/lib/English.pm Wed Aug 23 15:14:52 2000 @@ -98,6 +98,8 @@ *OSNAME *LAST_REGEXP_CODE_RESULT *EXCEPTIONS_BEING_CAUGHT + @LAST_MATCH_START + @LAST_MATCH_END ); # The ground of all being. @ARG is deprecated (5.005 makes @_ lexical) @@ -110,6 +112,8 @@ *PREMATCH = *` ; *POSTMATCH = *' ; *LAST_PAREN_MATCH = *+ ; + *LAST_MATCH_START = *-{ARRAY} ; + *LAST_MATCH_END = *+{ARRAY} ; # Input. diff -ruN perl-5.6.0/lib/ExtUtils/Liblist.pm AP618_source/lib/ExtUtils/Liblist.pm --- perl-5.6.0/lib/ExtUtils/Liblist.pm Wed Jul 5 14:34:16 2000 +++ AP618_source/lib/ExtUtils/Liblist.pm Wed Aug 23 15:14:53 2000 @@ -230,6 +230,10 @@ # add "$Config{installarchlib}/CORE" to default search path push @libpath, "$Config{installarchlib}/CORE"; + if ($VC and exists $ENV{LIB} and $ENV{LIB}) { + push @libpath, split /;/, $ENV{LIB}; + } + foreach (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){ $thislib = $_; diff -ruN perl-5.6.0/lib/ExtUtils/MM_Unix.pm AP618_source/lib/ExtUtils/MM_Unix.pm --- perl-5.6.0/lib/ExtUtils/MM_Unix.pm Wed Jul 5 14:34:16 2000 +++ AP618_source/lib/ExtUtils/MM_Unix.pm Wed Aug 23 15:14:53 2000 @@ -1249,11 +1249,6 @@ next; } my($dev,$ino,$mode) = stat FIXIN; - # If they override perm_rwx, we won't notice it during fixin, - # because fixin is run through a new instance of MakeMaker. - # That is why we must run another CHMOD later. - $mode = oct($self->perm_rwx) unless $dev; - chmod $mode, $file; # Print out the new #! line (or equivalent). local $\; @@ -1261,7 +1256,15 @@ print FIXOUT $shb, ; close FIXIN; close FIXOUT; - # can't rename open files on some DOSISH platforms + + # can't rename/chmod open files on some DOSISH platforms + + # If they override perm_rwx, we won't notice it during fixin, + # because fixin is run through a new instance of MakeMaker. + # That is why we must run another CHMOD later. + $mode = oct($self->perm_rwx) unless $dev; + chmod $mode, $file; + unless ( rename($file, "$file.bak") ) { warn "Can't rename $file to $file.bak: $!"; next; @@ -1276,6 +1279,7 @@ } unlink "$file.bak"; } continue { + close(FIXIN) if fileno(FIXIN); chmod oct($self->perm_rwx), $file or die "Can't reset permissions for $file: $!\n"; system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';; diff -ruN perl-5.6.0/lib/ExtUtils/MakeMaker.pm AP618_source/lib/ExtUtils/MakeMaker.pm --- perl-5.6.0/lib/ExtUtils/MakeMaker.pm Wed Jul 5 14:34:17 2000 +++ AP618_source/lib/ExtUtils/MakeMaker.pm Wed Aug 23 15:14:53 2000 @@ -189,7 +189,7 @@ AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE FULLPERL FUNCLIST H - HTMLLIBPODS HTMLSCRIPTPOD IMPORTS + HTMLLIBPODS HTMLSCRIPTPODS IMPORTS INC INCLUDE_EXT INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLHTMLPRIVLIBDIR INSTALLHTMLSCRIPTDIR INSTALLHTMLSITELIBDIR INSTALLMAN1DIR INSTALLMAN3DIR INSTALLPRIVLIB INSTALLSCRIPT INSTALLSITEARCH diff -ruN perl-5.6.0/lib/File/Find.pm AP618_source/lib/File/Find.pm --- perl-5.6.0/lib/File/Find.pm Wed Jul 5 14:34:17 2000 +++ AP618_source/lib/File/Find.pm Wed Aug 23 15:14:53 2000 @@ -584,12 +584,24 @@ while (defined $SE) { unless ($bydepth) { + # change to parent directory + unless ($no_chdir) { + my $udir = $pdir_loc; + if ($untaint) { + $udir = $1 if $pdir_loc =~ m|$untaint_pat|; + } + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + next; + } + } $dir= $p_dir; $name= $dir_name; $_= ($no_chdir ? $dir_name : $dir_rel ); $fullname= $dir_loc; # prune may happen here $prune= 0; + lstat($_); # make sure file tests with '_' work &$wanted_callback; next if $prune; } @@ -673,6 +685,7 @@ s|/\.$||; } + lstat($_); # make sure file tests with '_' work &$wanted_callback; } else { push @Stack,[$dir_loc, $pdir_loc, $p_dir, $dir_rel,-1] if $bydepth; diff -ruN perl-5.6.0/lib/Math/Complex.pm AP618_source/lib/Math/Complex.pm --- perl-5.6.0/lib/Math/Complex.pm Wed Jul 5 14:34:18 2000 +++ AP618_source/lib/Math/Complex.pm Wed Aug 23 15:14:53 2000 @@ -1373,7 +1373,6 @@ 1; __END__ -=pod =head1 NAME Math::Complex - complex numbers and associated mathematical functions diff -ruN perl-5.6.0/lib/perl5db.pl AP618_source/lib/perl5db.pl --- perl-5.6.0/lib/perl5db.pl Wed Jul 5 14:34:20 2000 +++ AP618_source/lib/perl5db.pl Wed Aug 23 15:14:54 2000 @@ -980,18 +980,18 @@ next CMD; }; $cmd =~ /^<\s*(.*)/ && do { unless ($1) { - print OUT "All < actions cleared.\n"; + print $OUT "All < actions cleared.\n"; $pre = []; next CMD; } if ($1 eq '?') { unless (@$pre) { - print OUT "No pre-prompt Perl actions.\n"; + print $OUT "No pre-prompt Perl actions.\n"; next CMD; } - print OUT "Perl commands run before each prompt:\n"; + print $OUT "Perl commands run before each prompt:\n"; for my $action ( @$pre ) { - print "\t< -- $action\n"; + print $OUT "\t< -- $action\n"; } next CMD; } @@ -999,18 +999,18 @@ next CMD; }; $cmd =~ /^>\s*(.*)/ && do { unless ($1) { - print OUT "All > actions cleared.\n"; + print $OUT "All > actions cleared.\n"; $post = []; next CMD; } if ($1 eq '?') { unless (@$post) { - print OUT "No post-prompt Perl actions.\n"; + print $OUT "No post-prompt Perl actions.\n"; next CMD; } - print OUT "Perl commands run after each prompt:\n"; + print $OUT "Perl commands run after each prompt:\n"; for my $action ( @$post ) { - print "\t> -- $action\n"; + print $OUT "\t> -- $action\n"; } next CMD; } @@ -1018,7 +1018,7 @@ next CMD; }; $cmd =~ /^\{\{\s*(.*)/ && do { if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) { - print OUT "{{ is now a debugger command\n", + print $OUT "{{ is now a debugger command\n", "use `;{{' if you mean Perl code\n"; $cmd = "h {{"; redo CMD; @@ -1027,23 +1027,23 @@ next CMD; }; $cmd =~ /^\{\s*(.*)/ && do { unless ($1) { - print OUT "All { actions cleared.\n"; + print $OUT "All { actions cleared.\n"; $pretype = []; next CMD; } if ($1 eq '?') { unless (@$pretype) { - print OUT "No pre-prompt debugger actions.\n"; + print $OUT "No pre-prompt debugger actions.\n"; next CMD; } - print OUT "Debugger commands run before each prompt:\n"; + print $OUT "Debugger commands run before each prompt:\n"; for my $action ( @$pretype ) { - print "\t{ -- $action\n"; + print $OUT "\t{ -- $action\n"; } next CMD; } if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) { - print OUT "{ is now a debugger command\n", + print $OUT "{ is now a debugger command\n", "use `;{' if you mean Perl code\n"; $cmd = "h {"; redo CMD; @@ -1815,7 +1815,7 @@ local $frame = 0; local $doret = -2; if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) { - print $OUT @_; + $OUT->write(join('', @_)); my $stuff; $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread? $stuff; diff -ruN perl-5.6.0/lib/vars.pm AP618_source/lib/vars.pm --- perl-5.6.0/lib/vars.pm Wed Jul 5 14:34:28 2000 +++ AP618_source/lib/vars.pm Wed Aug 23 15:14:55 2000 @@ -8,7 +8,8 @@ # if Carp hasn't been loaded in earlier compile time. :-( # We'll let those bugs get found on the development track. require Carp if $] < 5.00450; -use warnings::register(); + +use warnings::register; sub import { my $callpack = caller; diff -ruN perl-5.6.0/makedef.pl AP618_source/makedef.pl --- perl-5.6.0/makedef.pl Wed Jul 5 14:34:28 2000 +++ AP618_source/makedef.pl Wed Aug 23 15:14:55 2000 @@ -259,7 +259,9 @@ Perl_safexrealloc Perl_same_dirent Perl_unlnk + Perl_sys_intern_clear Perl_sys_intern_dup + Perl_sys_intern_init PL_cryptseen PL_opsave PL_statusvalue_vms diff -ruN perl-5.6.0/mg.c AP618_source/mg.c --- perl-5.6.0/mg.c Wed Jul 5 14:34:28 2000 +++ AP618_source/mg.c Wed Aug 23 15:14:55 2000 @@ -1735,7 +1735,7 @@ PL_compiling.cop_warnings = pWARN_NONE; break; } - if (isWARN_on(sv, WARN_ALL)) { + if (isWARN_on(sv, WARN_ALL) && !isWARNf_on(sv, WARN_ALL)) { PL_compiling.cop_warnings = pWARN_ALL; PL_dowarn |= G_WARN_ONCE ; } @@ -2100,7 +2100,11 @@ Signal_t Perl_sighandler(int sig) { +#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) + dTHXoa(PL_curinterp); /* fake TLS, because signals don't do TLS */ +#else dTHX; +#endif dSP; GV *gv = Nullgv; HV *st; @@ -2110,6 +2114,10 @@ U32 flags = 0; I32 o_save_i = PL_savestack_ix; XPV *tXpv = PL_Xpv; + +#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) + PERL_SET_THX(aTHXo); /* fake TLS, see above */ +#endif if (PL_savestack_ix + 15 <= PL_savestack_max) flags |= 1; diff -ruN perl-5.6.0/objXSUB.h AP618_source/objXSUB.h --- perl-5.6.0/objXSUB.h Wed Jul 5 14:34:29 2000 +++ AP618_source/objXSUB.h Wed Aug 23 15:14:55 2000 @@ -313,6 +313,10 @@ #endif #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) #endif +#undef Perl_do_join +#define Perl_do_join pPerl->Perl_do_join +#undef do_join +#define do_join Perl_do_join #undef Perl_do_open #define Perl_do_open pPerl->Perl_do_open #undef do_open @@ -1279,6 +1283,10 @@ #define Perl_rninstr pPerl->Perl_rninstr #undef rninstr #define rninstr Perl_rninstr +#undef Perl_rsignal +#define Perl_rsignal pPerl->Perl_rsignal +#undef rsignal +#define rsignal Perl_rsignal #if !defined(HAS_RENAME) #endif #undef Perl_savepv @@ -1337,6 +1345,10 @@ #define Perl_save_generic_svref pPerl->Perl_save_generic_svref #undef save_generic_svref #define save_generic_svref Perl_save_generic_svref +#undef Perl_save_generic_pvref +#define Perl_save_generic_pvref pPerl->Perl_save_generic_pvref +#undef save_generic_pvref +#define save_generic_pvref Perl_save_generic_pvref #undef Perl_save_gp #define Perl_save_gp pPerl->Perl_save_gp #undef save_gp @@ -1861,6 +1873,10 @@ #define Perl_vwarner pPerl->Perl_vwarner #undef vwarner #define vwarner Perl_vwarner +#undef Perl_whichsig +#define Perl_whichsig pPerl->Perl_whichsig +#undef whichsig +#define whichsig Perl_whichsig #if defined(USE_PURE_BISON) #else #endif @@ -2171,6 +2187,16 @@ #define Perl_ptr_table_split pPerl->Perl_ptr_table_split #undef ptr_table_split #define ptr_table_split Perl_ptr_table_split +#endif +#if defined(HAVE_INTERP_INTERN) +#undef Perl_sys_intern_clear +#define Perl_sys_intern_clear pPerl->Perl_sys_intern_clear +#undef sys_intern_clear +#define sys_intern_clear Perl_sys_intern_clear +#undef Perl_sys_intern_init +#define Perl_sys_intern_init pPerl->Perl_sys_intern_init +#undef sys_intern_init +#define sys_intern_init Perl_sys_intern_init #endif #if defined(PERL_OBJECT) #else diff -ruN perl-5.6.0/op.c AP618_source/op.c --- perl-5.6.0/op.c Wed Jul 5 14:34:29 2000 +++ AP618_source/op.c Wed Sep 13 15:48:54 2000 @@ -162,6 +162,7 @@ do { if ((sv = svp[off]) && sv != &PL_sv_undef + && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0) && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash) && strEQ(name, SvPVX(sv))) { @@ -321,9 +322,12 @@ } } else if (!CvUNIQUE(PL_compcv)) { - if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)) + if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv) + && !(SvFLAGS(sv) & SVpad_OUR)) + { Perl_warner(aTHX_ WARN_CLOSURE, "Variable \"%s\" will not stay shared", name); + } } } av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv)); @@ -780,6 +784,7 @@ cSVOPo->op_sv = Nullsv; #endif break; + case OP_METHOD_NAMED: case OP_CONST: SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = Nullsv; @@ -839,8 +844,8 @@ { Safefree(cop->cop_label); #ifdef USE_ITHREADS - Safefree(CopFILE(cop)); /* XXXXX share in a pvtable? */ - Safefree(CopSTASHPV(cop)); /* XXXXX share in a pvtable? */ + Safefree(CopFILE(cop)); /* XXX share in a pvtable? */ + Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */ #else /* NOTE: COP.cop_stash is not refcounted */ SvREFCNT_dec(CopFILEGV(cop)); @@ -3222,8 +3227,15 @@ sv = va_arg(*args, SV*); } } - utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), - veop, modname, imop); + { + line_t ocopline = PL_copline; + int oexpect = PL_expect; + + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); + PL_expect = oexpect; + PL_copline = ocopline; + } } OP * @@ -3366,7 +3378,11 @@ } else if (curop->op_type == OP_PUSHRE) { if (((PMOP*)curop)->op_pmreplroot) { +#ifdef USE_ITHREADS + GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot]; +#else GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; +#endif if (gv == PL_defgv || SvCUR(gv) == PL_generation) break; SvCUR(gv) = PL_generation; @@ -3486,9 +3502,9 @@ PL_copline = NOLINE; } #ifdef USE_ITHREADS - CopFILE_set(cop, CopFILE(PL_curcop)); /* XXXXX share in a pvtable? */ + CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ #else - CopFILEGV_set(cop, (GV*)SvREFCNT_inc(CopFILEGV(PL_curcop))); + CopFILEGV_set(cop, CopFILEGV(PL_curcop)); #endif CopSTASH_set(cop, PL_curstash); @@ -3848,7 +3864,10 @@ loopflags |= OPpLOOP_CONTINUE; } if (expr) { - cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0)); + OP *unstack = newOP(OP_UNSTACK, 0); + if (!next) + next = unstack; + cont = append_elem(OP_LINESEQ, cont, unstack); if ((line_t)whileline != NOLINE) { PL_copline = whileline; cont = append_elem(OP_LINESEQ, cont, @@ -3871,8 +3890,6 @@ if (listop) ((LISTOP*)listop)->op_last->op_next = condop = (o == listop ? redo : LINKLIST(o)); - if (!next) - next = condop; } else o = listop; @@ -4636,8 +4653,8 @@ if (!PL_beginav) PL_beginav = newAV(); DEBUG_x( dump_sub(gv) ); - av_push(PL_beginav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_beginav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ call_list(oldscope, PL_beginav); PL_curcop = &PL_compiling; @@ -4649,8 +4666,8 @@ PL_endav = newAV(); DEBUG_x( dump_sub(gv) ); av_unshift(PL_endav, 1); - av_store(PL_endav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_store(PL_endav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "CHECK") && !PL_error_count) { if (!PL_checkav) @@ -4659,8 +4676,8 @@ if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); av_unshift(PL_checkav, 1); - av_store(PL_checkav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_store(PL_checkav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "INIT") && !PL_error_count) { if (!PL_initav) @@ -4668,8 +4685,8 @@ DEBUG_x( dump_sub(gv) ); if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); - av_push(PL_initav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_initav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } } @@ -4695,10 +4712,11 @@ dTHR; ENTER; - SAVECOPLINE(PL_curcop); - SAVEHINTS(); + SAVECOPLINE(PL_curcop); CopLINE_set(PL_curcop, PL_copline); + + SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) { @@ -4795,15 +4813,15 @@ if (strEQ(s, "BEGIN")) { if (!PL_beginav) PL_beginav = newAV(); - av_push(PL_beginav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_beginav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "END")) { if (!PL_endav) PL_endav = newAV(); av_unshift(PL_endav, 1); - av_store(PL_endav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_store(PL_endav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "CHECK")) { if (!PL_checkav) @@ -4811,16 +4829,16 @@ if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); av_unshift(PL_checkav, 1); - av_store(PL_checkav, 0, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_store(PL_checkav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "INIT")) { if (!PL_initav) PL_initav = newAV(); if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); - av_push(PL_initav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + av_push(PL_initav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } } else @@ -5324,6 +5342,7 @@ #ifdef USE_ITHREADS /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); + SvREFCNT_dec(PL_curpad[kPADOP->op_padix]); GvIN_PAD_on(gv); PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv); #else @@ -5994,6 +6013,7 @@ OP * Perl_ck_sort(pTHX_ OP *o) { + OP *firstkid; o->op_private = 0; #ifdef USE_LOCALE if (PL_hints & HINT_LOCALE) @@ -6002,10 +6022,10 @@ if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) simplify_sort(o); - if (o->op_flags & OPf_STACKED) { /* may have been cleared */ - OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + if (o->op_flags & OPf_STACKED) { /* may have been cleared */ OP *k; - kid = kUNOP->op_first; /* get past null */ + OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { linklist(kid); @@ -6035,17 +6055,26 @@ } peep(k); - kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ - if (o->op_type == OP_SORT) + kid = firstkid; + if (o->op_type == OP_SORT) { + /* provide scalar context for comparison function/block */ + kid = scalar(kid); kid->op_next = kid; + } else kid->op_next = k; o->op_flags |= OPf_SPECIAL; } else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) - null(cLISTOPo->op_first->op_sibling); + null(firstkid); + + firstkid = firstkid->op_sibling; } + /* provide list context for arguments */ + if (o->op_type == OP_SORT) + list(firstkid); + return o; } @@ -6251,7 +6280,9 @@ proto++; arg++; if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF) - bad_type(arg, "block", gv_ename(namegv), o2); + bad_type(arg, + arg == 1 ? "block or sub {}" : "sub {}", + gv_ename(namegv), o2); break; case '*': /* '*' allows any scalar type, including bareword */ @@ -6299,8 +6330,8 @@ bad_type(arg, "symbol", gv_ename(namegv), o2); goto wrapref; case '&': - if (o2->op_type != OP_RV2CV) - bad_type(arg, "sub", gv_ename(namegv), o2); + if (o2->op_type != OP_ENTERSUB) + bad_type(arg, "subroutine entry", gv_ename(namegv), o2); goto wrapref; case '$': if (o2->op_type != OP_RV2SV @@ -6417,9 +6448,18 @@ * for reference counts, sv_upgrade() etc. */ if (cSVOP->op_sv) { PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); - SvREFCNT_dec(PL_curpad[ix]); - SvPADTMP_on(cSVOPo->op_sv); - PL_curpad[ix] = cSVOPo->op_sv; + if (SvPADTMP(cSVOPo->op_sv)) { + /* If op_sv is already a PADTMP then it is being used by + * another pad, so make a copy. */ + sv_setsv(PL_curpad[ix],cSVOPo->op_sv); + SvREADONLY_on(PL_curpad[ix]); + SvREFCNT_dec(cSVOPo->op_sv); + } + else { + SvREFCNT_dec(PL_curpad[ix]); + SvPADTMP_on(cSVOPo->op_sv); + PL_curpad[ix] = cSVOPo->op_sv; + } cSVOPo->op_sv = Nullsv; o->op_targ = ix; } diff -ruN perl-5.6.0/patchlevel.h AP618_source/patchlevel.h --- perl-5.6.0/patchlevel.h Wed Jul 5 14:34:30 2000 +++ AP618_source/patchlevel.h Wed Aug 23 15:14:56 2000 @@ -1,5 +1,7 @@ #ifndef __PATCHLEVEL_H_INCLUDED__ +#include "BuildInfo.h" + /* do not adjust the whitespace! Configure expects the numbers to be * exactly on the third column */ @@ -70,6 +72,7 @@ #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) static char *local_patches[] = { NULL + ,ACTIVEPERL_LOCAL_PATCHES_ENTRY ,NULL }; diff -ruN perl-5.6.0/perl.c AP618_source/perl.c --- perl-5.6.0/perl.c Wed Jul 5 14:34:30 2000 +++ AP618_source/perl.c Wed Aug 23 15:14:56 2000 @@ -272,10 +272,15 @@ PL_localpatches = local_patches; /* For possible -v */ #endif +#ifdef HAVE_INTERP_INTERN + sys_intern_init(); +#endif + PerlIO_init(); /* Hook to IO system */ PL_fdpid = newAV(); /* for remembering popen pids by fd */ PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ + PL_errors = newSVpvn("",0); ENTER; } @@ -595,9 +600,14 @@ if (!specialWARN(PL_compiling.cop_warnings)) SvREFCNT_dec(PL_compiling.cop_warnings); PL_compiling.cop_warnings = Nullsv; -#ifndef USE_ITHREADS +#ifdef USE_ITHREADS + Safefree(CopFILE(&PL_compiling)); + CopFILE(&PL_compiling) = Nullch; + Safefree(CopSTASHPV(&PL_compiling)); +#else SvREFCNT_dec(CopFILEGV(&PL_compiling)); - CopFILEGV_set(&PL_compiling, Nullgv); + CopFILEGV(&PL_compiling) = Nullgv; + /* cop_stash is not refcounted */ #endif /* Prepare to destruct main symbol table. */ @@ -647,6 +657,10 @@ SvREFCNT_dec(PL_fdpid); /* needed in io_close() */ PL_fdpid = Nullav; +#ifdef HAVE_INTERP_INTERN + sys_intern_clear(); +#endif + /* Destruct the global string table. */ { /* Yell and reset the HeVAL() slots that are still holding refcounts, @@ -696,9 +710,6 @@ if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count); - sv_free_arenas(); - - /* No SVs have survived, need to clean out */ Safefree(PL_origfilename); Safefree(PL_reg_start_tmp); if (PL_reg_curpm) @@ -706,6 +717,8 @@ Safefree(PL_reg_poscache); Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh)); Safefree(PL_op_mask); + Safefree(PL_psig_ptr); + Safefree(PL_psig_name); nuke_stacks(); PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ @@ -727,6 +740,8 @@ PL_thrsv = Nullsv; #endif /* USE_THREADS */ + sv_free_arenas(); + /* As the absolutely last thing, free the non-arena SV for mess() */ if (PL_mess_sv) { @@ -1565,18 +1580,7 @@ /* name of the subroutine */ /* See G_* flags in cop.h */ { - dSP; - OP myop; - if (!PL_op) { - Zero(&myop, 1, OP); - PL_op = &myop; - } - XPUSHs(sv_2mortal(newSVpv(methname,0))); - PUTBACK; - pp_method(); - if (PL_op == &myop) - PL_op = Nullop; - return call_sv(*PL_stack_sp--, flags); + return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD); } /* May be called with any of a CV, a GV, or an SV containing the name. */ @@ -1591,11 +1595,11 @@ I32 Perl_call_sv(pTHX_ SV *sv, I32 flags) - /* See G_* flags in cop.h */ { dSP; LOGOP myop; /* fake syntax tree node */ + UNOP method_op; I32 oldmark; I32 retval; I32 oldscope; @@ -1633,6 +1637,14 @@ && !(flags & G_NODEBUG)) PL_op->op_private |= OPpENTERSUB_DB; + if (flags & G_METHOD) { + Zero(&method_op, 1, UNOP); + method_op.op_next = PL_op; + method_op.op_ppaddr = PL_ppaddr[OP_METHOD]; + myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; + PL_op = (OP*)&method_op; + } + if (!(flags & G_EVAL)) { CATCH_SET(TRUE); call_body((OP*)&myop, FALSE); @@ -1640,7 +1652,7 @@ CATCH_SET(oldcatch); } else { - cLOGOP->op_other = PL_op; + myop.op_other = (OP*)&myop; PL_markstack_ptr--; /* we're trying to emulate pp_entertry() here */ { @@ -1650,7 +1662,7 @@ ENTER; SAVETMPS; - push_return(PL_op->op_next); + push_return(Nullop); PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); PUSHEVAL(cx, 0, 0); PL_eval_root = PL_op; /* Only needed so that goto works right. */ @@ -1753,9 +1765,9 @@ if (PL_op == myop) { if (is_eval) - PL_op = Perl_pp_entereval(aTHX); + PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */ else - PL_op = Perl_pp_entersub(aTHX); + PL_op = Perl_pp_entersub(aTHX); /* this does */ } if (PL_op) CALLRUNOPS(aTHX); @@ -1877,7 +1889,6 @@ dSP; SV* sv = newSVpv(p, 0); - PUSHMARK(SP); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); @@ -1938,7 +1949,7 @@ "-0[octal] specify record separator (\\0, if no argument)", "-a autosplit mode with -n or -p (splits $_ into @F)", "-C enable native wide character system interfaces", -"-c check syntax only (runs BEGIN and END blocks)", +"-c check syntax only (runs BEGIN and CHECK blocks)", "-d[:debugger] run program under debugger", "-D[number/list] set debugging flags (argument is a bit mask or alphabets)", "-e 'command' one line of program (several -e's allowed, omit programfile)", @@ -1966,9 +1977,11 @@ }; char **p = usage_msg; - printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name); + PerlIO_printf(PerlIO_stdout(), + "\nUsage: %s [switches] [--] [programfile] [arguments]", + name); while (*p) - printf("\n %s", *p++); + PerlIO_printf(PerlIO_stdout(), "\n %s", *p++); } /* This routine handles any switches that can be given during run */ @@ -1983,6 +1996,7 @@ case '0': { dTHR; + numlen = 0; /* disallow underscores */ rschar = (U32)scan_oct(s, 4, &numlen); SvREFCNT_dec(PL_nrs); if (rschar & ~((U8)~0)) @@ -2098,6 +2112,7 @@ if (isDIGIT(*s)) { PL_ors = savepv("\n"); PL_orslen = 1; + numlen = 0; /* disallow underscores */ *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen); s += numlen; } @@ -2175,57 +2190,75 @@ s++; return s; case 'v': - printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s", - PL_patchlevel, ARCHNAME)); + PerlIO_printf(PerlIO_stdout(), + Perl_form(aTHX_ "\nThis is perl, v%vd built for %s", + PL_patchlevel, ARCHNAME)); #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) - printf("\n(with %d registered patch%s, see perl -V for more detail)", - (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); + PerlIO_printf(PerlIO_stdout(), + "\n(with %d registered patch%s, " + "see perl -V for more detail)", + (int)LOCAL_PATCH_COUNT, + (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - printf("\n\nCopyright 1987-2000, Larry Wall\n"); + PerlIO_printf(PerlIO_stdout(), + "\n\nCopyright 1987-2000, Larry Wall\n"); #ifdef MSDOS - printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); + PerlIO_printf(PerlIO_stdout(), + "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif #ifdef DJGPP - printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"); - printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n" + "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); #endif #ifdef OS2 - printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" - "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n"); + PerlIO_printf(PerlIO_stdout(), + "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" + "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef atarist - printf("atariST series port, ++jrb bammi@cadence.com\n"); + PerlIO_printf(PerlIO_stdout(), + "atariST series port, ++jrb bammi@cadence.com\n"); #endif #ifdef __BEOS__ - printf("BeOS port Copyright Tom Spindler, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "BeOS port Copyright Tom Spindler, 1997-1999\n"); #endif #ifdef MPE - printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n"); #endif #ifdef OEMVS - printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); #endif #ifdef __VOS__ - printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n"); #endif #ifdef __OPEN_VM - printf("VM/ESA port by Neale Ferguson, 1998-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "VM/ESA port by Neale Ferguson, 1998-1999\n"); #endif #ifdef POSIX_BC - printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); #endif #ifdef __MINT__ - printf("MiNT port by Guido Flohr, 1997-1999\n"); + PerlIO_printf(PerlIO_stdout(), + "MiNT port by Guido Flohr, 1997-1999\n"); #endif #ifdef EPOC - printf("EPOC port by Olaf Flebbe, 1999-2000\n"); + PerlIO_printf(PerlIO_stdout(), + "EPOC port by Olaf Flebbe, 1999-2000\n"); #endif #ifdef BINARY_BUILD_NOTICE BINARY_BUILD_NOTICE; #endif - printf("\n\ + PerlIO_printf(PerlIO_stdout(), + "\n\ Perl may be copied only under the terms of either the Artistic License or the\n\ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\ Complete documentation for Perl, including FAQ lists, should be found on\n\ @@ -2425,6 +2458,7 @@ CopSTASH_set(&PL_compiling, PL_defstash); PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV)); + PL_nullstash = GvHV(gv_fetchpv("::", GV_ADDMULTI, SVt_PVHV)); /* We must init $/ before switches are processed. */ sv_setpvn(get_sv("/", TRUE), "\n", 1); } @@ -2456,6 +2490,11 @@ } } +#ifdef USE_ITHREADS + Safefree(CopFILE(PL_curcop)); +#else + SvREFCNT_dec(CopFILEGV(PL_curcop)); +#endif CopFILE_set(PL_curcop, PL_origfilename); if (strEQ(PL_origfilename,"-")) scriptname = ""; @@ -2478,7 +2517,7 @@ sv_catpvn(sv, "-I", 2); sv_catpv(sv,PRIVLIB_EXP); -#ifdef MSDOS +#if defined(MSDOS) || defined(WIN32) Perl_sv_setpvf(aTHX_ cmd, "\ sed %s -e \"/^[^#]/b\" \ -e \"/^#[ ]*include[ ]/b\" \ @@ -3180,7 +3219,7 @@ SV *sv = newSVpv(argv[0],0); av_push(GvAVn(PL_argvgv),sv); if (PL_widesyscalls) - sv_utf8_upgrade(sv); + (void)sv_utf8_decode(sv); } } if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) { diff -ruN perl-5.6.0/perl.h AP618_source/perl.h --- perl-5.6.0/perl.h Wed Jul 5 14:34:30 2000 +++ AP618_source/perl.h Tue Aug 29 21:57:51 2000 @@ -164,8 +164,8 @@ #define aTHXo_ this, #define PERL_OBJECT_THIS aTHXo #define PERL_OBJECT_THIS_ aTHXo_ -#define dTHXoa(a) pTHXo = a -#define dTHXo dTHXoa(PERL_GET_THX) +#define dTHXoa(a) pTHXo = (CPerlObj*)a +#define dTHXo pTHXo = PERL_GET_THX #define pTHXx void #define pTHXx_ @@ -180,15 +180,16 @@ # define pTHX register struct perl_thread *thr # define aTHX thr # define dTHR dNOOP +# define dTHXa(a) pTHX = (struct perl_thread*)a # else # ifndef MULTIPLICITY # define MULTIPLICITY # endif # define pTHX register PerlInterpreter *my_perl # define aTHX my_perl +# define dTHXa(a) pTHX = (PerlInterpreter*)a # endif -# define dTHXa(a) pTHX = a -# define dTHX dTHXa(PERL_GET_THX) +# define dTHX pTHX = PERL_GET_THX # define pTHX_ pTHX, # define aTHX_ aTHX, # define pTHX_1 2 @@ -242,6 +243,7 @@ # define aTHXo aTHX # define aTHXo_ aTHX_ # define dTHXo dTHX +# define dTHXoa(x) dTHXa(x) #endif #ifndef pTHXx @@ -3067,8 +3069,20 @@ ((PL_hints & HINT_LOCALE) && \ PL_numeric_radix && (c) == PL_numeric_radix) -#define RESTORE_NUMERIC_LOCAL() if ((PL_hints & HINT_LOCALE) && PL_numeric_standard) SET_NUMERIC_LOCAL() -#define RESTORE_NUMERIC_STANDARD() if ((PL_hints & HINT_LOCALE) && PL_numeric_local) SET_NUMERIC_STANDARD() +#define STORE_NUMERIC_LOCAL_SET_STANDARD() \ + bool was_local = (PL_hints & HINT_LOCALE) && PL_numeric_local; \ + if (!was_local) SET_NUMERIC_STANDARD(); + +#define STORE_NUMERIC_STANDARD_SET_LOCAL() \ + bool was_standard = !(PL_hints & HINT_LOCALE) || PL_numeric_standard; \ + if (!was_standard) SET_NUMERIC_LOCAL(); + +#define RESTORE_NUMERIC_LOCAL() \ + if (was_local) SET_NUMERIC_LOCAL(); + +#define RESTORE_NUMERIC_STANDARD() \ + if (was_standard) SET_NUMERIC_STANDARD(); + #define Atof my_atof #else /* !USE_LOCALE_NUMERIC */ @@ -3076,6 +3090,8 @@ #define SET_NUMERIC_STANDARD() /**/ #define SET_NUMERIC_LOCAL() /**/ #define IS_NUMERIC_RADIX(c) (0) +#define STORE_NUMERIC_LOCAL_SET_STANDARD() /**/ +#define STORE_NUMERIC_STANDARD_SET_LOCAL() /**/ #define RESTORE_NUMERIC_LOCAL() /**/ #define RESTORE_NUMERIC_STANDARD() /**/ #define Atof Perl_atof diff -ruN perl-5.6.0/perlapi.c AP618_source/perlapi.c --- perl-5.6.0/perlapi.c Wed Jul 5 14:34:31 2000 +++ AP618_source/perlapi.c Wed Aug 23 15:14:56 2000 @@ -616,9 +616,9 @@ #undef Perl_do_binmode int -Perl_do_binmode(pTHXo_ PerlIO *fp, int iotype, int flag) +Perl_do_binmode(pTHXo_ PerlIO *fp, int iotype, int mode) { - return ((CPerlObj*)pPerl)->Perl_do_binmode(fp, iotype, flag); + return ((CPerlObj*)pPerl)->Perl_do_binmode(fp, iotype, mode); } #undef Perl_do_close @@ -632,6 +632,13 @@ #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) #endif +#undef Perl_do_join +void +Perl_do_join(pTHXo_ SV* sv, SV* del, SV** mark, SV** sp) +{ + ((CPerlObj*)pPerl)->Perl_do_join(sv, del, mark, sp); +} + #undef Perl_do_open bool Perl_do_open(pTHXo_ GV* gv, char* name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO* supplied_fp) @@ -2343,6 +2350,13 @@ { return ((CPerlObj*)pPerl)->Perl_rninstr(big, bigend, little, lend); } + +#undef Perl_rsignal +Sighandler_t +Perl_rsignal(pTHXo_ int i, Sighandler_t t) +{ + return ((CPerlObj*)pPerl)->Perl_rsignal(i, t); +} #if !defined(HAS_RENAME) #endif @@ -2444,6 +2458,13 @@ ((CPerlObj*)pPerl)->Perl_save_generic_svref(sptr); } +#undef Perl_save_generic_pvref +void +Perl_save_generic_pvref(pTHXo_ char** str) +{ + ((CPerlObj*)pPerl)->Perl_save_generic_pvref(str); +} + #undef Perl_save_gp void Perl_save_gp(pTHXo_ GV* gv, I32 empty) @@ -3366,6 +3387,13 @@ { ((CPerlObj*)pPerl)->Perl_vwarner(err, pat, args); } + +#undef Perl_whichsig +I32 +Perl_whichsig(pTHXo_ char* sig) +{ + return ((CPerlObj*)pPerl)->Perl_whichsig(sig); +} #if defined(USE_PURE_BISON) #else #endif @@ -3920,6 +3948,22 @@ Perl_ptr_table_split(pTHXo_ PTR_TBL_t *tbl) { ((CPerlObj*)pPerl)->Perl_ptr_table_split(tbl); +} +#endif +#if defined(HAVE_INTERP_INTERN) + +#undef Perl_sys_intern_clear +void +Perl_sys_intern_clear(pTHXo) +{ + ((CPerlObj*)pPerl)->Perl_sys_intern_clear(); +} + +#undef Perl_sys_intern_init +void +Perl_sys_intern_init(pTHXo) +{ + ((CPerlObj*)pPerl)->Perl_sys_intern_init(); } #endif #if defined(PERL_OBJECT) diff -ruN perl-5.6.0/perlapi.h AP618_source/perlapi.h --- perl-5.6.0/perlapi.h Wed Jul 5 14:34:31 2000 +++ AP618_source/perlapi.h Wed Aug 23 15:14:56 2000 @@ -246,6 +246,8 @@ #define PL_glob_index (*Perl_Iglob_index_ptr(aTHXo)) #undef PL_globalstash #define PL_globalstash (*Perl_Iglobalstash_ptr(aTHXo)) +#undef PL_he_arenaroot +#define PL_he_arenaroot (*Perl_Ihe_arenaroot_ptr(aTHXo)) #undef PL_he_root #define PL_he_root (*Perl_Ihe_root_ptr(aTHXo)) #undef PL_hintgv @@ -382,6 +384,8 @@ #define PL_nthreads (*Perl_Inthreads_ptr(aTHXo)) #undef PL_nthreads_cond #define PL_nthreads_cond (*Perl_Inthreads_cond_ptr(aTHXo)) +#undef PL_nullstash +#define PL_nullstash (*Perl_Inullstash_ptr(aTHXo)) #undef PL_numeric_local #define PL_numeric_local (*Perl_Inumeric_local_ptr(aTHXo)) #undef PL_numeric_name @@ -566,26 +570,48 @@ #define PL_xiv_arenaroot (*Perl_Ixiv_arenaroot_ptr(aTHXo)) #undef PL_xiv_root #define PL_xiv_root (*Perl_Ixiv_root_ptr(aTHXo)) +#undef PL_xnv_arenaroot +#define PL_xnv_arenaroot (*Perl_Ixnv_arenaroot_ptr(aTHXo)) #undef PL_xnv_root #define PL_xnv_root (*Perl_Ixnv_root_ptr(aTHXo)) +#undef PL_xpv_arenaroot +#define PL_xpv_arenaroot (*Perl_Ixpv_arenaroot_ptr(aTHXo)) #undef PL_xpv_root #define PL_xpv_root (*Perl_Ixpv_root_ptr(aTHXo)) +#undef PL_xpvav_arenaroot +#define PL_xpvav_arenaroot (*Perl_Ixpvav_arenaroot_ptr(aTHXo)) #undef PL_xpvav_root #define PL_xpvav_root (*Perl_Ixpvav_root_ptr(aTHXo)) +#undef PL_xpvbm_arenaroot +#define PL_xpvbm_arenaroot (*Perl_Ixpvbm_arenaroot_ptr(aTHXo)) #undef PL_xpvbm_root #define PL_xpvbm_root (*Perl_Ixpvbm_root_ptr(aTHXo)) +#undef PL_xpvcv_arenaroot +#define PL_xpvcv_arenaroot (*Perl_Ixpvcv_arenaroot_ptr(aTHXo)) #undef PL_xpvcv_root #define PL_xpvcv_root (*Perl_Ixpvcv_root_ptr(aTHXo)) +#undef PL_xpvhv_arenaroot +#define PL_xpvhv_arenaroot (*Perl_Ixpvhv_arenaroot_ptr(aTHXo)) #undef PL_xpvhv_root #define PL_xpvhv_root (*Perl_Ixpvhv_root_ptr(aTHXo)) +#undef PL_xpviv_arenaroot +#define PL_xpviv_arenaroot (*Perl_Ixpviv_arenaroot_ptr(aTHXo)) #undef PL_xpviv_root #define PL_xpviv_root (*Perl_Ixpviv_root_ptr(aTHXo)) +#undef PL_xpvlv_arenaroot +#define PL_xpvlv_arenaroot (*Perl_Ixpvlv_arenaroot_ptr(aTHXo)) #undef PL_xpvlv_root #define PL_xpvlv_root (*Perl_Ixpvlv_root_ptr(aTHXo)) +#undef PL_xpvmg_arenaroot +#define PL_xpvmg_arenaroot (*Perl_Ixpvmg_arenaroot_ptr(aTHXo)) #undef PL_xpvmg_root #define PL_xpvmg_root (*Perl_Ixpvmg_root_ptr(aTHXo)) +#undef PL_xpvnv_arenaroot +#define PL_xpvnv_arenaroot (*Perl_Ixpvnv_arenaroot_ptr(aTHXo)) #undef PL_xpvnv_root #define PL_xpvnv_root (*Perl_Ixpvnv_root_ptr(aTHXo)) +#undef PL_xrv_arenaroot +#define PL_xrv_arenaroot (*Perl_Ixrv_arenaroot_ptr(aTHXo)) #undef PL_xrv_root #define PL_xrv_root (*Perl_Ixrv_root_ptr(aTHXo)) #undef PL_yychar diff -ruN perl-5.6.0/perly.c AP618_source/perly.c --- perl-5.6.0/perly.c Wed Jul 5 14:34:31 2000 +++ AP618_source/perly.c Wed Aug 23 15:14:56 2000 @@ -1386,6 +1386,9 @@ #endif struct ysv *ysave; +#ifdef USE_ITHREADS + ENTER; /* force yydestruct() before we return */ +#endif New(73, ysave, 1, struct ysv); SAVEDESTRUCTOR_X(yydestruct, ysave); ysave->oldyydebug = yydebug; @@ -2477,6 +2480,9 @@ yyabort: retval = 1; yyaccept: +#ifdef USE_ITHREADS + LEAVE; /* force yydestruct() before we return */ +#endif return retval; } diff -ruN perl-5.6.0/perly_c.diff AP618_source/perly_c.diff --- perl-5.6.0/perly_c.diff Wed Jul 5 14:34:31 2000 +++ AP618_source/perly_c.diff Wed Aug 23 15:14:56 2000 @@ -12,7 +12,7 @@ if (yys = getenv("YYDEBUG")) { yyn = *yys; ---- 1447,1473 ---- +--- 1447,1476 ---- yyparse() { register int yym, yyn, yystate; @@ -27,6 +27,9 @@ ! #endif + struct ysv *ysave; ++ #ifdef USE_ITHREADS ++ ENTER; /* force yydestruct() before we return */ ++ #endif + New(73, ysave, 1, struct ysv); + SAVEDESTRUCTOR_X(yydestruct, ysave); + ysave->oldyydebug = yydebug; @@ -42,7 +45,7 @@ yyn = *yys; *************** *** 1463,1468 **** ---- 1480,1495 ---- +--- 1483,1498 ---- yyerrflag = 0; yychar = (-1); @@ -68,7 +71,7 @@ } *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; ---- 1520,1538 ---- +--- 1523,1541 ---- #endif if (yyssp >= yyss + yystacksize - 1) { @@ -97,7 +100,7 @@ } *++yyssp = yystate = yytable[yyn]; *++yyvsp = yylval; ---- 1573,1591 ---- +--- 1576,1594 ---- #endif if (yyssp >= yyss + yystacksize - 1) { @@ -134,7 +137,7 @@ yyaccept: ! return (0); } ---- 2524,2569 ---- +--- 2527,2575 ---- #endif if (yyssp >= yyss + yystacksize - 1) { @@ -160,6 +163,9 @@ yyabort: ! retval = 1; yyaccept: +! #ifdef USE_ITHREADS +! LEAVE; /* force yydestruct() before we return */ +! #endif ! return retval; ! } ! diff -ruN perl-5.6.0/pod/perlapi.pod AP618_source/pod/perlapi.pod --- perl-5.6.0/pod/perlapi.pod Wed Jul 5 14:34:32 2000 +++ AP618_source/pod/perlapi.pod Wed Aug 23 15:14:57 2000 @@ -165,9 +165,16 @@ =item croak -This is the XSUB-writer's interface to Perl's C function. Use this -function the same way you use the C C function. See -C. +This is the XSUB-writer's interface to Perl's C function. +Normally use this function the same way you use the C C +function. See C. + +If you want to throw an exception object, assign the object to +C<$@> and then pass C to croak(): + + errsv = get_sv("@", TRUE); + sv_setsv(errsv, exception_object); + croak(Nullch); void croak(const char* pat, ...) diff -ruN perl-5.6.0/pod/perldelta.pod AP618_source/pod/perldelta.pod --- perl-5.6.0/pod/perldelta.pod Wed Jul 5 14:34:32 2000 +++ AP618_source/pod/perldelta.pod Wed Aug 23 15:14:57 2000 @@ -2847,11 +2847,6 @@ These expressions will get run-time errors in some future release of Perl. -=head2 Windows 2000 - -Windows 2000 is known to fail test 22 in lib/open3.t (cause unknown at -this time). That test passes under Windows NT. - =head2 Experimental features As discussed above, many features are still experimental. Interfaces and diff -ruN perl-5.6.0/pod/perlembed.pod AP618_source/pod/perlembed.pod --- perl-5.6.0/pod/perlembed.pod Wed Jul 5 14:34:33 2000 +++ AP618_source/pod/perlembed.pod Wed Aug 23 15:14:57 2000 @@ -894,21 +894,14 @@ Perl and linked C/C++ routines. Let's take a look some pieces of I to see how Perl does this: + static void xs_init (pTHX); - #ifdef __cplusplus - # define EXTERN_C extern "C" - #else - # define EXTERN_C extern - #endif - - static void xs_init (void); - - EXTERN_C void boot_DynaLoader (CV* cv); - EXTERN_C void boot_Socket (CV* cv); + EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); + EXTERN_C void boot_Socket (pTHX_ CV* cv); EXTERN_C void - xs_init() + xs_init(pTHX) { char *file = __FILE__; /* DynaLoader is a special case */ @@ -955,21 +948,13 @@ Consult L, L, and L for more details. -=head1 Embedding Perl under Win32 +=head1 Embedding Perl under Windows -At the time of this writing (5.004), there are two versions of Perl -which run under Win32. (The two versions are merging in 5.005.) -Interfacing to ActiveState's Perl library is quite different from the -examples in this documentation, as significant changes were made to -the internal Perl API. However, it is possible to embed ActiveState's -Perl runtime. For details, see the Perl for Win32 FAQ at -http://www.perl.com/CPAN/doc/FAQs/win32/perlwin32faq.html. - -With the "official" Perl version 5.004 or higher, all the examples -within this documentation will compile and run untouched, although -the build process is slightly different between Unix and Win32. +In general, all of the source code shown here should work unmodified under +Windows. -For starters, backticks don't work under the Win32 native command shell. +However, there are some caveats about the command-line examples shown. +For starters, backticks won't work under the Win32 native command shell. The ExtUtils::Embed kit on CPAN ships with a script called B, which generates a simple makefile to build a program from a single C source file. It can be used like this: diff -ruN perl-5.6.0/pod/perlfunc.pod AP618_source/pod/perlfunc.pod --- perl-5.6.0/pod/perlfunc.pod Wed Jul 5 14:34:34 2000 +++ AP618_source/pod/perlfunc.pod Wed Aug 23 15:14:58 2000 @@ -791,6 +791,8 @@ =item cos EXPR +=item cos + Returns the cosine of EXPR (expressed in radians). If EXPR is omitted, takes cosine of C<$_>. @@ -1983,7 +1985,7 @@ indicating December. $year is the number of years since 1900. That is, $year is C<123> in year 2023. $wday is the day of the week, with 0 indicating Sunday and 3 indicating Wednesday. $yday is the day of -the year, in the range C<1..365> (or C<1..366> in leap years.) +the year, in the range C<0..364> (or C<0..365> in leap years.) Note that the $year element is I simply the last two digits of the year. If you assume it is, then you create non-Y2K-compliant @@ -2351,7 +2353,7 @@ indicating December. $year is the number of years since 1900. That is, $year is C<123> in year 2023. $wday is the day of the week, with 0 indicating Sunday and 3 indicating Wednesday. $yday is the day of -the year, in the range C<1..365> (or C<1..366> in leap years.) $isdst +the year, in the range C<0..364> (or C<0..365> in leap years.) $isdst is true if the specified time occurs during daylight savings time, false otherwise. @@ -3266,10 +3268,10 @@ The same template may generally also be used in unpack(). -=item package - =item package NAMESPACE +=item package + Declares the compilation unit as being in the given namespace. The scope of the package declaration is from the declaration itself through the end of the enclosing block, file, or eval (the same as the C operator). @@ -3327,7 +3329,7 @@ =item pos Returns the offset of where the last C search left off for the variable -is in question (C<$_> is used when the variable is not specified). May be +in question (C<$_> is used when the variable is not specified). May be modified to change that offset. Such modification will also influence the C<\G> zero-width assertion in regular expressions. See L and L. diff -ruN perl-5.6.0/pod/perlintern.pod AP618_source/pod/perlintern.pod --- perl-5.6.0/pod/perlintern.pod Wed Jul 5 14:34:34 2000 +++ AP618_source/pod/perlintern.pod Wed Aug 23 15:14:58 2000 @@ -12,6 +12,18 @@ =over 8 +=item is_gv_magical + +Returns C if given the name of a magical GV. + +Currently only useful internally when determining if a GV should be +created even in rvalue contexts. + +C is not used at present but available for future extension to +allow selecting particular classes of magical variable. + + bool is_gv_magical(char *name, STRLEN len, U32 flags) + =back =head1 AUTHORS diff -ruN perl-5.6.0/pod/perlvar.pod AP618_source/pod/perlvar.pod --- perl-5.6.0/pod/perlvar.pod Wed Jul 5 14:34:37 2000 +++ AP618_source/pod/perlvar.pod Wed Aug 23 15:14:59 2000 @@ -174,6 +174,8 @@ (Mnemonic: be positive and forward looking.) This variable is read-only and dynamically scoped to the current BLOCK. +=item @LAST_MATCH_END + =item @+ This array holds the offsets of the ends of the last successful @@ -411,6 +413,8 @@ channel. Used with formats. (Mnemonic: lines_on_page - lines_printed.) + +=item @LAST_MATCH_START =item @- diff -ruN perl-5.6.0/pp.c AP618_source/pp.c --- perl-5.6.0/pp.c Wed Jul 5 14:34:38 2000 +++ AP618_source/pp.c Tue Aug 29 21:57:51 2000 @@ -198,7 +198,7 @@ else { if (SvTYPE(sv) != SVt_PVGV) { char *sym; - STRLEN n_a; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -236,13 +236,17 @@ report_uninit(); RETSETUNDEF; } - sym = SvPV(sv, n_a); + sym = SvPV(sv,len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV); - if (!sv) + if (!sv + && (!is_gv_magical(sym,len,0) + || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV)))) + { RETSETUNDEF; + } } else { if (PL_op->op_private & HINT_STRICT_REFS) @@ -276,7 +280,7 @@ else { GV *gv = (GV*)sv; char *sym; - STRLEN n_a; + STRLEN len; if (SvTYPE(gv) != SVt_PVGV) { if (SvGMAGICAL(sv)) { @@ -292,13 +296,17 @@ report_uninit(); RETSETUNDEF; } - sym = SvPV(sv, n_a); + sym = SvPV(sv, len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV); - if (!gv) + if (!gv + && (!is_gv_magical(sym,len,0) + || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV)))) + { RETSETUNDEF; + } } else { if (PL_op->op_private & HINT_STRICT_REFS) @@ -961,7 +969,7 @@ NV dright; NV dleft; - if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { + if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { IV i = SvIVX(POPs); right = (right_neg = (i < 0)) ? -i : i; } @@ -973,7 +981,7 @@ dright = -dright; } - if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { + if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { IV i = SvIVX(POPs); left = (left_neg = (i < 0)) ? -i : i; } @@ -1076,10 +1084,10 @@ SP -= items; } else { /* Note: mark already snarfed by pp_list */ - SV *tmpstr; + SV *tmpstr = POPs; STRLEN len; + bool isutf = DO_UTF8(tmpstr); - tmpstr = POPs; SvSetSV(TARG, tmpstr); SvPV_force(TARG, len); if (count != 1) { @@ -1092,7 +1100,10 @@ } *SvEND(TARG) = '\0'; } - (void)SvPOK_only(TARG); + if (isutf) + (void)SvPOK_only_UTF8(TARG); + else + (void)SvPOK_only(TARG); PUSHTARG; } RETURN; @@ -1809,7 +1820,7 @@ NV value; value = POPn; if (value <= 0.0) { - RESTORE_NUMERIC_STANDARD(); + SET_NUMERIC_STANDARD(); DIE(aTHX_ "Can't take log of %g", value); } value = Perl_log(value); @@ -1825,7 +1836,7 @@ NV value; value = POPn; if (value < 0.0) { - RESTORE_NUMERIC_STANDARD(); + SET_NUMERIC_STANDARD(); DIE(aTHX_ "Can't take sqrt of %g", value); } value = Perl_sqrt(value); @@ -1892,6 +1903,7 @@ STRLEN n_a; tmps = POPpx; + argtype = 1; /* allow underscores */ XPUSHn(scan_hex(tmps, 99, &argtype)); RETURN; } @@ -1909,6 +1921,7 @@ tmps++; if (*tmps == '0') tmps++; + argtype = 1; /* allow underscores */ if (*tmps == 'x') value = scan_hex(++tmps, 99, &argtype); else if (*tmps == 'b') @@ -2013,12 +2026,12 @@ RETPUSHUNDEF; } else { - if (utfcurlen) { + if (utfcurlen) sv_pos_u2b(sv, &pos, &rem); - SvUTF8_on(TARG); - } tmps += pos; sv_setpvn(TARG, tmps, rem); + if (utfcurlen) + SvUTF8_on(TARG); if (repl) sv_insert(sv, pos, rem, repl, repl_len); else if (lvalue) { /* it's an lvalue! */ @@ -2031,7 +2044,7 @@ "Attempt to use reference as lvalue in substr"); } if (SvOK(sv)) /* is it defined ? */ - (void)SvPOK_only(sv); + (void)SvPOK_only_UTF8(sv); else sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ } @@ -2214,7 +2227,6 @@ tmps = SvPVX(TARG); *tmps++ = value; *tmps = '\0'; - SvUTF8_off(TARG); /* decontaminate */ (void)SvPOK_only(TARG); XPUSHs(TARG); RETURN; @@ -2547,7 +2559,7 @@ } *d = '\0'; SvCUR_set(TARG, d - SvPVX(TARG)); - (void)SvPOK_only(TARG); + (void)SvPOK_only_UTF8(TARG); } else sv_setpvn(TARG, s, len); @@ -3236,7 +3248,7 @@ *up++ = *down; *down-- = tmp; } - (void)SvPOK_only(TARG); + (void)SvPOK_only_UTF8(TARG); } SP = MARK + 1; SETTARG; diff -ruN perl-5.6.0/pp_ctl.c AP618_source/pp_ctl.c --- perl-5.6.0/pp_ctl.c Wed Jul 5 14:34:38 2000 +++ AP618_source/pp_ctl.c Tue Aug 29 21:57:51 2000 @@ -598,7 +598,7 @@ value = SvNV(sv); /* Formats aren't yet marked for locales, so assume "yes". */ { - RESTORE_NUMERIC_LOCAL(); + STORE_NUMERIC_STANDARD_SET_LOCAL(); #if defined(USE_LONG_DOUBLE) if (arg & 256) { sprintf(t, "%#*.*" PERL_PRIfldbl, @@ -883,15 +883,18 @@ CATCH_SET(TRUE); PUSHSTACKi(PERLSI_SORT); - if (PL_sortstash != stash) { - PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV); - PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); - PL_sortstash = stash; + if (!hasargs && !is_xsub) { + if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) { + SAVESPTR(PL_firstgv); + SAVESPTR(PL_secondgv); + PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV); + PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); + PL_sortstash = stash; + } + SAVESPTR(GvSV(PL_firstgv)); + SAVESPTR(GvSV(PL_secondgv)); } - SAVESPTR(GvSV(PL_firstgv)); - SAVESPTR(GvSV(PL_secondgv)); - PUSHBLOCK(cx, CXt_NULL, PL_stack_base); if (!(PL_op->op_flags & OPf_SPECIAL)) { cx->cx_type = CXt_SUB; @@ -910,6 +913,7 @@ cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); #endif /* USE_THREADS */ + cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; } qsortsv((myorigmark+1), max, @@ -1521,15 +1525,21 @@ else PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); if (CxTYPE(cx) == CXt_EVAL) { + /* eval STRING */ if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { PUSHs(cx->blk_eval.cur_text); PUSHs(&PL_sv_no); } - /* try blocks have old_namesv == 0 */ + /* require */ else if (cx->blk_eval.old_namesv) { PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv))); PUSHs(&PL_sv_yes); } + /* eval BLOCK (try blocks have old_namesv == 0) */ + else { + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); + } } else { PUSHs(&PL_sv_undef); @@ -1546,7 +1556,7 @@ PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, SVt_PVAV))); GvMULTI_on(tmpgv); - AvREAL_off(PL_dbargs); /* XXX Should be REIFY */ + AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ } if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) @@ -1562,9 +1572,12 @@ { SV * mask ; SV * old_warnings = cx->blk_oldcop->cop_warnings ; - if (old_warnings == pWARN_NONE || old_warnings == pWARN_STD) + + if (old_warnings == pWARN_NONE || + (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) mask = newSVpvn(WARN_NONEstring, WARNsize) ; - else if (old_warnings == pWARN_ALL) + else if (old_warnings == pWARN_ALL || + (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) mask = newSVpvn(WARN_ALLstring, WARNsize) ; else mask = newSVsv(old_warnings); @@ -1979,7 +1992,7 @@ { I32 cxix; register PERL_CONTEXT *cx; - I32 oldsave; + I32 inner; if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); @@ -1994,13 +2007,12 @@ if (cxix < cxstack_ix) dounwind(cxix); + /* clear off anything above the scope we're re-entering, but + * save the rest until after a possible continue block */ + inner = PL_scopestack_ix; TOPBLOCK(cx); - - /* clean scope, but only if there's no continue block */ - if (!(cx->blk_loop.last_op->op_private & OPpLOOP_CONTINUE)) { - oldsave = PL_scopestack[PL_scopestack_ix - 1]; - LEAVE_SCOPE(oldsave); - } + if (PL_scopestack_ix < inner) + leave_scope(PL_scopestack[PL_scopestack_ix]); return cx->blk_loop.next_op; } @@ -2297,6 +2309,7 @@ cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); #endif /* USE_THREADS */ + cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; ++mark; @@ -2623,11 +2636,9 @@ /* switch to eval mode */ if (PL_curcop == &PL_compiling) { - SAVECOPSTASH(&PL_compiling); + SAVECOPSTASH_FREE(&PL_compiling); CopSTASH_set(&PL_compiling, PL_curstash); } - SAVECOPFILE(&PL_compiling); - SAVECOPLINE(&PL_compiling); if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { SV *sv = sv_newmortal(); Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]", @@ -2637,7 +2648,9 @@ } else sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); + SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); + SAVECOPLINE(&PL_compiling); CopLINE_set(&PL_compiling, 1); /* XXX For Cs within BEGIN {} blocks, this ends up deleting the eval's FILEGV from the stash before gv_check() runs @@ -2757,6 +2770,7 @@ SAVESPTR(PL_beginav); PL_beginav = newAV(); SAVEFREESV(PL_beginav); + SAVEI32(PL_error_count); /* try to compile it */ @@ -2910,8 +2924,8 @@ sv = POPs; if (SvNIOKp(sv)) { - UV rev, ver, sver; - if (SvPOKp(sv)) { /* require v5.6.1 */ + if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */ + UV rev = 0, ver = 0, sver = 0; I32 len; U8 *s = (U8*)SvPVX(sv); U8 *end = (U8*)SvPVX(sv) + SvCUR(sv); @@ -2923,14 +2937,8 @@ s += len; if (s < end) sver = utf8_to_uv(s, &len); - else - sver = 0; } - else - ver = 0; } - else - rev = 0; if (PERL_REVISION < rev || (PERL_REVISION == rev && (PERL_VERSION < ver @@ -2941,6 +2949,7 @@ "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION, PERL_VERSION, PERL_SUBVERSION); } + RETPUSHYES; } else if (!SvPOKp(sv)) { /* require 5.005_03 */ if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000) @@ -2969,8 +2978,8 @@ PERL_SUBVERSION); } } + RETPUSHYES; } - RETPUSHYES; } name = SvPV(sv, len); if (!(name && len > 0 && *name)) @@ -3129,7 +3138,7 @@ } } } - SAVECOPFILE(&PL_compiling); + SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tryrsfp ? tryname : name); SvREFCNT_dec(namesv); if (!tryrsfp) { @@ -3239,7 +3248,6 @@ /* switch to eval mode */ - SAVECOPFILE(&PL_compiling); if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { SV *sv = sv_newmortal(); Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]", @@ -3249,7 +3257,9 @@ } else sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); + SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); + SAVECOPLINE(&PL_compiling); CopLINE_set(&PL_compiling, 1); /* XXX For Cs within BEGIN {} blocks, this ends up deleting the eval's FILEGV from the stash before gv_check() runs @@ -3261,9 +3271,11 @@ SAVEHINTS(); PL_hints = PL_op->op_targ; SAVESPTR(PL_compiling.cop_warnings); - if (!specialWARN(PL_compiling.cop_warnings)) { - PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; - SAVEFREESV(PL_compiling.cop_warnings) ; + if (specialWARN(PL_curcop->cop_warnings)) + PL_compiling.cop_warnings = PL_curcop->cop_warnings; + else { + PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings); + SAVEFREESV(PL_compiling.cop_warnings); } push_return(PL_op->op_next); diff -ruN perl-5.6.0/pp_hot.c AP618_source/pp_hot.c --- perl-5.6.0/pp_hot.c Wed Jul 5 14:34:38 2000 +++ AP618_source/pp_hot.c Wed Aug 23 15:14:59 2000 @@ -146,22 +146,36 @@ dPOPTOPssrl; STRLEN len; char *s; + bool left_utf = DO_UTF8(left); + bool right_utf = DO_UTF8(right); if (TARG != left) { + if (right_utf && !left_utf) + sv_utf8_upgrade(left); s = SvPV(left,len); + SvUTF8_off(TARG); if (TARG == right) { + if (left_utf && !right_utf) + sv_utf8_upgrade(right); sv_insert(TARG, 0, 0, s, len); + if (left_utf || right_utf) + SvUTF8_on(TARG); SETs(TARG); RETURN; } sv_setpvn(TARG,s,len); } - else if (SvGMAGICAL(TARG)) + else if (SvGMAGICAL(TARG)) { mg_get(TARG); + if (right_utf && !left_utf) + sv_utf8_upgrade(left); + } else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) { sv_setpv(TARG, ""); /* Suppress warning. */ s = SvPV_force(TARG, len); } + if (left_utf && !right_utf) + sv_utf8_upgrade(right); s = SvPV(right,len); if (SvOK(TARG)) { #if defined(PERL_Y2KWARN) @@ -176,19 +190,12 @@ } } #endif - if (DO_UTF8(right)) - sv_utf8_upgrade(TARG); sv_catpvn(TARG,s,len); - if (!IN_BYTE) { - if (SvUTF8(right)) - SvUTF8_on(TARG); - } - else if (!SvUTF8(right)) { - SvUTF8_off(TARG); - } } else sv_setpvn(TARG,s,len); /* suppress warning */ + if (left_utf || right_utf) + SvUTF8_on(TARG); SETTARG; RETURN; } @@ -455,7 +462,7 @@ if (SvTYPE(sv) != SVt_PVGV) { char *sym; - STRLEN n_a; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -474,13 +481,17 @@ } RETSETUNDEF; } - sym = SvPV(sv,n_a); + sym = SvPV(sv,len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV); - if (!gv) + if (!gv + && (!is_gv_magical(sym,len,0) + || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV)))) + { RETSETUNDEF; + } } else { if (PL_op->op_private & HINT_STRICT_REFS) @@ -555,7 +566,7 @@ if (SvTYPE(sv) != SVt_PVGV) { char *sym; - STRLEN n_a; + STRLEN len; if (SvGMAGICAL(sv)) { mg_get(sv); @@ -574,13 +585,17 @@ } RETSETUNDEF; } - sym = SvPV(sv,n_a); + sym = SvPV(sv,len); if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV); - if (!gv) + if (!gv + && (!is_gv_magical(sym,len,0) + || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV)))) + { RETSETUNDEF; + } } else { if (PL_op->op_private & HINT_STRICT_REFS) @@ -1021,7 +1036,8 @@ && !PL_sawampersand && ((rx->reganch & ROPT_NOSCAN) || !((rx->reganch & RE_INTUIT_TAIL) - && (r_flags & REXEC_SCREAM)))) + && (r_flags & REXEC_SCREAM))) + && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */ goto yup; } if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags)) @@ -1374,8 +1390,7 @@ /* delay EOF state for a snarfed empty file */ #define SNARF_EOF(gimme,rs,io,sv) \ (gimme != G_SCALAR || SvCUR(sv) \ - || !RsSNARF(rs) || (IoFLAGS(io) & IOf_NOLINE) \ - || ((IoFLAGS(io) |= IOf_NOLINE), FALSE)) + || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) for (;;) { if (!sv_gets(sv, fp, offset) @@ -1408,6 +1423,7 @@ SvTAINTED_on(sv); } IoLINES(io)++; + IoFLAGS(io) |= IOf_NOLINE; SvSETMAGIC(sv); XPUSHs(sv); if (type == OP_GLOB) { @@ -2643,6 +2659,7 @@ cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); #endif /* USE_THREADS */ + cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; ++MARK; diff -ruN perl-5.6.0/pp_sys.c AP618_source/pp_sys.c --- perl-5.6.0/pp_sys.c Wed Jul 5 14:34:39 2000 +++ AP618_source/pp_sys.c Wed Aug 23 15:14:59 2000 @@ -3078,7 +3078,7 @@ (void)PerlIO_close(fp); RETPUSHUNDEF; } - do_binmode(fp, '<', TRUE); + do_binmode(fp, '<', O_BINARY); len = PerlIO_read(fp, tbuf, sizeof(tbuf)); (void)PerlIO_close(fp); if (len <= 0) { @@ -3680,6 +3680,8 @@ EXTEND(SP, 1); PERL_FLUSHALL_FOR_CHILD; childpid = PerlProc_fork(); + if (childpid == -1) + RETSETUNDEF; PUSHi(childpid); RETURN; # else @@ -3696,7 +3698,12 @@ int argflags; childpid = wait4pid(-1, &argflags, 0); +# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) + /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ + STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1); +# else STATUS_NATIVE_SET((childpid > 0) ? argflags : -1); +# endif XPUSHi(childpid); RETURN; #else @@ -3715,7 +3722,12 @@ optype = POPi; childpid = TOPi; childpid = wait4pid(childpid, &argflags, optype); +# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) + /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ + STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1); +# else STATUS_NATIVE_SET((childpid > 0) ? argflags : -1); +# endif SETi(childpid); RETURN; #else @@ -3812,6 +3824,8 @@ } PerlProc__exit(-1); #else /* ! FORK or VMS or OS/2 */ + PL_statusvalue = 0; + result = 0; if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); @@ -3821,10 +3835,12 @@ else { value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a)); } + if (PL_statusvalue == -1) /* hint that value must be returned as is */ + result = 1; STATUS_NATIVE_SET(value); do_execfree(); SP = ORIGMARK; - PUSHi(STATUS_CURRENT); + PUSHi(result ? value : STATUS_CURRENT); #endif /* !FORK or VMS */ RETURN; } diff -ruN perl-5.6.0/proto.h AP618_source/proto.h --- perl-5.6.0/proto.h Wed Jul 5 14:34:39 2000 +++ AP618_source/proto.h Wed Aug 23 15:15:00 2000 @@ -217,7 +217,7 @@ PERL_CALLCONV void Perl_dounwind(pTHX_ I32 cxix); PERL_CALLCONV bool Perl_do_aexec(pTHX_ SV* really, SV** mark, SV** sp); PERL_CALLCONV bool Perl_do_aexec5(pTHX_ SV* really, SV** mark, SV** sp, int fd, int flag); -PERL_CALLCONV int Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int flag); +PERL_CALLCONV int Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode); PERL_CALLCONV void Perl_do_chop(pTHX_ SV* asv, SV* sv); PERL_CALLCONV bool Perl_do_close(pTHX_ GV* gv, bool not_implicit); PERL_CALLCONV bool Perl_do_eof(pTHX_ GV* gv); @@ -331,6 +331,7 @@ PERL_CALLCONV char* Perl_instr(pTHX_ const char* big, const char* little); PERL_CALLCONV bool Perl_io_close(pTHX_ IO* io, bool not_implicit); PERL_CALLCONV OP* Perl_invert(pTHX_ OP* cmd); +PERL_CALLCONV bool Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags); PERL_CALLCONV bool Perl_is_uni_alnum(pTHX_ U32 c); PERL_CALLCONV bool Perl_is_uni_alnumc(pTHX_ U32 c); PERL_CALLCONV bool Perl_is_uni_idfirst(pTHX_ U32 c); @@ -650,6 +651,7 @@ PERL_CALLCONV void Perl_save_freeop(pTHX_ OP* o); PERL_CALLCONV void Perl_save_freepv(pTHX_ char* pv); PERL_CALLCONV void Perl_save_generic_svref(pTHX_ SV** sptr); +PERL_CALLCONV void Perl_save_generic_pvref(pTHX_ char** str); PERL_CALLCONV void Perl_save_gp(pTHX_ GV* gv, I32 empty); PERL_CALLCONV HV* Perl_save_hash(pTHX_ GV* gv); PERL_CALLCONV void Perl_save_helem(pTHX_ HV* hv, SV *key, SV **sptr); @@ -937,6 +939,10 @@ PERL_CALLCONV void* Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv); PERL_CALLCONV void Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldsv, void *newsv); PERL_CALLCONV void Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl); +#endif +#if defined(HAVE_INTERP_INTERN) +PERL_CALLCONV void Perl_sys_intern_clear(pTHX); +PERL_CALLCONV void Perl_sys_intern_init(pTHX); #endif #if defined(PERL_OBJECT) diff -ruN perl-5.6.0/regcomp.c AP618_source/regcomp.c --- perl-5.6.0/regcomp.c Wed Jul 5 14:34:39 2000 +++ AP618_source/regcomp.c Wed Aug 23 15:15:00 2000 @@ -2296,8 +2296,14 @@ nextchar(); ret = reg(1, &flags); if (ret == NULL) { - if (flags & TRYAGAIN) + if (flags & TRYAGAIN) { + if (PL_regcomp_parse == PL_regxend) { + /* Make parent create an empty node if needed. */ + *flagp |= TRYAGAIN; + return(NULL); + } goto tryagain; + } return(NULL); } *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE); @@ -2599,8 +2605,10 @@ if (!e) FAIL("Missing right brace on \\x{}"); else if (UTF) { - ender = (UV)scan_hex(p + 1, e - p, &numlen); - if (numlen + len >= 127) { /* numlen is generous */ + numlen = 1; /* allow underscores */ + ender = (UV)scan_hex(p + 1, e - p - 1, &numlen); + /* numlen is generous */ + if (numlen + len >= 127) { p--; goto loopdone; } @@ -2610,6 +2618,7 @@ FAIL("Can't use \\x{} without 'use utf8' declaration"); } else { + numlen = 0; /* disallow underscores */ ender = (UV)scan_hex(p, 2, &numlen); p += numlen; } @@ -2623,6 +2632,7 @@ case '5': case '6': case '7': case '8':case '9': if (*p == '0' || (isDIGIT(p[1]) && atoi(p) >= PL_regnpar) ) { + numlen = 0; /* disallow underscores */ ender = (UV)scan_oct(p, 3, &numlen); p += numlen; } @@ -2934,6 +2944,7 @@ case 'a': value = '\057'; break; #endif case 'x': + numlen = 0; /* disallow underscores */ value = (UV)scan_hex(PL_regcomp_parse, 2, &numlen); PL_regcomp_parse += numlen; break; @@ -2943,6 +2954,7 @@ break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': + numlen = 0; /* disallow underscores */ value = (UV)scan_oct(--PL_regcomp_parse, 3, &numlen); PL_regcomp_parse += numlen; break; @@ -3408,12 +3420,14 @@ e = strchr(PL_regcomp_parse++, '}'); if (!e) FAIL("Missing right brace on \\x{}"); + numlen = 1; /* allow underscores */ value = (UV)scan_hex(PL_regcomp_parse, e - PL_regcomp_parse, &numlen); PL_regcomp_parse = e + 1; } else { + numlen = 0; /* disallow underscores */ value = (UV)scan_hex(PL_regcomp_parse, 2, &numlen); PL_regcomp_parse += numlen; } @@ -3424,6 +3438,7 @@ break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': + numlen = 0; /* disallow underscores */ value = (UV)scan_oct(--PL_regcomp_parse, 3, &numlen); PL_regcomp_parse += numlen; break; diff -ruN perl-5.6.0/regexec.c AP618_source/regexec.c --- perl-5.6.0/regexec.c Wed Jul 5 14:34:39 2000 +++ AP618_source/regexec.c Wed Aug 23 15:15:00 2000 @@ -346,7 +346,9 @@ I32 slen; if ( !(prog->reganch & ROPT_ANCH_GPOS) /* Checked by the caller */ - && (sv && (strpos + SvCUR(sv) != strend)) ) { + /* SvCUR is not set on references: SvRV and SvPVX overlap */ + && sv && !SvROK(sv) + && (strpos + SvCUR(sv) != strend)) { DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n")); goto fail; } @@ -597,9 +599,10 @@ find_anchor: while (t < strend - prog->minlen) { if (*t == '\n') { - if (t < s - prog->check_offset_min) { + if (t < check_at - prog->check_offset_min) { if (prog->anchored_substr) { - /* We definitely contradict the found anchored + /* Since we moved from the found position, + we definitely contradict the found anchored substr. Due to the above check we do not contradict "check" substr. Thus we can arrive here only if check substr @@ -610,12 +613,17 @@ PL_colors[0],PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset))); goto do_other_anchored; } + /* We don't contradict the found floating substring. */ + /* XXXX Why not check for STCLASS? */ s = t + 1; DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n", PL_colors[0],PL_colors[1], (long)(s - i_strpos))); goto set_useful; } - DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting at offset %ld...\n", + /* Position contradicts check-string */ + /* XXXX probably better to look for check-string + than for "\n", so one should lower the limit for t? */ + DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n", PL_colors[0],PL_colors[1], (long)(t + 1 - i_strpos))); strpos = s = t + 1; goto restart; @@ -626,19 +634,24 @@ PL_colors[0],PL_colors[1])); goto fail_finish; } + else { + DEBUG_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n", + PL_colors[0],PL_colors[1])); + } s = t; set_useful: ++BmUSEFUL(prog->check_substr); /* hooray/5 */ } else { PL_bostr = tmp; - /* The found string does not prohibit matching at beg-of-str + /* The found string does not prohibit matching at strpos, - no optimization of calling REx engine can be performed, - unless it was an MBOL and we are not after MBOL. */ + unless it was an MBOL and we are not after MBOL, + or a future STCLASS check will fail this. */ try_at_start: /* Even in this situation we may use MBOL flag if strpos is offset wrt the start of the string. */ - if (ml_anch && sv + if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */ && (strpos + SvCUR(sv) != strend) && strpos[-1] != '\n' /* May be due to an implicit anchor of m{.*foo} */ && !(prog->reganch & ROPT_IMPLICIT)) @@ -647,8 +660,8 @@ goto find_anchor; } DEBUG_r( if (ml_anch) - PerlIO_printf(Perl_debug_log, "Does not contradict /%s^%s/m...\n", - PL_colors[0],PL_colors[1]); + PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n", + (long)(strpos - i_strpos), PL_colors[0],PL_colors[1]); ); success_at_start: if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */ @@ -657,6 +670,7 @@ && prog->check_substr == prog->float_substr) { /* If flags & SOMETHING - do not do it many times on the same match */ + DEBUG_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n")); SvREFCNT_dec(prog->check_substr); prog->check_substr = Nullsv; /* disable */ prog->float_substr = Nullsv; /* clear */ @@ -723,7 +737,7 @@ goto fail; } DEBUG_r( PerlIO_printf(Perl_debug_log, - "Trying %s substr starting at offset %ld...\n", + "Looking for %s substr starting at offset %ld...\n", what, (long)(s + start_shift - i_strpos)) ); goto restart; } @@ -733,7 +747,7 @@ /* Recheck anchored substring, but not floating... */ s = check_at; DEBUG_