This patch describes the changes made in ActivePerl build 622 over the official Perl v5.6.0 sources. Summary of changes in build 622: * 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 AP622_source/BuildInfo.h --- perl-5.6.0/BuildInfo.h Wed Dec 31 16:00:00 1969 +++ AP622_source/BuildInfo.h Mon Nov 6 19:21:25 2000 @@ -0,0 +1,25 @@ +/* BuildInfo.h + * + * (c) 1998 ActiveState Tool Corp. All rights reserved. + * + */ + +#ifndef ___BuildInfo__h___ +#define ___BuildInfo__h___ + +#define PRODUCT_BUILD_NUMBER "622" +#define PERLFILEVERSION "5,6,0,622\0" +#define PERLRC_VERSION 5,6,0,622 +#define ACTIVEPERL_CHANGELIST "" +#define PERLPRODUCTVERSION "Build " PRODUCT_BUILD_NUMBER ACTIVEPERL_CHANGELIST "\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 ACTIVEPERL_CHANGELIST +#define BINARY_BUILD_NOTICE printf("\n\ +Binary build " PRODUCT_BUILD_NUMBER ACTIVEPERL_CHANGELIST " provided by ActiveState Tool Corp. http://www.ActiveState.com\n\ +" ACTIVEPERL_VERSION "\n"); + +#endif /* ___BuildInfo__h___ */ diff -ruN perl-5.6.0/Configure AP622_source/Configure --- perl-5.6.0/Configure Wed Jul 5 14:34:01 2000 +++ AP622_source/Configure Mon Nov 6 19:21:26 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 AP622_source/MANIFEST --- perl-5.6.0/MANIFEST Wed Jul 5 14:34:01 2000 +++ AP622_source/MANIFEST Mon Nov 6 19:21:26 2000 @@ -567,6 +567,7 @@ lib/CGI/Pretty.pm Output nicely formatted HTML lib/CGI/Push.pm Support for server push lib/CGI/Switch.pm Simple interface for multiple server types +lib/CGI/Util.pm Utility functions lib/CPAN.pm Interface to Comprehensive Perl Archive Network lib/CPAN/FirstTime.pm Utility for creating CPAN config files lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions @@ -677,6 +678,7 @@ lib/UNIVERSAL.pm Base class for ALL classes lib/User/grent.pm By-name interface to Perl's builtin getgr* lib/User/pwent.pm By-name interface to Perl's builtin getpw* +lib/Win32.pod Documentation for Win32 extras lib/abbrev.pl An abbreviation table builder lib/assert.pl assertion and panic with stack trace lib/attributes.pm For "sub foo : attrlist" @@ -1051,7 +1053,6 @@ plan9/setup.rc Plan9 port: script for easy build+install plan9/versnum Plan9 port: script to print version number pod/Makefile Make pods into something else -pod/Win32.pod Documentation for Win32 extras pod/buildtoc generate perltoc.pod pod/checkpods.PL Tool to check for common errors in pods pod/perl.pod Top level perl man page @@ -1210,6 +1211,7 @@ t/lib/cgi-form.t See if CGI.pm works t/lib/cgi-function.t See if CGI.pm works t/lib/cgi-html.t See if CGI.pm works +t/lib/cgi-pretty.t See if CGI.pm works t/lib/cgi-request.t See if CGI.pm works t/lib/charnames.t See if character names work t/lib/checktree.t See if File::CheckTree works @@ -1295,6 +1297,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 AP622_source/README.win32 --- perl-5.6.0/README.win32 Wed Jul 5 14:34:03 2000 +++ AP622_source/README.win32 Mon Nov 6 19:21:26 2000 @@ -100,7 +100,7 @@ (The make that Borland supplies is seriously crippled, and will not work for MakeMaker builds.) -See L/"Make"> above. +See L above. =item Microsoft Visual C++ @@ -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 AP622_source/av.h --- perl-5.6.0/av.h Wed Jul 5 14:34:03 2000 +++ AP622_source/av.h Mon Nov 6 19:21:26 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 AP622_source/cop.h --- perl-5.6.0/cop.h Wed Jul 5 14:34:04 2000 +++ AP622_source/cop.h Mon Nov 6 19:21:26 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 AP622_source/doop.c --- perl-5.6.0/doop.c Wed Jul 5 14:34:04 2000 +++ AP622_source/doop.c Mon Nov 6 19:21:26 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 AP622_source/dump.c --- perl-5.6.0/dump.c Wed Jul 5 14:34:04 2000 +++ AP622_source/dump.c Mon Nov 6 19:21:26 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 AP622_source/embed.h --- perl-5.6.0/embed.h Wed Jul 5 14:34:06 2000 +++ AP622_source/embed.h Mon Nov 6 19:21:27 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 AP622_source/embed.pl --- perl-5.6.0/embed.pl Wed Jul 5 14:34:06 2000 +++ AP622_source/embed.pl Mon Nov 6 19:21:27 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 AP622_source/embedvar.h --- perl-5.6.0/embedvar.h Wed Jul 5 14:34:07 2000 +++ AP622_source/embedvar.h Mon Nov 6 19:21:27 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 AP622_source/ext/B/B/Deparse.pm --- perl-5.6.0/ext/B/B/Deparse.pm Wed Jul 5 14:34:08 2000 +++ AP622_source/ext/B/B/Deparse.pm Mon Nov 6 19:21:27 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 AP622_source/ext/Data/Dumper/Dumper.xs --- perl-5.6.0/ext/Data/Dumper/Dumper.xs Wed Jul 5 14:34:09 2000 +++ AP622_source/ext/Data/Dumper/Dumper.xs Mon Nov 6 19:21:27 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 AP622_source/ext/File/Glob/Glob.pm --- perl-5.6.0/ext/File/Glob/Glob.pm Wed Jul 5 14:34:09 2000 +++ AP622_source/ext/File/Glob/Glob.pm Mon Nov 6 19:21:27 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 AP622_source/ext/IO/lib/IO/Poll.pm --- perl-5.6.0/ext/IO/lib/IO/Poll.pm Wed Jul 5 14:34:10 2000 +++ AP622_source/ext/IO/lib/IO/Poll.pm Mon Nov 6 19:21:27 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 AP622_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 +++ AP622_source/ext/IO/lib/IO/Socket/INET.pm Mon Nov 6 19:21:27 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 AP622_source/ext/POSIX/POSIX.pm --- perl-5.6.0/ext/POSIX/POSIX.pm Wed Jul 5 14:34:10 2000 +++ AP622_source/ext/POSIX/POSIX.pm Mon Nov 6 19:21:27 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 AP622_source/ext/Sys/Syslog/Syslog.pm --- perl-5.6.0/ext/Sys/Syslog/Syslog.pm Wed Jul 5 14:34:11 2000 +++ AP622_source/ext/Sys/Syslog/Syslog.pm Mon Nov 6 19:21:27 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 AP622_source/ext/Sys/Syslog/Syslog.xs --- perl-5.6.0/ext/Sys/Syslog/Syslog.xs Wed Jul 5 14:34:11 2000 +++ AP622_source/ext/Sys/Syslog/Syslog.xs Mon Nov 6 19:21:27 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 AP622_source/global.sym --- perl-5.6.0/global.sym Wed Jul 5 14:34:12 2000 +++ AP622_source/global.sym Mon Nov 6 19:21:28 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 AP622_source/gv.c --- perl-5.6.0/gv.c Wed Jul 5 14:34:12 2000 +++ AP622_source/gv.c Mon Nov 6 19:21:28 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/hints/hpux.sh AP622_source/hints/hpux.sh --- perl-5.6.0/hints/hpux.sh Wed Jul 5 14:34:12 2000 +++ AP622_source/hints/hpux.sh Mon Nov 6 19:21:28 2000 @@ -343,9 +343,7 @@ fi # HP-UX 10.X uses the old pthreads API - case "$d_oldpthreads" in - '') d_oldpthreads="$define" ;; - esac + d_oldpthreads="$define" # include libcma before all the others libswanted="cma $libswanted" diff -ruN perl-5.6.0/hv.c AP622_source/hv.c --- perl-5.6.0/hv.c Wed Jul 5 14:34:13 2000 +++ AP622_source/hv.c Mon Nov 6 19:21:28 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 AP622_source/intrpvar.h --- perl-5.6.0/intrpvar.h Wed Jul 5 14:34:13 2000 +++ AP622_source/intrpvar.h Mon Nov 6 19:21:28 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/CGI/Carp.pm AP622_source/lib/CGI/Carp.pm --- perl-5.6.0/lib/CGI/Carp.pm Wed Jul 5 14:34:15 2000 +++ AP622_source/lib/CGI/Carp.pm Mon Nov 6 19:21:28 2000 @@ -142,6 +142,33 @@ In order to correctly intercept compile-time errors, you should call set_message() from within a BEGIN{} block. +=head1 MAKING WARNINGS APPEAR AS HTML COMMENTS + +It is now also possible to make non-fatal errors appear as HTML +comments embedded in the output of your program. To enable this +feature, export the new "warningsToBrowser" subroutine. Since sending +warnings to the browser before the HTTP headers have been sent would +cause an error, any warnings are stored in an internal buffer until +you call the warningsToBrowser() subroutine with a true argument: + + use CGI::Carp qw(fatalsToBrowser warningsToBrowser); + use CGI qw(:standard); + print header(); + warningsToBrowser(1); + +You may also give a false argument to warningsToBrowser() to prevent +warnings from being sent to the browser while you are printing some +content where HTML comments are not allowed: + + warningsToBrowser(0); # disable warnings + print "\n"; + warningsToBrowser(1); # re-enable warnings + +Note: In this respect warningsToBrowser() differs fundamentally from +fatalsToBrowser(), which you should never call yourself! + =head1 CHANGE LOG 1.05 carpout() added and minor corrections by Marc Hedlund @@ -166,7 +193,11 @@ 1.12 Changed die() on line 217 to CORE::die to avoid B<-w> warning. 1.13 Added cluck() to make the module orthogonal with Carp. - More mod_perl related fixes. + More mod_perl related fixes. + +1.20 Patch from Ilmari Karonen (perl@itz.pp.sci.fi): Added + warningsToBrowser(). Replaced tags with 
 in
+     fatalsToBrowser() output.
 
 =head1 AUTHORS
 
@@ -190,18 +221,11 @@
 
 @ISA = qw(Exporter);
 @EXPORT = qw(confess croak carp);
-@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message cluck);
-
-BEGIN {
-  $] >= 5.005
-    ? eval q#sub ineval { $^S }#
-      : eval q#sub ineval { _longmess() =~ /eval [\{\']/m }#;
-  $@ and die;
-}
+@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message cluck);
 
 $main::SIG{__WARN__}=\&CGI::Carp::warn;
 $main::SIG{__DIE__}=\&CGI::Carp::die;
-$CGI::Carp::VERSION = '1.14';
+$CGI::Carp::VERSION = '1.20';
 $CGI::Carp::CUSTOM_MSG = undef;
 
 # fancy import routine detects and handles 'errorWrap' specially.
@@ -210,6 +234,7 @@
     my(%routines);
     grep($routines{$_}++,@_,@EXPORT);
     $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
+    $WARN++ if $routines{'warningsToBrowser'};
     my($oldlevel) = $Exporter::ExportLevel;
     $Exporter::ExportLevel = 1;
     Exporter::import($pkg,keys %routines);
@@ -243,23 +268,40 @@
     my $message = shift;
     my($file,$line,$id) = id(1);
     $message .= " at $file line $line.\n" unless $message=~/\n$/;
+    _warn($message) if $WARN;
     my $stamp = stamp;
     $message=~s/^/$stamp/gm;
     realwarn $message;
 }
 
+sub _warn {
+    my $msg = shift;
+    if ($EMIT_WARNINGS) {
+	# We need to mangle the message a bit to make it a valid HTML
+	# comment.  This is done by substituting similar-looking ISO
+	# 8859-1 characters for <, > and -.  This is a hack.
+	$msg =~ tr/<>-/\253\273\255/;
+	chomp $msg;
+	print STDOUT "\n";
+    } else {
+	push @WARNINGS, $msg;
+    }
+}
+
+sub ineval { _longmess() =~ /eval [\{\']/m }
+
 # The mod_perl package Apache::Registry loads CGI programs by calling
 # eval.  These evals don't count when looking at the stack backtrace.
 sub _longmess {
     my $message = Carp::longmess();
     my $mod_perl = exists $ENV{MOD_PERL};
     $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl;
-    return( $message );    
+    return $message;    
 }
 
 sub die {
   realdie @_ if ineval;
-  my $message = shift;
+  my ($message) = @_;
   my $time = scalar(localtime);
   my($file,$line,$id) = id(1);
   $message .= " at $file line $line." unless $message=~/\n$/;
@@ -299,6 +341,11 @@
 	( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
 }
 
+sub warningsToBrowser {
+    $EMIT_WARNINGS = @_ ? shift : 1;
+    _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS;
+}
+
 # headers
 sub fatalsToBrowser {
     my($msg) = @_;
@@ -318,6 +365,8 @@
     print STDOUT "Content-type: text/html\n\n" 
 	unless $mod_perl;
 
+    warningsToBrowser(1);    # emit warnings before dying
+
     if ($CUSTOM_MSG) {
 	if (ref($CUSTOM_MSG) eq 'CODE') {
 	    &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
@@ -329,14 +378,13 @@
     
     my $mess = <Software error:
-$msg
+
$msg

 

 $outer_message
 END
     ;
 
-    if ($mod_perl) {
-	my $r = Apache->request;
+    if ($mod_perl && (my $r = Apache->request)) {
 	# If bytes have already been sent, then
 	# we print the message out directly.
 	# Otherwise we make a custom error
diff -ruN perl-5.6.0/lib/CGI/Cookie.pm AP622_source/lib/CGI/Cookie.pm
--- perl-5.6.0/lib/CGI/Cookie.pm	Wed Jul  5 14:34:15 2000
+++ AP622_source/lib/CGI/Cookie.pm	Mon Nov  6 19:21:28 2000
@@ -13,9 +13,9 @@
 # wish, but if you redistribute a modified version, please attach a note
 # listing the modifications you have made.
 
-$CGI::Cookie::VERSION='1.12';
+$CGI::Cookie::VERSION='1.16';
 
-use CGI qw(-no_debug);
+use CGI::Util qw(rearrange unescape escape);
 use overload '""' => \&as_string,
     'cmp' => \&compare,
     'fallback'=>1;
@@ -40,17 +40,18 @@
     my %results;
     my($key,$value);
 
-    my(@pairs) = split("; ",$raw_cookie);
+    my(@pairs) = split("; ?",$raw_cookie);
     foreach (@pairs) {
-	if (/^([^=]+)=(.*)/) {
-	    $key = $1;
-	    $value = $2;
-	}
-	else {
-	    $key = $_;
-	    $value = '';
-	}
-	$results{$key} = $value;
+      s/\s*(.*?)\s*/$1/;
+      if (/^([^=]+)=(.*)/) {
+	$key = $1;
+	$value = $2;
+      }
+      else {
+	$key = $_;
+	$value = '';
+      }
+      $results{$key} = $value;
     }
     return \%results unless wantarray;
     return %results;
@@ -60,14 +61,18 @@
     my ($self,$raw_cookie) = @_;
     my %results;
 
-    my(@pairs) = split("; ",$raw_cookie);
+    my(@pairs) = split("; ?",$raw_cookie);
     foreach (@pairs) {
-	my($key,$value) = split("=");
-	my(@values) = map CGI::unescape($_),split('&',$value);
-	$key = CGI::unescape($key);
-	# A bug in Netscape can cause several cookies with same name to
-	# appear.  The FIRST one in HTTP_COOKIE is the most recent version.
-	$results{$key} ||= $self->new(-name=>$key,-value=>\@values);
+      s/\s*(.*?)\s*/$1/;
+      my($key,$value) = split("=");
+      my(@values) = map unescape($_),split('&',$value);
+      $key = unescape($key);
+      # Some foreign cookies are not in name=value format, so ignore
+      # them.
+      next if !defined($value);
+      # A bug in Netscape can cause several cookies with same name to
+      # appear.  The FIRST one in HTTP_COOKIE is the most recent version.
+      $results{$key} ||= $self->new(-name=>$key,-value=>\@values);
     }
     return \%results unless wantarray;
     return %results;
@@ -77,7 +82,7 @@
     my $class = shift;
     $class = ref($class) if ref($class);
     my($name,$value,$path,$domain,$secure,$expires) =
-	CGI->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_);
+      rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_);
 
     # Pull out our parameters.
     my @values;
@@ -97,7 +102,7 @@
 	},$class;
 
     # IE requires the path and domain to be present for some reason.
-    $path   = CGI::url(-absolute=>1) unless defined $path;
+    $path   ||= '/';
 # however, this breaks networks which use host tables without fully qualified
 # names, so we comment it out.
 #    $domain = CGI::virtual_host()    unless defined $domain;
@@ -120,8 +125,8 @@
     push(@constant_values,"expires=$expires") if $expires = $self->expires;
     push(@constant_values,'secure') if $secure = $self->secure;
 
-    my($key) = CGI::escape($self->name);
-    my($cookie) = join("=",$key,join("&",map CGI::escape($_),$self->value));
+    my($key) = escape($self->name);
+    my($cookie) = join("=",$key,join("&",map escape($_),$self->value));
     return join("; ",$cookie,@constant_values);
 }
 
@@ -163,7 +168,7 @@
 sub expires {
     my $self = shift;
     my $expires = shift;
-    $self->{'expires'} = CGI::expires($expires,'cookie') if defined $expires;
+    $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires;
     return $self->{'expires'};
 }
 
@@ -252,8 +257,8 @@
 if you specify the path "/cgi-bin", then the cookie will be returned
 to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", and
 "/cgi-bin/customer_service/complain.pl", but not to the script
-"/cgi-private/site_admin.pl".  By default, the path is set to your
-script, so that only it will receive the cookie.
+"/cgi-private/site_admin.pl".  By default, the path is set to "/", so
+that all scripts at your site will receive the cookie.
 
 =item B<4. secure flag>
 
@@ -379,7 +384,7 @@
 	$value = $c->value;
 	@new_value = $c->value(['a','b','c','d']);
 
-B is context sensitive.  In an array context it will return
+B is context sensitive.  In a list context it will return
 the current value of the cookie as an array.  In a scalar context it
 will return the B value of a multivalued cookie.
 
diff -ruN perl-5.6.0/lib/CGI/Pretty.pm AP622_source/lib/CGI/Pretty.pm
--- perl-5.6.0/lib/CGI/Pretty.pm	Wed Jul  5 14:34:15 2000
+++ AP622_source/lib/CGI/Pretty.pm	Mon Nov  6 19:21:28 2000
@@ -10,7 +10,7 @@
 use strict;
 use CGI ();
 
-$CGI::Pretty::VERSION = '1.03';
+$CGI::Pretty::VERSION = '1.04';
 $CGI::DefaultClass = __PACKAGE__;
 $CGI::Pretty::AutoloadClass = 'CGI';
 @CGI::Pretty::ISA = qw( CGI );
@@ -62,19 +62,17 @@
 	sub $tagname { 
 	    # handle various cases in which we're called
 	    # most of this bizarre stuff is to avoid -w errors
-	    shift if \$_[0] && 
-		(!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
-		    (ref(\$_[0]) &&
-		     (substr(ref(\$_[0]),0,3) eq 'CGI' ||
-		    UNIVERSAL::isa(\$_[0],'CGI')));
-	    
+            shift if \$_[0] && 
+                    (ref(\$_[0]) &&
+                     (substr(ref(\$_[0]),0,3) eq 'CGI' ||
+                    UNIVERSAL::isa(\$_[0],'CGI')));
 	    my(\$attr) = '';
 	    if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') {
-		my(\@attr) = make_attributes('',shift);
+		my(\@attr) = make_attributes(shift);
 		\$attr = " \@attr" if \@attr;
 	    }
 
-	    my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U\E");
+	    my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L\E");
 	    return \$tag unless \@_;
 
 	    my \@result;
@@ -130,7 +128,7 @@
     $CGI::Pretty::LINEBREAK = "\n";
 
     # These tags are not prettify'd.
-    @CGI::Pretty::AS_IS = qw( A PRE CODE SCRIPT TEXTAREA );
+    @CGI::Pretty::AS_IS = qw( a pre code script textarea );
 
     1;
 }
diff -ruN perl-5.6.0/lib/CGI/Push.pm AP622_source/lib/CGI/Push.pm
--- perl-5.6.0/lib/CGI/Push.pm	Wed Jul  5 14:34:15 2000
+++ AP622_source/lib/CGI/Push.pm	Mon Nov  6 19:21:28 2000
@@ -16,8 +16,9 @@
 # The most recent version and complete docs are available at:
 #   http://stein.cshl.org/WWW/software/CGI/
 
-$CGI::Push::VERSION='1.01';
+$CGI::Push::VERSION='1.03';
 use CGI;
+use CGI::Util 'rearrange';
 @ISA = ('CGI');
 
 $CGI::DefaultClass = 'CGI::Push';
@@ -37,7 +38,7 @@
 
     my (@header);
     my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,@other) =
-	$self->rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES],@p);
+	rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES],@p);
     $type = 'text/html' unless $type;
     $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE';
     $delay = 1 unless defined($delay);
@@ -53,13 +54,13 @@
     push(@o,'-nph'=>1);
     print $self->header(@o);
     print "${boundary}$CGI::CRLF";
-    
+
     # now we enter a little loop
     my @contents;
     while (1) {
 	last unless (@contents = &$callback($self,++$COUNTER)) && defined($contents[0]);
 	print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" 
-	    unless $type eq 'dynamic';
+	    unless $type =~ /^dynamic|heterogeneous$/i;
 	print @contents,"$CGI::CRLF";
 	print "${boundary}$CGI::CRLF";
 	do_sleep($self->push_delay()) if $self->push_delay();
@@ -142,6 +143,9 @@
 in such a way that it will replace what was there beforehand.  The
 technique will work with HTML pages as well as with graphics files, 
 allowing you to create animated GIFs.
+
+Only Netscape Navigator supports server push.  Internet Explorer
+browsers do not.
 
 =head1 USING CGI::Push
 
diff -ruN perl-5.6.0/lib/CGI/Util.pm AP622_source/lib/CGI/Util.pm
--- perl-5.6.0/lib/CGI/Util.pm	Wed Dec 31 16:00:00 1969
+++ AP622_source/lib/CGI/Util.pm	Mon Nov  6 19:21:28 2000
@@ -0,0 +1,180 @@
+package CGI::Util;
+
+use strict;
+use vars '$VERSION','@EXPORT_OK','@ISA','$EBCDIC','@A2E';
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(rearrange make_attributes unescape escape expires);
+
+$VERSION = '1.1';
+
+$EBCDIC = "\t" ne "\011";
+if ($EBCDIC) {
+@A2E = (
+  0,  1,  2,  3, 55, 45, 46, 47, 22,  5, 21, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
+ 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
+240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
+124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
+215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
+121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
+151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161,  7,
+ 32, 33, 34, 35, 36, 37,  6, 23, 40, 41, 42, 43, 44,  9, 10, 27,
+ 48, 49, 26, 51, 52, 53, 54,  8, 56, 57, 58, 59,  4, 20, 62,255,
+ 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
+144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
+100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
+172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
+ 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
+140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
+      );
+}
+
+# Smart rearrangement of parameters to allow named parameter
+# calling.  We do the rearangement if:
+# the first parameter begins with a -
+sub rearrange {
+    my($order,@param) = @_;
+    return () unless @param;
+
+    if (ref($param[0]) eq 'HASH') {
+	@param = %{$param[0]};
+    } else {
+	return @param 
+	    unless (defined($param[0]) && substr($param[0],0,1) eq '-');
+    }
+
+    # map parameters into positional indices
+    my ($i,%pos);
+    $i = 0;
+    foreach (@$order) {
+	foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; }
+	$i++;
+    }
+
+    my (@result,%leftover);
+    $#result = $#$order;  # preextend
+    while (@param) {
+	my $key = lc(shift(@param));
+	$key =~ s/^\-//;
+	if (exists $pos{$key}) {
+	    $result[$pos{$key}] = shift(@param);
+	} else {
+	    $leftover{$key} = shift(@param);
+	}
+    }
+
+    push (@result,make_attributes(\%leftover,1)) if %leftover;
+    @result;
+}
+
+sub make_attributes {
+    my $attr = shift;
+    return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
+    my $escape = shift || 0;
+    my(@att);
+    foreach (keys %{$attr}) {
+	my($key) = $_;
+	$key=~s/^\-//;     # get rid of initial - if present
+	$key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes
+	my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_};
+	push(@att,defined($attr->{$_}) ? qq/$key="$value"/ : qq/$key/);
+    }
+    return @att;
+}
+
+sub simple_escape {
+  return unless defined(my $toencode = shift);
+  $toencode =~ s{&}{&}gso;
+  $toencode =~ s{<}{<}gso;
+  $toencode =~ s{>}{>}gso;
+  $toencode =~ s{\"}{"}gso;
+# Doesn't work.  Can't work.  forget it.
+#  $toencode =~ s{\x8b}{‹}gso;
+#  $toencode =~ s{\x9b}{›}gso;
+  $toencode;
+}
+
+# unescape URL-encoded data
+sub unescape {
+  shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
+  my $todecode = shift;
+  return undef unless defined($todecode);
+  $todecode =~ tr/+/ /;       # pluses become spaces
+    if ($EBCDIC) {
+      $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge;
+    } else {
+      $todecode =~ s/%([0-9a-fA-F]{2})/chr hex($1)/ge;
+    }
+  return $todecode;
+}
+
+# URL-encode data
+sub escape {
+  shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass);
+  my $toencode = shift;
+  return undef unless defined($toencode);
+  $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
+  return $toencode;
+}
+
+# This internal routine creates date strings suitable for use in
+# cookies and HTTP headers.  (They differ, unfortunately.)
+# Thanks to Mark Fisher for this.
+sub expires {
+    my($time,$format) = @_;
+    $format ||= 'http';
+
+    my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
+    my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
+
+    # pass through preformatted dates for the sake of expire_calc()
+    $time = expire_calc($time);
+    return $time unless $time =~ /^\d+$/;
+
+    # make HTTP/cookie date string from GMT'ed time
+    # (cookies use '-' as date separator, HTTP uses ' ')
+    my($sc) = ' ';
+    $sc = '-' if $format eq "cookie";
+    my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
+    $year += 1900;
+    return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
+                   $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
+}
+
+# This internal routine creates an expires time exactly some number of
+# hours from the current time.  It incorporates modifications from 
+# Mark Fisher.
+sub expire_calc {
+    my($time) = @_;
+    my(%mult) = ('s'=>1,
+                 'm'=>60,
+                 'h'=>60*60,
+                 'd'=>60*60*24,
+                 'M'=>60*60*24*30,
+                 'y'=>60*60*24*365);
+    # format for time can be in any of the forms...
+    # "now" -- expire immediately
+    # "+180s" -- in 180 seconds
+    # "+2m" -- in 2 minutes
+    # "+12h" -- in 12 hours
+    # "+1d"  -- in 1 day
+    # "+3M"  -- in 3 months
+    # "+2y"  -- in 2 years
+    # "-3m"  -- 3 minutes ago(!)
+    # If you don't supply one of these forms, we assume you are
+    # specifying the date yourself
+    my($offset);
+    if (!$time || (lc($time) eq 'now')) {
+        $offset = 0;
+    } elsif ($time=~/^\d+/) {
+        return $time;
+    } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
+        $offset = ($mult{$2} || 1)*$1;
+    } else {
+        return $time;
+    }
+    return (time+$offset);
+}
+
+1;
diff -ruN perl-5.6.0/lib/CGI.pm AP622_source/lib/CGI.pm
--- perl-5.6.0/lib/CGI.pm	Wed Jul  5 14:34:15 2000
+++ AP622_source/lib/CGI.pm	Mon Nov  6 19:21:28 2000
@@ -17,38 +17,52 @@
 # The most recent version and complete docs are available at:
 #   http://stein.cshl.org/WWW/software/CGI/
 
-$CGI::revision = '$Id: CGI.pm,v 1.19 1999/08/31 17:04:37 lstein Exp $';
-$CGI::VERSION='2.56';
+$CGI::revision = '$Id: CGI.pm,v 1.45 2000/09/13 02:55:41 lstein Exp $';
+$CGI::VERSION='2.74';
 
 # HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
 # UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
 # $TempFile::TMPDIRECTORY = '/usr/tmp';
+use CGI::Util qw(rearrange make_attributes unescape escape expires);
+
+use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
+			   'DTD/xhtml1-transitional.dtd'];
 
 # >>>>> Here are some globals that you might want to adjust <<<<<<
 sub initialize_globals {
     # Set this to 1 to enable copious autoloader debugging messages
     $AUTOLOAD_DEBUG = 0;
+    
+    # Set this to 1 to generate XTML-compatible output
+    $XHTML = 1;
 
     # Change this to the preferred DTD to print in start_html()
     # or use default_dtd('text of DTD to use');
-    $DEFAULT_DTD = '-//IETF//DTD HTML//EN';
+    $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
+		     'http://www.w3.org/TR/html4/loose.dtd' ] ;
+
+    # Set this to 1 to enable NOSTICKY scripts
+    # or: 
+    #    1) use CGI qw(-nosticky)
+    #    2) $CGI::nosticky(1)
+    $NOSTICKY = 0;
 
     # Set this to 1 to enable NPH scripts
     # or: 
     #    1) use CGI qw(-nph)
-    #    2) $CGI::nph(1)
+    #    2) CGI::nph(1)
     #    3) print header(-nph=>1)
     $NPH = 0;
 
-    # Set this to 1 to disable debugging from the
-    # command line
-    $NO_DEBUG = 0;
+    # Set this to 1 to enable debugging from @ARGV
+    # Set to 2 to enable debugging from STDIN
+    $DEBUG = 1;
 
     # Set this to 1 to make the temporary files created
     # during file uploads safe from prying eyes
     # or do...
     #    1) use CGI qw(:private_tempfiles)
-    #    2) $CGI::private_tempfiles(1);
+    #    2) CGI::private_tempfiles(1);
     $PRIVATE_TEMPFILES = 0;
 
     # Set this to a positive value to limit the size of a POSTing
@@ -65,13 +79,15 @@
     $HEADERS_ONCE = 0;
 
     # separate the name=value pairs by semicolons rather than ampersands
-    $USE_PARAM_SEMICOLONS = 0;
+    $USE_PARAM_SEMICOLONS = 1;
 
     # Other globals that you shouldn't worry about.
     undef $Q;
     $BEEN_THERE = 0;
     undef @QUERY_PARAM;
     undef %EXPORT;
+    undef $QUERY_CHARSET;
+    undef %QUERY_FIELDNAMES;
 
     # prevent complaints by mod_perl
     1;
@@ -153,27 +169,6 @@
   $CRLF = "\015\012";
 }
 
-if ($EBCDIC) {
-@A2E = (
-  0,  1,  2,  3, 55, 45, 46, 47, 22,  5, 21, 11, 12, 13, 14, 15,
- 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31,
- 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97,
-240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111,
-124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214,
-215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109,
-121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150,
-151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161,  7,
- 32, 33, 34, 35, 36, 37,  6, 23, 40, 41, 42, 43, 44,  9, 10, 27,
- 48, 49, 26, 51, 52, 53, 54,  8, 56, 57, 58, 59,  4, 20, 62,255,
- 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188,
-144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171,
-100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119,
-172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89,
- 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87,
-140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223
-      );
-}
-
 if ($needs_binmode) {
     $CGI::DefaultClass->binmode(main::STDOUT);
     $CGI::DefaultClass->binmode(main::STDIN);
@@ -184,7 +179,7 @@
 		':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
 			   tt u i b blockquote pre img a address cite samp dfn html head
 			   base body Link nextid title meta kbd start_html end_html
-			   input Select option comment/],
+			   input Select option comment charset escapeHTML/],
 		':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param 
 			   embed basefont style span layer ilayer font frameset frame script small big/],
 		':netscape'=>[qw/blink fontsize center/],
@@ -195,7 +190,7 @@
 		':cgi'=>[qw/param upload path_info path_translated url self_url script_name cookie Dump
 			 raw_cookie request_method query_string Accept user_agent remote_host content_type
 			 remote_addr referer server_name server_software server_port server_protocol
-			 virtual_host remote_ident auth_type http use_named_parameters 
+			 virtual_host remote_ident auth_type http
 			 save_parameters restore_parameters param_fetch
 			 remote_user user_name header redirect import_names put 
 			 Delete Delete_all url_param cgi_error/],
@@ -259,9 +254,9 @@
     my($class,$initializer) = @_;
     my $self = {};
     bless $self,ref $class || $class || $DefaultClass;
-    if ($MOD_PERL) {
-	Apache->request->register_cleanup(\&CGI::_reset_globals);
-	undef $NPH;
+    if ($MOD_PERL && defined Apache->request) {
+      Apache->request->register_cleanup(\&CGI::_reset_globals);
+      undef $NPH;
     }
     $self->_reset_globals if $PERLEX;
     $self->init($initializer);
@@ -291,10 +286,10 @@
     # For compatibility between old calling style and use_named_parameters() style, 
     # we have to special case for a single parameter present.
     if (@p > 1) {
-	($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
+	($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
 	my(@values);
 
-	if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
+	if (substr($p[0],0,1) eq '-') {
 	    @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
 	} else {
 	    foreach ($value,@other) {
@@ -322,7 +317,7 @@
 	$Q = $CGI::DefaultClass->new unless defined($Q);
 	unshift(@_,$Q);
     }
-    return @_;
+    return wantarray ? @_ : $Q;
 }
 
 sub self_or_CGI {
@@ -357,10 +352,12 @@
     # if we get called more than once, we want to initialize
     # ourselves from the original query (which may be gone
     # if it was read from STDIN originally.)
-    if (@QUERY_PARAM && !defined($initializer)) {
+    if (defined(@QUERY_PARAM) && !defined($initializer)) {
 	foreach (@QUERY_PARAM) {
 	    $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
 	}
+	$self->charset($QUERY_CHARSET);
+	$self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
 	return;
     }
 
@@ -369,6 +366,9 @@
 
     $fh = to_filehandle($initializer) if $initializer;
 
+    # set charset to the safe ISO-8859-1
+    $self->charset('ISO-8859-1');
+
   METHOD: {
 
       # avoid unreasonably large postings
@@ -432,6 +432,7 @@
 	      $query_string = Apache->request->args;
 	  } else {
 	      $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+	      $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
 	  }
 	  last METHOD;
       }
@@ -450,13 +451,13 @@
       # Check the command line and then the standard input for data.
       # We use the shellwords package in order to behave the way that
       # UN*X programmers expect.
-      $query_string = read_from_cmdline() unless $NO_DEBUG;
+      $query_string = read_from_cmdline() if $DEBUG;
   }
 
     # We now have the query string in hand.  We do slightly
     # different things for keyword lists and parameter lists.
     if (defined $query_string && $query_string) {
-	if ($query_string =~ /=/) {
+	if ($query_string =~ /[&=;]/) {
 	    $self->parse_params($query_string);
 	} else {
 	    $self->add_parameter('keywords');
@@ -479,6 +480,7 @@
     # Clear out our default submission button flag if present
     $self->delete('.submit');
     $self->delete('.cgifields');
+
     $self->save_request unless $initializer;
 }
 
@@ -518,29 +520,6 @@
     return $self->{'.cgi_error'};
 }
 
-# unescape URL-encoded data
-sub unescape {
-  shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass);
-  my $todecode = shift;
-  return undef unless defined($todecode);
-  $todecode =~ tr/+/ /;       # pluses become spaces
-    if ($EBCDIC) {
-      $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",$A2E[hex($1)])/ge;
-    } else {
-      $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
-    }
-  return $todecode;
-}
-
-# URL-encode data
-sub escape {
-  shift() if ref($_[0]) || (defined $_[1] && $_[0] eq $DefaultClass);
-  my $toencode = shift;
-  return undef unless defined($toencode);
-  $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
-  return $toencode;
-}
-
 sub save_request {
     my($self) = @_;
     # We're going to play with the package globals now so that if we get called
@@ -548,8 +527,11 @@
     # us to have several of these objects.
     @QUERY_PARAM = $self->param; # save list of parameters
     foreach (@QUERY_PARAM) {
-	$QUERY_PARAM{$_}=$self->{$_};
+      next unless defined $_;
+      $QUERY_PARAM{$_}=$self->{$_};
     }
+    $QUERY_CHARSET = $self->charset;
+    %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
 }
 
 sub parse_params {
@@ -558,6 +540,7 @@
     my($param,$value);
     foreach (@pairs) {
 	($param,$value) = split('=',$_,2);
+	$value = '' unless defined $value;
 	$param = unescape($param);
 	$value = unescape($value);
 	$self->add_parameter($param);
@@ -567,6 +550,7 @@
 
 sub add_parameter {
     my($self,$param)=@_;
+    return unless defined $param;
     push (@{$self->{'.parameters'}},$param) 
 	unless defined($self->{$param});
 }
@@ -586,28 +570,27 @@
 sub _make_tag_func {
     my ($self,$tagname) = @_;
     my $func = qq(
-	sub $tagname { 
-	    shift if \$_[0] && 
-#		(!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
-		    (ref(\$_[0]) &&
-		     (substr(ref(\$_[0]),0,3) eq 'CGI' ||
-		    UNIVERSAL::isa(\$_[0],'CGI')));
-	    
+	sub $tagname {
+            shift if \$_[0] && 
+                    (ref(\$_[0]) &&
+                     (substr(ref(\$_[0]),0,3) eq 'CGI' ||
+                    UNIVERSAL::isa(\$_[0],'CGI')));
 	    my(\$attr) = '';
 	    if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') {
-		my(\@attr) = make_attributes( '',shift() );
+		my(\@attr) = make_attributes(shift()||undef,1);
 		\$attr = " \@attr" if \@attr;
 	    }
 	);
     if ($tagname=~/start_(\w+)/i) {
-	$func .= qq! return "<\U$1\E\$attr>";} !;
+	$func .= qq! return "<\L$1\E\$attr>";} !;
     } elsif ($tagname=~/end_(\w+)/i) {
-	$func .= qq! return "<\U/$1\E>"; } !;
+	$func .= qq! return "<\L/$1\E>"; } !;
     } else {
 	$func .= qq#
-	    my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U\E");
-	    return \$tag unless \@_;
-	    my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
+	    return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@_;
+	    my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L\E");
+	    my \@result = map { "\$tag\$_\$untag" } 
+                              (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
 	    return "\@result";
             }#;
     }
@@ -620,47 +603,6 @@
     goto &$func;
 }
 
-# PRIVATE SUBROUTINE
-# Smart rearrangement of parameters to allow named parameter
-# calling.  We do the rearangement if:
-# 1. The first parameter begins with a -
-# 2. The use_named_parameters() method returns true
-sub rearrange {
-    my($self,$order,@param) = @_;
-    return () unless @param;
-
-    if (ref($param[0]) eq 'HASH') {
-	@param = %{$param[0]};
-    } else {
-	return @param 
-	    unless (defined($param[0]) && substr($param[0],0,1) eq '-')
-		|| $self->use_named_parameters;
-    }
-
-    # map parameters into positional indices
-    my ($i,%pos);
-    $i = 0;
-    foreach (@$order) {
-	foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; }
-	$i++;
-    }
-
-    my (@result,%leftover);
-    $#result = $#$order;  # preextend
-    while (@param) {
-	my $key = uc(shift(@param));
-	$key =~ s/^\-//;
-	if (exists $pos{$key}) {
-	    $result[$pos{$key}] = shift(@param);
-	} else {
-	    $leftover{$key} = shift(@param);
-	}
-    }
-
-    push (@result,$self->make_attributes(\%leftover)) if %leftover;
-    @result;
-}
-
 sub _compile {
     my($func) = $AUTOLOAD;
     my($pack,$func_name);
@@ -711,8 +653,13 @@
     foreach (@_) {
 	$HEADERS_ONCE++,         next if /^[:-]unique_headers$/;
 	$NPH++,                  next if /^[:-]nph$/;
-	$NO_DEBUG++,             next if /^[:-]no_?[Dd]ebug$/;
+	$NOSTICKY++,             next if /^[:-]nosticky$/;
+	$DEBUG=0,                next if /^[:-]no_?[Dd]ebug$/;
+	$DEBUG=2,                next if /^[:-][Dd]ebug$/;
 	$USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
+	$XHTML++,                next if /^[:-]xhtml$/;
+	$XHTML=0,                next if /^[:-]no_?xhtml$/;
+	$USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
 	$PRIVATE_TEMPFILES++,    next if /^[:-]private_tempfiles$/;
 	$EXPORT{$_}++,           next if /^[:-]any$/;
 	$compile++,              next if /^[:-]compile$/;
@@ -736,6 +683,12 @@
     _compile_all(keys %EXPORT) if $compile;
 }
 
+sub charset {
+  my ($self,$charset) = self_or_default(@_);
+  $self->{'.charset'} = $charset if defined $charset;
+  $self->{'.charset'};
+}
+
 ###############################################################################
 ################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
 ###############################################################################
@@ -756,21 +709,6 @@
 sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; }
 END_OF_FUNC
 
-'use_named_parameters' => <<'END_OF_FUNC',
-#### Method: use_named_parameters
-# Force CGI.pm to use named parameter-style method calls
-# rather than positional parameters.  The same effect
-# will happen automatically if the first parameter
-# begins with a -.
-sub use_named_parameters {
-    my($self,$use_named) = self_or_default(@_);
-    return $self->{'.named'} unless defined ($use_named);
-
-    # stupidity to avoid annoying warnings
-    return $self->{'.named'}=$use_named;
-}
-END_OF_FUNC
-
 'new_MultipartBuffer' => <<'END_OF_FUNC',
 # Create a new multipart buffer
 sub new_MultipartBuffer {
@@ -794,7 +732,8 @@
 # Deletes the named parameter entirely.
 ####
 sub delete {
-    my($self,$name) = self_or_default(@_);
+    my($self,@p) = self_or_default(@_);
+    my($name) = rearrange([NAME],@p);
     CORE::delete $self->{$name};
     CORE::delete $self->{'.fieldnames'}->{$name};
     @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
@@ -920,13 +859,17 @@
 'TIEHASH' => <<'END_OF_FUNC',
 sub TIEHASH { 
     return $_[1] if defined $_[1];
-    return $Q || new shift;
+    return $Q ||= new shift;
 }
 END_OF_FUNC
 
 'STORE' => <<'END_OF_FUNC',
 sub STORE {
-    $_[0]->param($_[1],split("\0",$_[2]));
+    my $self = shift;
+    my $tag  = shift;
+    my $vals = shift;
+    my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
+    $self->param(-name=>$tag,-value=>\@vals);
 }
 END_OF_FUNC
 
@@ -976,7 +919,7 @@
 'append' => <<'EOF',
 sub append {
     my($self,@p) = @_;
-    my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
+    my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
     my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
     if (@values) {
 	$self->add_parameter($name);
@@ -1030,21 +973,6 @@
 }
 END_OF_FUNC
 
-'make_attributes' => <<'END_OF_FUNC',
-sub make_attributes {
-    my($self,$attr) = @_;
-    return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
-    my(@att);
-    foreach (keys %{$attr}) {
-	my($key) = $_;
-	$key=~s/^\-//;     # get rid of initial - if present
-	$key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
-	push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/);
-    }
-    return @att;
-}
-END_OF_FUNC
-
 #### Method: url_param
 # Return a parameter in the QUERY_STRING, regardless of
 # whether this was a POST or a GET
@@ -1076,13 +1004,13 @@
 }
 END_OF_FUNC
 
-#### Method: dump
+#### Method: Dump
 # Returns a string in which all the known parameter/value 
 # pairs are represented as nested lists, mainly for the purposes 
 # of debugging.
 ####
-'dump' => <<'END_OF_FUNC',
-sub dump {
+'Dump' => <<'END_OF_FUNC',
+sub Dump {
     my($self) = self_or_default(@_);
     my($param,$value,@result);
     return '
    ' unless $self->param;
@@ -1109,7 +1037,7 @@
 ####
 'as_string' => <<'END_OF_FUNC',
 sub as_string {
-    &dump(@_);
+    &Dump(@_);
 }
 END_OF_FUNC
 
@@ -1131,6 +1059,9 @@
 	    print $filehandle "$escaped_param=",escape("$value"),"\n";
 	}
     }
+    foreach (keys %{$self->{'.fieldnames'}}) {
+          print $filehandle ".cgifields=",escape("$_"),"\n";
+    }
     print $filehandle "=\n";    # end of record
 }
 END_OF_FUNC
@@ -1167,7 +1098,7 @@
 'multipart_init' => <<'END_OF_FUNC',
 sub multipart_init {
     my($self,@p) = self_or_default(@_);
-    my($boundary,@other) = $self->rearrange([BOUNDARY],@p);
+    my($boundary,@other) = rearrange([BOUNDARY],@p);
     $boundary = $boundary || '------- =_aaaaaaaaaa0';
     $self->{'separator'} = "\n--$boundary\n";
     $type = SERVER_PUSH($boundary);
@@ -1189,7 +1120,7 @@
 'multipart_start' => <<'END_OF_FUNC',
 sub multipart_start {
     my($self,@p) = self_or_default(@_);
-    my($type,@other) = $self->rearrange([TYPE],@p);
+    my($type,@other) = rearrange([TYPE],@p);
     $type = $type || 'text/html';
     return $self->header(
 	-type => $type,
@@ -1224,19 +1155,28 @@
 
     return undef if $self->{'.header_printed'}++ and $HEADERS_ONCE;
 
-    my($type,$status,$cookie,$target,$expires,$nph,@other) = 
-	$self->rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
-			  STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
+    my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,@other) = 
+	rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
+			    'STATUS',['COOKIE','COOKIES'],'TARGET',
+                            'EXPIRES','NPH','CHARSET',
+                            'ATTACHMENT'],@p);
+
+    $nph     ||= $NPH;
+    if (defined $charset) {
+      $self->charset($charset);
+    } else {
+      $charset = $self->charset;
+    }
 
-    $nph ||= $NPH;
     # rearrange() was designed for the HTML portion, so we
     # need to fix it up a little.
     foreach (@other) {
         next unless my($header,$value) = /([^\s=]+)=\"?(.+?)\"?$/;
-	($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e;
+	($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
     }
 
     $type ||= 'text/html' unless defined($type);
+    $type .= "; charset=$charset" if $type ne '' and $type =~ m!^text/! and $type !~ /\bcharset\b/;
 
     # Maybe future compatibility.  Maybe not.
     my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
@@ -1259,6 +1199,7 @@
 	if $expires;
     push(@header,"Date: " . expires(0,'http')) if $expires || $cookie;
     push(@header,"Pragma: no-cache") if $self->cache();
+    push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
     push(@header,@other);
     push(@header,"Content-Type: $type") if $type ne '';
 
@@ -1296,8 +1237,8 @@
 'redirect' => <<'END_OF_FUNC',
 sub redirect {
     my($self,@p) = self_or_default(@_);
-    my($url,$target,$cookie,$nph,@other) = $self->rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p);
-    $url = $url || $self->self_url;
+    my($url,$target,$cookie,$nph,@other) = rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p);
+    $url ||= $self->self_url;
     my(@o);
     foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
     unshift(@o,
@@ -1334,27 +1275,45 @@
 'start_html' => <<'END_OF_FUNC',
 sub start_html {
     my($self,@p) = &self_or_default(@_);
-    my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,@other) = 
-	$self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD],@p);
+    my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,$lang,@other) = 
+	rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD,LANG],@p);
 
     # strangely enough, the title needs to be escaped as HTML
     # while the author needs to be escaped as a URL
     $title = $self->escapeHTML($title || 'Untitled Document');
     $author = $self->escape($author);
+    $lang ||= 'en-US';
     my(@result);
-    $dtd = $DEFAULT_DTD unless $dtd && $dtd =~ m|^-//|;
-    push(@result,qq()) if $dtd;
-    push(@result,"$title");
-    push(@result,"") if defined $author;
+    if ($dtd) {
+        if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
+            $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
+        } else {
+            $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
+        }
+    } else {
+        $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
+    }
+    if (ref($dtd) && ref($dtd) eq 'ARRAY') {
+        push(@result,qq([0]"\n\t"$dtd->[1]">));
+    } else {
+        push(@result,qq());
+    }
+    push(@result,$XHTML ? qq($title)
+                        : qq($title));
+	if (defined $author) {
+    push(@result,$XHTML ? ""
+								: "");
+	}
 
     if ($base || $xbase || $target) {
 	my $href = $xbase || $self->url('-path'=>1);
-	my $t = $target ? qq/ TARGET="$target"/ : '';
-	push(@result,qq//);
+	my $t = $target ? qq/ target="$target"/ : '';
+	push(@result,$XHTML ? qq() : qq());
     }
 
     if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
-	foreach (keys %$meta) { push(@result,qq()); }
+	foreach (keys %$meta) { push(@result,$XHTML ? qq() 
+			: qq()); }
     }
 
     push(@result,ref($head) ? @$head : $head) if $head;
@@ -1365,13 +1324,13 @@
 
     # handle -noscript parameter
     push(@result,<
+
+
 END
     ;
     my($other) = @other ? " @other" : '';
-    push(@result,"");
+    push(@result,"");
     return join("\n",@result);
 }
 END_OF_FUNC
@@ -1384,45 +1343,73 @@
     my ($self,$style) = @_;
     my (@result);
     my $type = 'text/css';
+
+    my $cdata_start = $XHTML ? "\n\n" : " -->\n";
+
     if (ref($style)) {
-	my($src,$code,$stype,@other) =
-	    $self->rearrange([SRC,CODE,TYPE],
-			     '-foo'=>'bar',	# a trick to allow the '-' to be omitted
-			     ref($style) eq 'ARRAY' ? @$style : %$style);
-	$type = $stype if $stype;
-	push(@result,qq//) if $src;
-	push(@result,style({'type'=>$type},"")) if $code;
+     my($src,$code,$stype,@other) =
+         rearrange([SRC,CODE,TYPE],
+                    '-foo'=>'bar', # a trick to allow the '-' to be omitted
+                    ref($style) eq 'ARRAY' ? @$style : %$style);
+     $type = $stype if $stype;
+     if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
+     { # If it is, push a LINK tag for each one.
+       foreach $src (@$src)
+       {
+         push(@result,qq//) if $src;
+       }
+     }
+     else
+     { # Otherwise, push the single -src, if it exists.
+       push(@result,qq//) if $src;
+      }
+     push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
     } else {
-	push(@result,style({'type'=>$type},""));
+     push(@result,style({'type'=>$type},"$cdata_start\n$style\n$cdata_end"));
     }
     @result;
 }
 END_OF_FUNC
 
-
 '_script' => <<'END_OF_FUNC',
 sub _script {
     my ($self,$script) = @_;
     my (@result);
+
     my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
     foreach $script (@scripts) {
 	my($src,$code,$language);
 	if (ref($script)) { # script is a hash
-	    ($src,$code,$language) =
-		$self->rearrange([SRC,CODE,LANGUAGE],
+	    ($src,$code,$language, $type) =
+		rearrange([SRC,CODE,LANGUAGE,TYPE],
 				 '-foo'=>'bar',	# a trick to allow the '-' to be omitted
 				 ref($script) eq 'ARRAY' ? @$script : %$script);
-	    
+            # User may not have specified language
+            $language ||= 'JavaScript';
+            unless (defined $type) {
+                $type = lc $language;
+                # strip '1.2' from 'javascript1.2'
+                $type =~ s/^(\D+).*$/text\/$1/;
+            }
 	} else {
-	    ($src,$code,$language) = ('',$script,'JavaScript');
+	    ($src,$code,$language, $type) = ('',$script,'JavaScript', 'text/javascript');
 	}
+
+    my $comment = '//';  # javascript by default
+    $comment = '#' if $type=~/perl|tcl/i;
+    $comment = "'" if $type=~/vbscript/i;
+
+    my $cdata_start  =  "\n\n";
+
 	my(@satts);
 	push(@satts,'src'=>$src) if $src;
-	push(@satts,'language'=>$language || 'JavaScript');
-	$code = ""
-	    if $code && $language=~/javascript/i;
-	$code = ""
-	    if $code && $language=~/perl/i;
+	push(@satts,'language'=>$language);
+        push(@satts,'type'=>$type);
+	$code = "$cdata_start$code$cdata_end";
 	push(@result,script({@satts},$code || ''));
     }
     @result;
@@ -1435,7 +1422,7 @@
 ####
 'end_html' => <<'END_OF_FUNC',
 sub end_html {
-    return "";
+    return "";
 }
 END_OF_FUNC
 
@@ -1453,10 +1440,10 @@
 'isindex' => <<'END_OF_FUNC',
 sub isindex {
     my($self,@p) = self_or_default(@_);
-    my($action,@other) = $self->rearrange([ACTION],@p);
-    $action = qq/ACTION="$action"/ if $action;
+    my($action,@other) = rearrange([ACTION],@p);
+    $action = qq/action="$action"/ if $action;
     my($other) = @other ? " @other" : '';
-    return "";
+    return $XHTML ? "" : "";
 }
 END_OF_FUNC
 
@@ -1472,15 +1459,18 @@
     my($self,@p) = self_or_default(@_);
 
     my($method,$action,$enctype,@other) = 
-	$self->rearrange([METHOD,ACTION,ENCTYPE],@p);
+	rearrange([METHOD,ACTION,ENCTYPE],@p);
 
-    $method = $method || 'POST';
+    $method = lc($method) || 'post';
     $enctype = $enctype || &URL_ENCODED;
-    $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
-	'ACTION="'.$self->script_name.'"' : '';
+    unless (defined $action) {
+       $action = $self->url(-absolute=>1,-path=>1);
+       $action .= "?$ENV{QUERY_STRING}" if $ENV{QUERY_STRING};
+    }
+    $action = qq(action="$action");
     my($other) = @other ? " @other" : '';
     $self->{'.parametersToAdd'}={};
-    return qq/
    \n/;
+    return qq/\n/;
 }
 END_OF_FUNC
 
@@ -1504,14 +1494,13 @@
 'start_multipart_form' => <<'END_OF_FUNC',
 sub start_multipart_form {
     my($self,@p) = self_or_default(@_);
-    if ($self->use_named_parameters || 
-	(defined($param[0]) && substr($param[0],0,1) eq '-')) {
+    if (defined($param[0]) && substr($param[0],0,1) eq '-') {
 	my(%p) = @p;
 	$p{'-enctype'}=&MULTIPART;
 	return $self->startform(%p);
     } else {
 	my($method,$action,@other) = 
-	    $self->rearrange([METHOD,ACTION],@p);
+	    rearrange([METHOD,ACTION],@p);
 	return $self->startform($method,$action,&MULTIPART,@other);
     }
 }
@@ -1523,8 +1512,12 @@
 'endform' => <<'END_OF_FUNC',
 sub endform {
     my($self,@p) = self_or_default(@_);    
-    return wantarray ? ($self->get_fields,"
    ") : 
-                        $self->get_fields ."\n";
+    if ( $NOSTICKY ) {
+    return wantarray ? ("") : "\n";
+    } else {
+    return wantarray ? ($self->get_fields,"") : 
+                        $self->get_fields ."\n";
+    }
 }
 END_OF_FUNC
 
@@ -1542,20 +1535,21 @@
 sub _textfield {
     my($self,$tag,@p) = self_or_default(@_);
     my($name,$default,$size,$maxlength,$override,@other) = 
-	$self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
+	rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
 
     my $current = $override ? $default : 
 	(defined($self->param($name)) ? $self->param($name) : $default);
 
-    $current = defined($current) ? $self->escapeHTML($current) : '';
+    $current = defined($current) ? $self->escapeHTML($current,1) : '';
     $name = defined($name) ? $self->escapeHTML($name) : '';
-    my($s) = defined($size) ? qq/ SIZE=$size/ : '';
-    my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
+    my($s) = defined($size) ? qq/ size=$size/ : '';
+    my($m) = defined($maxlength) ? qq/ maxlength=$maxlength/ : '';
     my($other) = @other ? " @other" : '';
     # this entered at cristy's request to fix problems with file upload fields
     # and WebTV -- not sure it won't break stuff
-    my($value) = $current ne '' ? qq(VALUE="$current") : '';
-    return qq//;
+    my($value) = $current ne '' ? qq(value="$current") : '';
+    return $XHTML ? qq() 
+                  : qq//;
 }
 END_OF_FUNC
 
@@ -1626,17 +1620,17 @@
     my($self,@p) = self_or_default(@_);
     
     my($name,$default,$rows,$cols,$override,@other) =
-	$self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
+	rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
 
     my($current)= $override ? $default :
 	(defined($self->param($name)) ? $self->param($name) : $default);
 
     $name = defined($name) ? $self->escapeHTML($name) : '';
     $current = defined($current) ? $self->escapeHTML($current) : '';
-    my($r) = $rows ? " ROWS=$rows" : '';
-    my($c) = $cols ? " COLS=$cols" : '';
+    my($r) = $rows ? " rows=$rows" : '';
+    my($c) = $cols ? " cols=$cols" : '';
     my($other) = @other ? " @other" : '';
-    return qq{};
+    return qq{};
 }
 END_OF_FUNC
 
@@ -1655,21 +1649,22 @@
 sub button {
     my($self,@p) = self_or_default(@_);
 
-    my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
+    my($label,$value,$script,@other) = rearrange([NAME,[VALUE,LABEL],
 							 [ONCLICK,SCRIPT]],@p);
 
     $label=$self->escapeHTML($label);
-    $value=$self->escapeHTML($value);
+    $value=$self->escapeHTML($value,1);
     $script=$self->escapeHTML($script);
 
     my($name) = '';
     $name = qq/ NAME="$label"/ if $label;
     $value = $value || $label;
     my($val) = '';
-    $val = qq/ VALUE="$value"/ if $value;
-    $script = qq/ ONCLICK="$script"/ if $script;
+    $val = qq/ value="$value"/ if $value;
+    $script = qq/ onclick="$script"/ if $script;
     my($other) = @other ? " @other" : '';
-    return qq//;
+    return $XHTML ? qq()
+                  : qq//;
 }
 END_OF_FUNC
 
@@ -1687,18 +1682,19 @@
 sub submit {
     my($self,@p) = self_or_default(@_);
 
-    my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
+    my($label,$value,@other) = rearrange([NAME,[VALUE,LABEL]],@p);
 
     $label=$self->escapeHTML($label);
-    $value=$self->escapeHTML($value);
+    $value=$self->escapeHTML($value,1);
 
-    my($name) = ' NAME=".submit"';
-    $name = qq/ NAME="$label"/ if defined($label);
+    my($name) = ' name=".submit"' unless $NOSTICKY;
+    $name = qq/ name="$label"/ if defined($label);
     $value = defined($value) ? $value : $label;
     my($val) = '';
-    $val = qq/ VALUE="$value"/ if defined($value);
+    $val = qq/ value="$value"/ if defined($value);
     my($other) = @other ? " @other" : '';
-    return qq//;
+    return $XHTML ? qq()
+                  : qq//;
 }
 END_OF_FUNC
 
@@ -1713,11 +1709,12 @@
 'reset' => <<'END_OF_FUNC',
 sub reset {
     my($self,@p) = self_or_default(@_);
-    my($label,@other) = $self->rearrange([NAME],@p);
+    my($label,@other) = rearrange([NAME],@p);
     $label=$self->escapeHTML($label);
-    my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
+    my($value) = defined($label) ? qq/ value="$label"/ : '';
     my($other) = @other ? " @other" : '';
-    return qq//;
+    return $XHTML ? qq()
+                  : qq//;
 }
 END_OF_FUNC
 
@@ -1737,13 +1734,14 @@
 sub defaults {
     my($self,@p) = self_or_default(@_);
 
-    my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
+    my($label,@other) = rearrange([[NAME,VALUE]],@p);
 
-    $label=$self->escapeHTML($label);
+    $label=$self->escapeHTML($label,1);
     $label = $label || "Defaults";
-    my($value) = qq/ VALUE="$label"/;
+    my($value) = qq/ value="$label"/;
     my($other) = @other ? " @other" : '';
-    return qq//;
+    return $XHTML ? qq()
+                  : qq//;
 }
 END_OF_FUNC
 
@@ -1775,23 +1773,24 @@
     my($self,@p) = self_or_default(@_);
 
     my($name,$checked,$value,$label,$override,@other) = 
-	$self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
+	rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
     
     $value = defined $value ? $value : 'on';
 
     if (!$override && ($self->{'.fieldnames'}->{$name} || 
 		       defined $self->param($name))) {
-	$checked = grep($_ eq $value,$self->param($name)) ? ' CHECKED' : '';
+	$checked = grep($_ eq $value,$self->param($name)) ? ' checked' : '';
     } else {
-	$checked = $checked ? ' CHECKED' : '';
+	$checked = $checked ? qq/ checked/ : '';
     }
     my($the_label) = defined $label ? $label : $name;
     $name = $self->escapeHTML($name);
-    $value = $self->escapeHTML($value);
+    $value = $self->escapeHTML($value,1);
     $the_label = $self->escapeHTML($the_label);
     my($other) = @other ? " @other" : '';
     $self->register_parameter($name);
-    return qq{$the_label};
+    return $XHTML ? qq{$the_label}
+                  : qq{$the_label};
 }
 END_OF_FUNC
 
@@ -1823,7 +1822,7 @@
 
     my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
        $rowheaders,$colheaders,$override,$nolabels,@other) =
-	$self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
+	rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
 			  LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
 			  ROWHEADERS,COLHEADERS,
 			  [OVERRIDE,FORCE],NOLABELS],@p);
@@ -1832,7 +1831,12 @@
 
     my(%checked) = $self->previous_or_default($name,$defaults,$override);
 
-    $break = $linebreak ? "
    " : '';
+	if ($linebreak) {
+    $break = $XHTML ? "
    " : "
    ";
+	}
+	else {
+	$break = '';
+	}
     $name=$self->escapeHTML($name);
 
     # Create the elements
@@ -1842,15 +1846,16 @@
 
     my($other) = @other ? " @other" : '';
     foreach (@values) {
-	$checked = $checked{$_} ? ' CHECKED' : '';
+	$checked = $checked{$_} ? qq/ checked/ : '';
 	$label = '';
 	unless (defined($nolabels) && $nolabels) {
 	    $label = $_;
 	    $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
 	    $label = $self->escapeHTML($label);
 	}
-	$_ = $self->escapeHTML($_);
-	push(@elements,qq/${label}${break}/);
+	$_ = $self->escapeHTML($_,1);
+	push(@elements,$XHTML ? qq(${label}${break})
+                              : qq/${label}${break}/);
     }
     $self->register_parameter($name);
     return wantarray ? @elements : join(' ',@elements)            
@@ -1862,23 +1867,34 @@
 # Escape HTML -- used internally
 'escapeHTML' => <<'END_OF_FUNC',
 sub escapeHTML {
-    my ($self,$toencode) = self_or_default(@_);
-    return undef unless defined($toencode);
-    return $toencode if ref($self) && $self->{'dontescape'};
-
-    $toencode=~s/&/&/g;
-    $toencode=~s/\"/"/g;
-    $toencode=~s/>/>/g;
-    $toencode=~s/{'dontescape'};
+         $toencode =~ s{&}{&}gso;
+         $toencode =~ s{<}{<}gso;
+         $toencode =~ s{>}{>}gso;
+         $toencode =~ s{"}{"}gso;
+         my $latin = uc $self->{'.charset'} eq 'ISO-8859-1' ||
+                     uc $self->{'.charset'} eq 'WINDOWS-1252';
+         if ($latin) {  # bug in some browsers
+                $toencode =~ s{\x8b}{‹}gso;
+                $toencode =~ s{\x9b}{›}gso;
+                if (defined $newlinestoo && $newlinestoo) {
+                     $toencode =~ s{\012}{
}gso;
+                     $toencode =~ s{\015}{
}gso;
+                }
+         }
+         return $toencode;
 }
 END_OF_FUNC
 
 # unescape HTML -- used internally
 'unescapeHTML' => <<'END_OF_FUNC',
 sub unescapeHTML {
-    my $string = ref($_[0]) ? $_[1] : $_[0];
+    my ($self,$string) = CGI::self_or_default(@_);
     return undef unless defined($string);
+    my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
+                                            : 1;
     # thanks to Randal Schwartz for the correct solution to this one
     $string=~ s[&(.*?);]{
 	local $_ = $1;
@@ -1886,8 +1902,8 @@
 	/^quot$/i	? '"' :
         /^gt$/i		? ">" :
 	/^lt$/i		? "<" :
-	/^#(\d+)$/	? chr($1) :
-	/^#x([0-9a-f]+)$/i ? chr(hex($1)) :
+	/^#(\d+)$/ && $latin	     ? chr($1) :
+	/^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
 	$_
 	}gex;
     return $string;
@@ -1898,6 +1914,8 @@
 '_tableize' => <<'END_OF_FUNC',
 sub _tableize {
     my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
+    $rowheaders = [] unless defined $rowheaders;
+    $colheaders = [] unless defined $colheaders;
     my($result);
 
     if (defined($columns)) {
@@ -1908,23 +1926,23 @@
     }
     
     # rearrange into a pretty table
-    $result = "";
+    $result = "
    ";
     my($row,$column);
     unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
-    $result .= "" if @$colheaders;
+    $result .= "" if @{$colheaders};
     foreach (@{$colheaders}) {
-	$result .= "";
+	$result .= "";
     }
     for ($row=0;$row<$rows;$row++) {
-	$result .= "";
-	$result .= "" if @$rowheaders;
+	$result .= "";
+	$result .= "" if @$rowheaders;
 	for ($column=0;$column<$columns;$column++) {
-	    $result .= ""
+	    $result .= ""
 		if defined($elements[$column*$rows + $row]);
 	}
-	$result .= "";
+	$result .= "";
     }
-    $result .= "
    $_$_
    $rowheaders->[$row]
    $rowheaders->[$row]" . $elements[$column*$rows + $row] . "" . $elements[$column*$rows + $row] . "
    ";
+    $result .= "";
     return $result;
 }
 END_OF_FUNC
@@ -1953,7 +1971,7 @@
 
     my($name,$values,$default,$linebreak,$labels,
        $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
-	$self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
+	rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
 			  ROWS,[COLUMNS,COLS],
 			  ROWHEADERS,COLHEADERS,
 			  [OVERRIDE,FORCE],NOLABELS],@p);
@@ -1973,16 +1991,23 @@
 
     my($other) = @other ? " @other" : '';
     foreach (@values) {
-	my($checkit) = $checked eq $_ ? ' CHECKED' : '';
-	my($break) = $linebreak ? '
    ' : '';
+	my($checkit) = $checked eq $_ ? qq/ checked/ : '';
+	my($break);
+	if ($linebreak) {
+    $break = $XHTML ? "
    " : "
    ";
+	}
+	else {
+	$break = '';
+	}
 	my($label)='';
 	unless (defined($nolabels) && $nolabels) {
 	    $label = $_;
 	    $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
-	    $label = $self->escapeHTML($label);
+	    $label = $self->escapeHTML($label,1);
 	}
 	$_=$self->escapeHTML($_);
-	push(@elements,qq/${label}${break}/);
+	push(@elements,$XHTML ? qq(${label}${break})
+                              : qq/${label}${break}/);
     }
     $self->register_parameter($name);
     return wantarray ? @elements : join(' ',@elements) 
@@ -2011,7 +2036,7 @@
     my($self,@p) = self_or_default(@_);
 
     my($name,$values,$default,$labels,$override,@other) =
-	$self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
+	rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
     my($result,$selected);
 
     if (!$override && defined($self->param($name))) {
@@ -2025,17 +2050,17 @@
     my(@values);
     @values = $self->_set_values_and_labels($values,\$labels,$name);
 
-    $result = qq/\n/;
     foreach (@values) {
-	my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
+	my($selectit) = defined($selected) ? ($selected eq $_ ? qq/selected/ : '' ) : '';
 	my($label) = $_;
 	$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
 	my($value) = $self->escapeHTML($_);
-	$label=$self->escapeHTML($label);
-	$result .= "\n";
     }
 
-    $result .= "\n";
+    $result .= "\n";
     return $result;
 }
 END_OF_FUNC
@@ -2065,7 +2090,7 @@
 sub scrolling_list {
     my($self,@p) = self_or_default(@_);
     my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
-	= $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
+	= rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
 			    SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
 
     my($result,@values);
@@ -2074,21 +2099,21 @@
     $size = $size || scalar(@values);
 
     my(%selected) = $self->previous_or_default($name,$defaults,$override);
-    my($is_multiple) = $multiple ? ' MULTIPLE' : '';
-    my($has_size) = $size ? " SIZE=$size" : '';
+    my($is_multiple) = $multiple ? qq/ multiple/ : '';
+    my($has_size) = $size ? qq/ size="$size"/: '';
     my($other) = @other ? " @other" : '';
 
     $name=$self->escapeHTML($name);
-    $result = qq/\n/;
     foreach (@values) {
-	my($selectit) = $selected{$_} ? 'SELECTED' : '';
+	my($selectit) = $selected{$_} ? qq/selected/ : '';
 	my($label) = $_;
 	$label = $labels->{$_} if defined($labels) && defined($labels->{$_});
 	$label=$self->escapeHTML($label);
-	my($value)=$self->escapeHTML($_);
-	$result .= "\n";
     }
-    $result .= "\n";
+    $result .= "\n";
     $self->register_parameter($name);
     return $result;
 }
@@ -2112,10 +2137,10 @@
     # calling scheme, so we have to special-case (darn)
     my(@result,@value);
     my($name,$default,$override,@other) = 
-	$self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
+	rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
 
     my $do_override = 0;
-    if ( ref($p[0]) || substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
+    if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
 	@value = ref($default) ? @{$default} : $default;
 	$do_override = $override;
     } else {
@@ -2130,8 +2155,9 @@
 
     $name=$self->escapeHTML($name);
     foreach (@value) {
-	$_ = defined($_) ? $self->escapeHTML($_) : '';
-	push(@result,qq//);
+	$_ = defined($_) ? $self->escapeHTML($_,1) : '';
+	push @result,$XHTMl ? qq()
+                            : qq();
     }
     return wantarray ? @result : join('',@result);
 }
@@ -2151,12 +2177,13 @@
     my($self,@p) = self_or_default(@_);
 
     my($name,$src,$alignment,@other) =
-	$self->rearrange([NAME,SRC,ALIGN],@p);
+	rearrange([NAME,SRC,ALIGN],@p);
 
-    my($align) = $alignment ? " ALIGN=\U$alignment" : '';
+    my($align) = $alignment ? " align=\U$alignment" : '';
     my($other) = @other ? " @other" : '';
     $name=$self->escapeHTML($name);
-    return qq//;
+    return $XHTML ? qq()
+                  : qq//;
 }
 END_OF_FUNC
 
@@ -2191,24 +2218,28 @@
 'url' => <<'END_OF_FUNC',
 sub url {
     my($self,@p) = self_or_default(@_);
-    my ($relative,$absolute,$full,$path_info,$query) = 
-	$self->rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p);
+    my ($relative,$absolute,$full,$path_info,$query,$base) = 
+	rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE'],@p);
     my $url;
-    $full++ if !($relative || $absolute);
+    $full++ if $base || !($relative || $absolute);
 
     my $path = $self->path_info;
-    my $script_name;
-    if (exists($ENV{REQUEST_URI})) {
-        my $index;
-	$script_name = $ENV{REQUEST_URI};
-        # strip query string
-        substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0;
-        # and path
-        substr($script_name,$index) = '' if exists($ENV{PATH_INFO})
-                                     and ($index = rindex($script_name,$ENV{PATH_INFO})) >= 0;
-    } else {
-	$script_name = $self->script_name;
-    }
+    my $script_name = $self->script_name;
+
+# If anybody knows why I ever wrote this please tell me!
+#    if (exists($ENV{REQUEST_URI})) {
+#        my $index;
+#	$script_name = $ENV{REQUEST_URI};
+#        # strip query string
+#        substr($script_name,$index) = '' if ($index = index($script_name,'?')) >= 0;
+#        # and path
+#        if (exists($ENV{PATH_INFO})) {
+#           (my $encoded_path = $ENV{PATH_INFO}) =~ s!([^a-zA-Z0-9_./-])!uc sprintf("%%%02x",ord($1))!eg;;
+#           substr($script_name,$index) = '' if ($index = rindex($script_name,$encoded_path)) >= 0;
+#         }
+#    } else {
+#	$script_name = $self->script_name;
+#    }
 
     if ($full) {
 	my $protocol = $self->protocol();
@@ -2223,14 +2254,18 @@
 		unless (lc($protocol) eq 'http' && $port == 80)
 		    || (lc($protocol) eq 'https' && $port == 443);
 	}
+        return $url if $base;
 	$url .= $script_name;
     } elsif ($relative) {
 	($url) = $script_name =~ m!([^/]+)$!;
     } elsif ($absolute) {
 	$url = $script_name;
     }
+
     $url .= $path if $path_info and defined $path;
     $url .= "?" . $self->query_string if $query and $self->query_string;
+    $url = '' unless defined $url;
+    $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/uc sprintf("%%%02x",ord($1))/eg;
     return $url;
 }
 
@@ -2252,7 +2287,7 @@
 sub cookie {
     my($self,@p) = self_or_default(@_);
     my($name,$value,$path,$domain,$secure,$expires) =
-	$self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
+	rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
 
     require CGI::Cookie;
 
@@ -2285,69 +2320,6 @@
 }
 END_OF_FUNC
 
-# This internal routine creates an expires time exactly some number of
-# hours from the current time.  It incorporates modifications from 
-# Mark Fisher.
-'expire_calc' => <<'END_OF_FUNC',
-sub expire_calc {
-    my($time) = @_;
-    my(%mult) = ('s'=>1,
-                 'm'=>60,
-                 'h'=>60*60,
-                 'd'=>60*60*24,
-                 'M'=>60*60*24*30,
-                 'y'=>60*60*24*365);
-    # format for time can be in any of the forms...
-    # "now" -- expire immediately
-    # "+180s" -- in 180 seconds
-    # "+2m" -- in 2 minutes
-    # "+12h" -- in 12 hours
-    # "+1d"  -- in 1 day
-    # "+3M"  -- in 3 months
-    # "+2y"  -- in 2 years
-    # "-3m"  -- 3 minutes ago(!)
-    # If you don't supply one of these forms, we assume you are
-    # specifying the date yourself
-    my($offset);
-    if (!$time || (lc($time) eq 'now')) {
-        $offset = 0;
-    } elsif ($time=~/^\d+/) {
-        return $time;
-    } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
-        $offset = ($mult{$2} || 1)*$1;
-    } else {
-        return $time;
-    }
-    return (time+$offset);
-}
-END_OF_FUNC
-
-# This internal routine creates date strings suitable for use in
-# cookies and HTTP headers.  (They differ, unfortunately.)
-# Thanks to Mark Fisher for this.
-'expires' => <<'END_OF_FUNC',
-sub expires {
-    my($time,$format) = @_;
-    $format ||= 'http';
-
-    my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
-    my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
-
-    # pass through preformatted dates for the sake of expire_calc()
-    $time = expire_calc($time);
-    return $time unless $time =~ /^\d+$/;
-
-    # make HTTP/cookie date string from GMT'ed time
-    # (cookies use '-' as date separator, HTTP uses ' ')
-    my($sc) = ' ';
-    $sc = '-' if $format eq "cookie";
-    my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
-    $year += 1900;
-    return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
-                   $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
-}
-END_OF_FUNC
-
 'parse_keywordlist' => <<'END_OF_FUNC',
 sub parse_keywordlist {
     my($self,$tosplit) = @_;
@@ -2361,7 +2333,7 @@
 'param_fetch' => <<'END_OF_FUNC',
 sub param_fetch {
     my($self,@p) = self_or_default(@_);
-    my($name) = $self->rearrange([NAME],@p);
+    my($name) = rearrange([NAME],@p);
     unless (exists($self->{$name})) {
 	$self->add_parameter($name);
 	$self->{$name} = [];
@@ -2443,6 +2415,9 @@
 	    push(@pairs,"$eparam=$value");
 	}
     }
+    foreach (keys %{$self->{'.fieldnames'}}) {
+      push(@pairs,".cgifields=".escape("$_"));
+    }
     return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
 }
 END_OF_FUNC
@@ -2730,6 +2705,17 @@
 }
 END_OF_FUNC
 
+#### Method: nosticky
+# Set or return the NOSTICKY global flag
+####
+'nosticky' => <<'END_OF_FUNC',
+sub nosticky {
+    my ($self,$param) = self_or_CGI(@_);
+    $CGI::NOSTICKY = $param if defined($param);
+    return $CGI::NOSTICKY;
+}
+END_OF_FUNC
+
 #### Method: nph
 # Set or return the NPH global flag
 ####
@@ -2757,8 +2743,12 @@
 ####
 'default_dtd' => <<'END_OF_FUNC',
 sub default_dtd {
-    my ($self,$param) = self_or_CGI(@_);
-    $CGI::DEFAULT_DTD = $param if defined($param);
+    my ($self,$param,$param2) = self_or_CGI(@_);
+    if (defined $param2 && defined $param) {
+        $CGI::DEFAULT_DTD = [ $param, $param2 ];
+    } elsif (defined $param) {
+        $CGI::DEFAULT_DTD = $param;
+    }
     return $CGI::DEFAULT_DTD;
 }
 END_OF_FUNC
@@ -2803,9 +2793,9 @@
 sub read_from_cmdline {
     my($input,@words);
     my($query_string);
-    if (@ARGV) {
+    if ($DEBUG && @ARGV) {
 	@words = @ARGV;
-    } else {
+    } elsif ($DEBUG > 1) {
 	require "shellwords.pl";
 	print STDERR "(offline mode: enter name=value pairs on standard input)\n";
 	chomp(@lines = ); # remove newlines
@@ -2852,7 +2842,7 @@
 	my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
 
 	# Bug:  Netscape doesn't escape quotation marks in file names!!!
-	my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/;
+	my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\"]*)"?/;
 
 	# add this parameter to our list
 	$self->add_parameter($param);
@@ -3010,10 +3000,11 @@
 sub new {
     my($pack,$name,$file,$delete) = @_;
     require Fcntl unless defined &Fcntl::O_RDWR;
-    my $ref = \*{'Fh::' .  ++$FH . quotemeta($name)};
+    my $fv = ++$FH . quotemeta($name);
+    my $ref = \*{"Fh::$fv"};
     sysopen($ref,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
     unlink($file) if $delete;
-    CORE::delete $Fh::{$FH};
+    CORE::delete $Fh::{$fv};
     return bless $ref,$pack;
 }
 END_OF_FUNC
@@ -3073,6 +3064,7 @@
 
     # Netscape seems to be a little bit unreliable
     # about providing boundary strings.
+    my $boundary_read = 0;
     if ($boundary) {
 
 	# Under the MIME spec, the boundary consists of the 
@@ -3089,6 +3081,7 @@
 	$length -= length($boundary);
 	chomp($boundary);               # remove the CRLF
 	$/ = $old;                      # restore old line separator
+        $boundary_read++;
     }
 
     my $self = {LENGTH=>$length,
@@ -3104,7 +3097,9 @@
     my $retval = bless $self,ref $package || $package;
 
     # Read the preamble and the topmost (boundary) line plus the CRLF.
-    while ($self->read(0)) { }
+    unless ($boundary_read) {
+      while ($self->read(0)) { }
+    }
     die "Malformed multipart POST\n" if $self->eof;
 
     return $retval;
@@ -3118,9 +3113,7 @@
     my($ok) = 0;
     my($bad) = 0;
 
-    if ($CGI::OS eq 'VMS') {  # tssk, tssk: inconsistency alert!
-	local($CRLF) = "\015\012";
-    }
+    local($CRLF) = "\015\012" if $CGI::OS eq 'VMS';
 
     do {
 	$self->fillBuffer($FILLUNIT);
@@ -3185,8 +3178,7 @@
     die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
 
     # If the boundary begins the data, then skip past it
-    # and return undef.  The +2 here is a fiendish plot to
-    # remove the CR/LF pair at the end of the boundary.
+    # and return undef.
     if ($start == 0) {
 
 	# clear us out completely if we've hit the last boundary.
@@ -3197,7 +3189,8 @@
 	}
 
 	# just remove the boundary.
-	substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
+	substr($self->{BUFFER},0,length($self->{BOUNDARY}))='';
+        $self->{BUFFER} =~ s/^\012\015?//;
 	return undef;
     }
 
@@ -3280,17 +3273,18 @@
 unless ($TMPDIRECTORY) {
     @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
 	   "C:${SL}temp","${SL}tmp","${SL}temp",
-	   "${vol}${SL}Temporary Items","${SL}sys\$scratch",
-	   "${SL}WWW_ROOT");
+	   "${vol}${SL}Temporary Items",
+           "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH");
     unshift(@TEMP,$ENV{'TMPDIR'}) if exists $ENV{'TMPDIR'};
 
-    #
+    # this feature was supposed to provide per-user tmpfiles, but
+    # it is problematic.
     #    unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
     # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
     #    : can generate a 'getpwuid() not implemented' exception, even though
     #    : it's never called.  Found under DOS/Win with the DJGPP perl port.
     #    : Refer to getpwuid() only at run-time if we're fortunate and have  UNIX.
-    unshift(@TEMP,(eval {(getpwuid($<))[7]}).'/tmp') if $CGI::OS eq 'UNIX';
+    # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
 
     foreach (@TEMP) {
 	do {$TM