diff options
author | Gurusamy Sarathy <gsar@cpan.org> | 1998-02-09 23:09:40 +0000 |
---|---|---|
committer | Gurusamy Sarathy <gsar@cpan.org> | 1998-02-09 23:09:40 +0000 |
commit | 837485b6cd4b757519a4ac6f03f3857c2fcf4844 (patch) | |
tree | f8a5bcaa5cc60df2da6db55f7faced65ca3a55f1 | |
parent | 565764a853a177193a027e73655fad354d57fc10 (diff) | |
parent | ef50df4b2435a16251e94335bad8aa9485e4478c (diff) | |
download | perl-837485b6cd4b757519a4ac6f03f3857c2fcf4844.tar.gz |
[asperl] integrate win32 branch contents
p4raw-id: //depot/asperl@493
88 files changed, 2281 insertions, 945 deletions
@@ -5464,13 +5464,13 @@ fi cat <<EOM -Previous version of $package used the standard IO mechanisms as defined in -<stdio.h>. Versions 5.003_02 and later of perl allow alternate IO +Previous version of $package used the standard IO mechanisms as defined +in <stdio.h>. Versions 5.003_02 and later of perl allow alternate IO mechanisms via a "PerlIO" abstraction, but the stdio mechanism is still -the default and is the only supported mechanism. This abstraction -layer can use AT&T's sfio (if you already have sfio installed) or -fall back on standard IO. This PerlIO abstraction layer is -experimental and may cause problems with some extension modules. +the default. This abstraction layer can use AT&T's sfio (if you already +have sfio installed) or regular stdio. Using PerlIO with sfio may cause +problems with some extension modules. Using PerlIO with stdio is safe, +but it is slower than plain stdio and therefore is not the default. If this doesn't make any sense to you, just accept the default 'n'. EOM @@ -181,7 +181,9 @@ ext/POSIX/Makefile.PL POSIX extension makefile writer ext/POSIX/POSIX.pm POSIX extension Perl module ext/POSIX/POSIX.pod POSIX extension documentation ext/POSIX/POSIX.xs POSIX extension external subroutines +ext/POSIX/hints/linux.pl Hint for POSIX for named architecture ext/POSIX/hints/next_3.pl Hint for POSIX for named architecture +ext/POSIX/hints/sunos_4.pl Hint for POSIX for named architecture ext/POSIX/typemap POSIX extension interface types ext/SDBM_File/Makefile.PL SDBM extension makefile writer ext/SDBM_File/SDBM_File.pm SDBM extension Perl module @@ -382,6 +384,7 @@ lib/ExtUtils/Mksymlists.pm Writes a linker options file for extensions lib/ExtUtils/testlib.pm Fixes up @INC to use just-built extension lib/ExtUtils/typemap Extension interface types lib/ExtUtils/xsubpp External subroutine preprocessor +lib/Fatal.pm Make errors in functions/builtins fatal lib/File/Basename.pm Emulate the basename program lib/File/CheckTree.pm Perl module supporting wholesale file mode validation lib/File/Compare.pm Emulation of cmp command @@ -551,12 +554,18 @@ patchlevel.h The current patch level of perl perl.c main() perl.h Global declarations perl_exp.SH Creates list of exported symbols for AIX +perldir.h perldir stuff +perlenv.h perlenv stuff perlio.c C code for PerlIO abstraction perlio.h Interface to PerlIO abstraction perlio.sym Symbols for PerlIO abstraction +perllio.h perllio stuff +perlmem.h perlmem stuff +perlproc.h perlproc stuff perlsdio.h Fake stdio using perlio perlsfio.h Prototype sfio mapping for PerlIO perlsh A poor man's perl shell +perlsock.h perlsock stuff perlvars.h Global variables perly.c A byacc'ed perly.y perly.c.diff Fixup perly.c to allow recursion @@ -605,7 +614,7 @@ pod/perlfaq9.pod Frequently Asked Questions, Part 9 pod/perlform.pod Format info pod/perlfunc.pod Function info pod/perlguts.pod Internals info -pod/perlhist.pod The Perl history records +pod/perlhist.pod Perl history info pod/perlipc.pod IPC info pod/perllocale.pod Locale support info pod/perllol.pod How to use lists of lists @@ -726,6 +735,7 @@ t/lib/open2.t See if IPC::Open2 works t/lib/open3.t See if IPC::Open3 works t/lib/ops.t See if Opcode works t/lib/parsewords.t See if Text::ParseWords works +t/lib/ph.t See if h2ph works t/lib/posix.t See if POSIX works t/lib/safe1.t See if Safe works t/lib/safe2.t See if Safe works @@ -737,10 +747,11 @@ t/lib/soundex.t See if Soundex works t/lib/symbol.t See if Symbol works t/lib/texttabs.t See if Text::Tabs works t/lib/textwrap.t See if Text::Wrap works +t/lib/thread.t Basic test of threading (skipped if no threads) t/lib/tie-push.t Test for Tie::Array t/lib/tie-stdarray.t Test for Tie::StdArray t/lib/tie-stdpush.t Test for Tie::StdArray -t/lib/thread.t Basic test of threading (skipped if no threads) +t/lib/timelocal.t See if Time::Local works t/lib/trig.t See if Math::Trig works t/op/append.t See if . works t/op/arith.t See if arithmetic works @@ -804,7 +815,7 @@ t/op/substr.t See if substr works t/op/sysio.t See if sysread and syswrite work t/op/taint.t See if tainting works t/op/tie.t See if tie/untie functions work -t/op/tiearray.t See if tied arrays work +t/op/tiearray.t See if tie for arrays works t/op/time.t See if time functions work t/op/undef.t See if undef works t/op/universal.t See if UNIVERSAL class works @@ -876,7 +887,7 @@ win32/Makefile Win32 makefile for NMAKE (Visual C++ build) win32/TEST Win32 port win32/autosplit.pl Win32 port win32/bin/network.pl Win32 port -win32/bin/perlglob.pl glob() support +win32/bin/perlglob.pl Win32 globbing win32/bin/pl2bat.pl wrap perl scripts into batch files win32/bin/runperl.pl run perl script via batch file namesake win32/bin/search.pl Win32 port @@ -367,13 +367,7 @@ av_undef(register AV *av) SvREFCNT_dec(AvARRAY(av)[--key]); } Safefree(AvALLOC(av)); -#ifdef PERL_OBJECT - (((XPVAV*) SvANY(av))->xav_array) = 0; - /* the following line is is a problem with VC */ - /* AvARRAY(av) = 0; */ -#else - AvARRAY(av) = 0; -#endif + SvPVX(av) = 0; AvALLOC(av) = 0; SvPVX(av) = 0; AvMAX(av) = AvFILLp(av) = -1; @@ -40,12 +40,18 @@ # include <utime.h> # endif #endif + #ifdef I_FCNTL #include <fcntl.h> #endif #ifdef I_SYS_FILE #include <sys/file.h> #endif +#ifdef O_EXCL +# define OPEN_EXCL O_EXCL +#else +# define OPEN_EXCL 0 +#endif #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include <signal.h> @@ -381,16 +387,16 @@ nextargv(register GV *gv) filemode = 0; while (av_len(GvAV(gv)) >= 0) { dTHR; - STRLEN len; + STRLEN oldlen; sv = av_shift(GvAV(gv)); SAVEFREESV(sv); sv_setsv(GvSV(gv),sv); SvSETMAGIC(GvSV(gv)); - oldname = SvPVx(GvSV(gv), len); - if (do_open(gv,oldname,len,FALSE,0,0,Nullfp)) { + oldname = SvPVx(GvSV(gv), oldlen); + if (do_open(gv,oldname,oldlen,inplace!=0,0,0,Nullfp)) { if (inplace) { TAINT_PROPER("inplace open"); - if (strEQ(oldname,"-")) { + if (oldlen == 1 && *oldname == '-') { setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO)); return IoIFP(GvIOp(gv)); } @@ -439,7 +445,7 @@ nextargv(register GV *gv) do_close(gv,FALSE); (void)PerlLIO_unlink(SvPVX(sv)); (void)PerlLIO_rename(oldname,SvPVX(sv)); - do_open(gv,SvPVX(sv),SvCUR(sv),FALSE,0,0,Nullfp); + do_open(gv,SvPVX(sv),SvCUR(sv),inplace!=0,0,0,Nullfp); #endif /* DOSISH */ #else (void)UNLINK(SvPVX(sv)); @@ -456,8 +462,8 @@ nextargv(register GV *gv) #if !defined(DOSISH) && !defined(AMIGAOS) # ifndef VMS /* Don't delete; use automatic file versioning */ if (UNLINK(oldname) < 0) { - warn("Can't rename %s to %s: %s, skipping file", - oldname, SvPVX(sv), Strerror(errno) ); + warn("Can't remove %s: %s, skipping file", + oldname, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -467,10 +473,11 @@ nextargv(register GV *gv) #endif } - sv_setpvn(sv,">",1); - sv_catpv(sv,oldname); + sv_setpvn(sv,">",!inplace); + sv_catpvn(sv,oldname,oldlen); SETERRNO(0,0); /* in case sprintf set errno */ - if (!do_open(argvoutgv,SvPVX(sv),SvCUR(sv),FALSE,0,0,Nullfp)) { + if (!do_open(argvoutgv,SvPVX(sv),SvCUR(sv),inplace!=0, + O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) { warn("Can't do inplace edit on %s: %s", oldname, Strerror(errno) ); do_close(gv,FALSE); @@ -28,7 +28,6 @@ } STMT_END # define pthread_mutexattr_default NULL # define pthread_condattr_default NULL -# define pthread_attr_default NULL # define pthread_addr_t any_t # endif #else /* DJGPP */ @@ -396,6 +396,7 @@ #define newSVnv Perl_newSVnv #define newSVpv Perl_newSVpv #define newSVpvf Perl_newSVpvf +#define newSVpvn Perl_newSVpvn #define newSVrv Perl_newSVrv #define newSVsv Perl_newSVsv #define newUNOP Perl_newUNOP @@ -927,9 +928,13 @@ #define sv_backoff Perl_sv_backoff #define sv_bless Perl_sv_bless #define sv_catpv Perl_sv_catpv +#define sv_catpv_mg Perl_sv_catpv_mg #define sv_catpvf Perl_sv_catpvf +#define sv_catpvf_mg Perl_sv_catpvf_mg #define sv_catpvn Perl_sv_catpvn +#define sv_catpvn_mg Perl_sv_catpvn_mg #define sv_catsv Perl_sv_catsv +#define sv_catsv_mg Perl_sv_catsv_mg #define sv_chop Perl_sv_chop #define sv_clean_all Perl_sv_clean_all #define sv_clean_objs Perl_sv_clean_objs @@ -966,18 +971,26 @@ #define sv_report_used Perl_sv_report_used #define sv_reset Perl_sv_reset #define sv_setiv Perl_sv_setiv +#define sv_setiv_mg Perl_sv_setiv_mg #define sv_setnv Perl_sv_setnv +#define sv_setnv_mg Perl_sv_setnv_mg #define sv_setptrobj Perl_sv_setptrobj #define sv_setpv Perl_sv_setpv +#define sv_setpv_mg Perl_sv_setpv_mg #define sv_setpvf Perl_sv_setpvf +#define sv_setpvf_mg Perl_sv_setpvf_mg #define sv_setpviv Perl_sv_setpviv +#define sv_setpviv_mg Perl_sv_setpviv_mg #define sv_setpvn Perl_sv_setpvn +#define sv_setpvn_mg Perl_sv_setpvn_mg #define sv_setref_iv Perl_sv_setref_iv #define sv_setref_nv Perl_sv_setref_nv #define sv_setref_pv Perl_sv_setref_pv #define sv_setref_pvn Perl_sv_setref_pvn #define sv_setsv Perl_sv_setsv +#define sv_setsv_mg Perl_sv_setsv_mg #define sv_setuv Perl_sv_setuv +#define sv_setuv_mg Perl_sv_setuv_mg #define sv_taint Perl_sv_taint #define sv_tainted Perl_sv_tainted #define sv_true Perl_sv_true @@ -986,6 +999,7 @@ #define sv_untaint Perl_sv_untaint #define sv_upgrade Perl_sv_upgrade #define sv_usepvn Perl_sv_usepvn +#define sv_usepvn_mg Perl_sv_usepvn_mg #define sv_uv Perl_sv_uv #define sv_vcatpvfn Perl_sv_vcatpvfn #define sv_vsetpvfn Perl_sv_vsetpvfn diff --git a/embedvar.h b/embedvar.h index 7f3dce022c..30bac224c9 100644 --- a/embedvar.h +++ b/embedvar.h @@ -189,6 +189,7 @@ #define sv_objcount (curinterp->Isv_objcount) #define sv_root (curinterp->Isv_root) #define tainting (curinterp->Itainting) +#define threadnum (curinterp->Ithreadnum) #define thrsv (curinterp->Ithrsv) #define unsafe (curinterp->Iunsafe) #define warnhook (curinterp->Iwarnhook) @@ -306,6 +307,7 @@ #define Isv_objcount sv_objcount #define Isv_root sv_root #define Itainting tainting +#define Ithreadnum threadnum #define Ithrsv thrsv #define Iunsafe unsafe #define Iwarnhook warnhook @@ -483,6 +485,7 @@ #define sv_objcount Perl_sv_objcount #define sv_root Perl_sv_root #define tainting Perl_tainting +#define threadnum Perl_threadnum #define thrsv Perl_thrsv #define unsafe Perl_unsafe #define warnhook Perl_warnhook diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index f77757caa4..8f2eda10b0 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -560,12 +560,13 @@ SV * sv ; { SV ** svp; HV * action ; - DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; + DB_File RETVAL; void * openinfo = NULL ; - INFO * info = &RETVAL->info ; + INFO * info; /* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ - Zero(RETVAL, 1, DB_File_type) ; + Newz(777, RETVAL, 1, DB_File_type) ; + info = &RETVAL->info ; /* Default to HASH */ RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; diff --git a/ext/DynaLoader/dl_next.xs b/ext/DynaLoader/dl_next.xs index 92d14bc81c..e35c251c55 100644 --- a/ext/DynaLoader/dl_next.xs +++ b/ext/DynaLoader/dl_next.xs @@ -100,7 +100,7 @@ static void TranslateError path, number, type); break; } - safefree(dl_last_error); + Safefree(dl_last_error); dl_last_error = savepv(error); } @@ -151,10 +151,10 @@ static void TransferError(NXStream *s) int len, maxlen; if ( dl_last_error ) { - safefree(dl_last_error); + Safefree(dl_last_error); } NXGetMemoryBuffer(s, &buffer, &len, &maxlen); - dl_last_error = safemalloc(len); + New(1097, dl_last_error, len, char); strcpy(dl_last_error, buffer); } diff --git a/ext/DynaLoader/dl_vms.xs b/ext/DynaLoader/dl_vms.xs index 0329ebd9cb..2ed718dfd7 100644 --- a/ext/DynaLoader/dl_vms.xs +++ b/ext/DynaLoader/dl_vms.xs @@ -263,7 +263,7 @@ dl_load_file(filespec, flags) dlptr->name.dsc$w_length = namlst[0].len; dlptr->name.dsc$a_pointer = savepvn(namlst[0].string,namlst[0].len); dlptr->defspec.dsc$w_length = specdsc.dsc$w_length - namlst[0].len; - dlptr->defspec.dsc$a_pointer = safemalloc(dlptr->defspec.dsc$w_length + 1); + New(1097, dlptr->defspec.dsc$a_pointer, dlptr->defspec.dsc$w_length + 1, char); deflen = namlst[0].string - specdsc.dsc$a_pointer; memcpy(dlptr->defspec.dsc$a_pointer,specdsc.dsc$a_pointer,deflen); memcpy(dlptr->defspec.dsc$a_pointer + deflen, diff --git a/ext/Fcntl/Fcntl.pm b/ext/Fcntl/Fcntl.pm index 6214323c31..74de3dfc65 100644 --- a/ext/Fcntl/Fcntl.pm +++ b/ext/Fcntl/Fcntl.pm @@ -78,7 +78,7 @@ $VERSION = "1.03"; sub AUTOLOAD { my($constname); ($constname = $AUTOLOAD) =~ s/.*:://; - my $val = constant($constname, @_ ? $_[0] : 0); + my $val = constant($constname, (@_ && (caller(0))[4]) ? $_[0] : 0); if ($! != 0) { if ($! =~ /Invalid/) { $AutoLoader::AUTOLOAD = $AUTOLOAD; diff --git a/ext/GDBM_File/typemap b/ext/GDBM_File/typemap index 73ad370359..a9b73d8b81 100644 --- a/ext/GDBM_File/typemap +++ b/ext/GDBM_File/typemap @@ -20,8 +20,8 @@ T_GDATUM UNIMPLEMENTED OUTPUT T_DATUM - SvSetMagicPVN($arg, $var.dptr, $var.dsize); + sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM - SvUseMagicPVN($arg, $var.dptr, $var.dsize); + sv_usepvn($arg, $var.dptr, $var.dsize); T_PTROBJ sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/ext/NDBM_File/typemap b/ext/NDBM_File/typemap index 73ad370359..a9b73d8b81 100644 --- a/ext/NDBM_File/typemap +++ b/ext/NDBM_File/typemap @@ -20,8 +20,8 @@ T_GDATUM UNIMPLEMENTED OUTPUT T_DATUM - SvSetMagicPVN($arg, $var.dptr, $var.dsize); + sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM - SvUseMagicPVN($arg, $var.dptr, $var.dsize); + sv_usepvn($arg, $var.dptr, $var.dsize); T_PTROBJ sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/ext/ODBM_File/typemap b/ext/ODBM_File/typemap index c2c3e3e725..a6b0e5faa8 100644 --- a/ext/ODBM_File/typemap +++ b/ext/ODBM_File/typemap @@ -20,6 +20,6 @@ T_GDATUM UNIMPLEMENTED OUTPUT T_DATUM - SvSetMagicPVN($arg, $var.dptr, $var.dsize); + sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM - SvUseMagicPVN($arg, $var.dptr, $var.dsize); + sv_usepvn($arg, $var.dptr, $var.dsize); diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index 31e734a26c..cf5c859395 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -111,7 +111,7 @@ new_opset(SV *old_opset) opset = newSVsv(old_opset); } else { - opset = newSV(opset_len); + opset = NEWSV(1156, opset_len); Zero(SvPVX(opset), opset_len + 1, char); SvCUR_set(opset, opset_len); (void)SvPOK_only(opset); diff --git a/ext/POSIX/hints/linux.pl b/ext/POSIX/hints/linux.pl new file mode 100644 index 0000000000..7994f24023 --- /dev/null +++ b/ext/POSIX/hints/linux.pl @@ -0,0 +1,5 @@ +# libc6, aka glibc2, seems to need STRUCT_TM_HASZONE defined. +# Thanks to Bart Schuller <schuller@Lunatech.com> +# See Message-ID: <19971009002636.50729@tanglefoot> +# XXX A Configure test is needed. +$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ; diff --git a/ext/POSIX/hints/sunos_4.pl b/ext/POSIX/hints/sunos_4.pl new file mode 100644 index 0000000000..59b45bc4f2 --- /dev/null +++ b/ext/POSIX/hints/sunos_4.pl @@ -0,0 +1,6 @@ +# SunOS 4.1.3 has two extra fields in struct tm. This works around +# the problem. Other BSD platforms may have similar problems. +# This state of affairs also persists in glibc2, found +# on linux systems running libc6. +# XXX A Configure test is needed. +$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ; diff --git a/ext/SDBM_File/typemap b/ext/SDBM_File/typemap index 73ad370359..a9b73d8b81 100644 --- a/ext/SDBM_File/typemap +++ b/ext/SDBM_File/typemap @@ -20,8 +20,8 @@ T_GDATUM UNIMPLEMENTED OUTPUT T_DATUM - SvSetMagicPVN($arg, $var.dptr, $var.dsize); + sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM - SvUseMagicPVN($arg, $var.dptr, $var.dsize); + sv_usepvn($arg, $var.dptr, $var.dsize); T_PTROBJ sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs index c5adcb3eb7..3b49dbecb2 100644 --- a/ext/Thread/Thread.xs +++ b/ext/Thread/Thread.xs @@ -12,7 +12,6 @@ #endif #include <fcntl.h> -static U32 threadnum = 0; static int sig_pipe[2]; #ifndef THREAD_RET_TYPE @@ -208,6 +207,8 @@ newthread (SV *startsv, AV *initargs, char *classname) SV *sv; int err; #ifndef THREAD_CREATE + static pthread_attr_t attr; + static int attr_inited = 0; sigset_t fullmask, oldmask; #endif @@ -233,33 +234,22 @@ newthread (SV *startsv, AV *initargs, char *classname) sigfillset(&fullmask); if (sigprocmask(SIG_SETMASK, &fullmask, &oldmask) == -1) croak("panic: sigprocmask"); -#ifdef PTHREADS_CREATED_JOINABLE - err = pthread_create(&thr->self, pthread_attr_default, - threadstart, (void*) thr); -#else - { - pthread_attr_t attr; - + err = 0; + if (!attr_inited) { + attr_inited = 1; err = pthread_attr_init(&attr); - if (err == 0) { -#ifdef PTHREAD_CREATE_UNDETACHED - err = pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_UNDETACHED); -#else - croak("panic: pthread_attr_setdetachstate"); -#endif - if (err == 0) - err = pthread_create(&thr->self, &attr, - threadstart, (void*) thr); - } - pthread_attr_destroy(&attr); + if (err == 0) + err = pthread_attr_setdetachstate(&attr, ATTR_JOINABLE); } -#endif + if (err == 0) + err = pthread_create(&thr->self, &attr, threadstart, (void*) thr); /* Go */ MUTEX_UNLOCK(&thr->mutex); #endif if (err) { DEBUG_L(PerlIO_printf(PerlIO_stderr(), - "%p: create of %p failed %d\n", savethread, thr, err)); + "%p: create of %p failed %d\n", + savethread, thr, err)); /* Thread creation failed--clean up */ SvREFCNT_dec(thr->cvcache); remove_thread(thr); diff --git a/global.sym b/global.sym index 979f8d1818..afbc7c9620 100644 --- a/global.sym +++ b/global.sym @@ -490,6 +490,7 @@ newSVREF newSViv newSVnv newSVpv +newSVpvn newSVpvf newSVrv newSVsv @@ -970,9 +971,13 @@ sv_add_arena sv_backoff sv_bless sv_catpvf +sv_catpvf_mg sv_catpv +sv_catpv_mg sv_catpvn +sv_catpvn_mg sv_catsv +sv_catsv_mg sv_chop sv_clean_all sv_clean_objs @@ -1007,18 +1012,26 @@ sv_replace sv_report_used sv_reset sv_setpvf +sv_setpvf_mg sv_setiv +sv_setiv_mg sv_setnv +sv_setnv_mg sv_setptrobj sv_setpv +sv_setpv_mg sv_setpviv +sv_setpviv_mg sv_setpvn +sv_setpvn_mg sv_setref_iv sv_setref_nv sv_setref_pv sv_setref_pvn sv_setsv +sv_setsv_mg sv_setuv +sv_setuv_mg sv_taint sv_tainted sv_unmagic @@ -1026,6 +1039,7 @@ sv_unref sv_untaint sv_upgrade sv_usepvn +sv_usepvn_mg sv_vcatpvfn sv_vsetpvfn taint_env @@ -97,7 +97,7 @@ gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi) GvFILEGV(gv) = curcop->cop_filegv; GvEGV(gv) = gv; sv_magic((SV*)gv, (SV*)gv, '*', name, len); - GvSTASH(gv) = stash; + GvSTASH(gv) = (HV*)SvREFCNT_inc(stash); GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; if (multi) @@ -399,7 +399,6 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) register char *namend; HV *stash = 0; U32 add_gvflags = 0; - char *tmpbuf; if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ name++; @@ -415,23 +414,29 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) len = namend - name; if (len > 0) { - New(601, tmpbuf, len+3, char); + char *tmpbuf; + char autobuf[64]; + + if (len < sizeof(autobuf) - 2) + tmpbuf = autobuf; + else + New(601, tmpbuf, len+3, char); Copy(name, tmpbuf, len, char); tmpbuf[len++] = ':'; tmpbuf[len++] = ':'; tmpbuf[len] = '\0'; gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); - Safefree(tmpbuf); - if (!gvp || *gvp == (GV*)&sv_undef) - return Nullgv; - gv = *gvp; - - if (SvTYPE(gv) == SVt_PVGV) - GvMULTI_on(gv); - else if (!add) + gv = gvp ? *gvp : Nullgv; + if (gv && gv != (GV*)&sv_undef) { + if (SvTYPE(gv) != SVt_PVGV) + gv_init(gv, stash, tmpbuf, len, (add & 2)); + else + GvMULTI_on(gv); + } + if (tmpbuf != autobuf) + Safefree(tmpbuf); + if (!gv || gv == (GV*)&sv_undef) return Nullgv; - else - gv_init(gv, stash, nambeg, namend - nambeg, (add & 2)); if (!(stash = GvHV(gv))) stash = GvHV(gv) = newHV(); @@ -244,7 +244,10 @@ typedef U16 line_t; #define NOLINE ((line_t) 65535) #endif -/* XXX LEAKTEST doesn't really work in perl5. There are direct calls to + +/* This looks obsolete (IZ): + + XXX LEAKTEST doesn't really work in perl5. There are direct calls to safemalloc() in the source, so LEAKTEST won't pick them up. Further, if you try LEAKTEST, you'll also end up calling Safefree, which might call safexfree() on some things that weren't @@ -278,12 +281,16 @@ typedef U16 line_t; (v = (t*)safexrealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))) #define Renewc(v,n,t,c) \ (v = (c*)safexrealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))) -#define Safefree(d) safexfree((Malloc_t)d) +#define Safefree(d) safexfree((Malloc_t)(d)) #define NEWSV(x,len) newSV(x,len) #define MAXXCOUNT 1400 -long xcount[MAXXCOUNT]; -long lastxcount[MAXXCOUNT]; +#define MAXY_SIZE 80 +#define MAXYCOUNT 16 /* (MAXY_SIZE/4 + 1) */ +extern long xcount[MAXXCOUNT]; +extern long lastxcount[MAXXCOUNT]; +extern long xycount[MAXXCOUNT][MAXYCOUNT]; +extern long lastxycount[MAXXCOUNT][MAXYCOUNT]; #endif /* LEAKTEST */ diff --git a/hints/dec_osf.sh b/hints/dec_osf.sh index a1efc11cd1..2e8ffac5bd 100644 --- a/hints/dec_osf.sh +++ b/hints/dec_osf.sh @@ -121,8 +121,11 @@ esac # no attempt to figure out the additional location(s) searched by # gcc, since not all versions of gcc are easily coerced into # revealing that information. -glibpth="/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc" -glibpth="$glibpth /usr/lib /usr/local/lib /var/shlib" +# +# This or the new useshrplib default below breaks the build. +# Commented out for this snapshot. +#glibpth="/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc" +#glibpth="$glibpth /usr/lib /usr/local/lib /var/shlib" # dlopen() is in libc libswanted="`echo $libswanted | sed -e 's/ dl / /'`" @@ -196,9 +199,11 @@ fi # "-Uuseshrplib" prevents this default. # -case "$_DEC_cc_style.$useshrplib" in - new.) useshrplib="$define" ;; -esac +# This or the glibpth change above breaks the build. Commented out +# for this snapshot. +#case "$_DEC_cc_style.$useshrplib" in +# new.) useshrplib="$define" ;; +#esac # # Unset temporary variables no more needed. diff --git a/hints/freebsd.sh b/hints/freebsd.sh index 6ce5fa720c..e20d40d249 100644 --- a/hints/freebsd.sh +++ b/hints/freebsd.sh @@ -108,3 +108,17 @@ problem. Try EOM +if [ "X$usethreads" != "X" ]; then + if [ ! -r /usr/lib/libc_r.a ]; then + cat <<'EOM' + +The re-entrant C library /usr/lib/libc_r.a does not exist; cannot build +threaded Perl. Consider upgrading to a newer FreeBSD snapshot or release: +at least the FreeBSD 3.0-971225-SNAP is known to have the libc_r.a. + +EOM + exit 1 + fi + libswanted="$libswanted c_r" + ccflags="-DUSE_THREADS $ccflags" +fi diff --git a/hints/linux.sh b/hints/linux.sh index af7d0a835e..8ff7f5d747 100644 --- a/hints/linux.sh +++ b/hints/linux.sh @@ -29,14 +29,6 @@ esac # gcc-2.6.3 defines _G_HAVE_BOOL to 1, but doesn't actually supply bool. ccflags="-Dbool=char -DHAS_BOOL $ccflags" -# libc6, aka glibc2, seems to need STRUCT_TM_HASZONE defined. -# Thanks to Bart Schuller <schuller@Lunatech.com> -# See Message-ID: <19971009002636.50729@tanglefoot> -# This is currently commented out for maintenance releases -# but should probably be uncommented for 5.005 or after -# more widespread testing. -#POSIX_cflags='ccflags="$ccflags -DSTRUCT_TM_HASZONE"' - # BSD compatability library no longer needed set `echo X "$libswanted "| sed -e 's/ bsd / /'` shift diff --git a/hints/solaris_2.sh b/hints/solaris_2.sh index 21593f132f..6b24dd1ef2 100644 --- a/hints/solaris_2.sh +++ b/hints/solaris_2.sh @@ -123,17 +123,18 @@ rm -f make.vers # - check as(1) and ld(1), they should not be GNU # # Watch out in case they have not set $cc. -case "`${cc:-cc} -v 2>&1`" in -*gcc*) + +# Get gcc to share its secrets. +echo 'main() { return 0; }' > try.c +verbose=`${cc:-cc} -v -o try try.c 2>&1` +rm -f try try.c + +if echo "$verbose" | grep '^Reading specs from' >/dev/null 2>&1; then # # Using gcc. # #echo Using gcc - # Get gcc to share its secrets. - echo 'main() { return 0; }' > try.c - verbose=`${cc:-cc} -v -o try try.c 2>&1` - rm -f try try.c tmp=`echo "$verbose" | grep '^Reading' | awk '{print $NF}' | sed 's/specs$/include/'` @@ -141,36 +142,36 @@ case "`${cc:-cc} -v 2>&1`" in # Doesn't work anymore for gcc-2.7.2. # See if as(1) is GNU as(1). GNU as(1) won't work for this job. - case $verbose in - */usr/ccs/bin/as*) ;; - *) + if echo "$verbose" | grep ' /usr/ccs/bin/as ' >/dev/null 2>&1; then + : + else cat <<END >&2 NOTE: You are using GNU as(1). GNU as(1) will not build Perl. -You must arrange to use /usr/ccs/bin/as, perhaps by setting -GCC_EXEC_PREFIX or by including -B/usr/ccs/bin/ in your cc command. +I'm arranging to use /usr/ccs/bin/as by setting including +-B/usr/ccs/bin/ in your ${cc:-cc} command. (Note that the trailing "/" is required.) END - ;; - esac + cc="${cc:-cc} -B/usr/ccs/bin/" + fi # See if ld(1) is GNU ld(1). GNU ld(1) won't work for this job. - case $verbose in - */usr/ccs/bin/ld*) ;; - *) + if echo "$verbose" | grep ' /usr/ccs/bin/as ' >/dev/null 2>&1; then + : + else cat <<END >&2 -NOTE: You are using GNU ld(1). GNU ld(1) will not build Perl. -You must arrange to use /usr/ccs/bin/ld, perhaps by setting -GCC_EXEC_PREFIX or by including -B/usr/ccs/bin/ in your cc command. +NOTE: You are using GNU as(1). GNU as(1) will not build Perl. +I'm arranging to use /usr/ccs/bin/as by setting including +-B/usr/ccs/bin/ in your ${cc:-cc} command. +(Note that the trailing "/" is required.) END - ;; - esac + cc="${cc:-cc} -B/usr/ccs/bin/" + fi - ;; #using gcc -*) +else # # Not using gcc. # @@ -217,8 +218,7 @@ beginning of your PATH. END fi - ;; #not using gcc -esac +fi # as --version or ld --version might dump core. rm -f core diff --git a/hints/sunos_4_1.sh b/hints/sunos_4_1.sh index 07cd89fc7b..9f342d100b 100644 --- a/hints/sunos_4_1.sh +++ b/hints/sunos_4_1.sh @@ -37,10 +37,6 @@ d_tzname and i_unistd. Keep the recommended values. See hints/sunos_4_1.sh for more information. EOM -# SunOS 4.1.3 has two extra fields in struct tm. This works around -# the problem. Other BSD platforms may have similar problems. -POSIX_cflags='ccflags="$ccflags -DSTRUCT_TM_HASZONE"' - # The correct setting of groupstype depends on which version of the C # library is used. If you are in the 'System V environment' # (i.e. you have /usr/5bin ahead of /usr/bin in your PATH), and @@ -45,7 +45,7 @@ more_he(void) { register HE* he; register HE* heend; - he_root = (HE*)safemalloc(1008); + New(54, he_root, 1008/sizeof(HE), HE); he = he_root; heend = &he[1008 / sizeof(HE) - 1]; while (he < heend) { @@ -678,6 +678,10 @@ hsplit(HV *hv) nomemok = TRUE; #ifdef STRANGE_MALLOC Renew(a, newsize, HE*); + if (!a) { + nomemok = FALSE; + return; + } #else i = newsize * sizeof(HE*); #define MALLOC_OVERHEAD 16 @@ -688,6 +692,10 @@ hsplit(HV *hv) tmp /= sizeof(HE*); assert(tmp >= newsize); New(2,a, tmp, HE*); + if (!a) { + nomemok = FALSE; + return; + } Copy(xhv->xhv_array, a, oldsize, HE*); if (oldsize >= 64) { offer_nice_chunk(xhv->xhv_array, @@ -751,6 +759,10 @@ hv_ksplit(HV *hv, IV newmax) nomemok = TRUE; #ifdef STRANGE_MALLOC Renew(a, newsize, HE*); + if (!a) { + nomemok = FALSE; + return; + } #else i = newsize * sizeof(HE*); j = MALLOC_OVERHEAD; @@ -760,6 +772,10 @@ hv_ksplit(HV *hv, IV newmax) j /= sizeof(HE*); assert(j >= newsize); New(2, a, j, HE*); + if (!a) { + nomemok = FALSE; + return; + } Copy(xhv->xhv_array, a, oldsize, HE*); if (oldsize >= 64) { offer_nice_chunk(xhv->xhv_array, diff --git a/interp.sym b/interp.sym index e95a9162c4..5453afa064 100644 --- a/interp.sym +++ b/interp.sym @@ -134,6 +134,7 @@ sv_root sv_arenaroot tainted tainting +threadnum thrsv tmps_floor tmps_ix diff --git a/intrpvar.h b/intrpvar.h index 447753e45e..21f907602e 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -156,6 +156,7 @@ PERLVAR(Iofmt, char *) /* $# */ #ifdef USE_THREADS PERLVAR(Ithrsv, SV *) /* holds struct perl_thread for main thread */ +PERLVARI(Ithreadnum, U32, 0) /* incremented each thread creation */ #endif /* USE_THREADS */ #ifdef PERL_OBJECT diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm index 13acf869bc..e09bc92958 100644 --- a/lib/Benchmark.pm +++ b/lib/Benchmark.pm @@ -367,7 +367,9 @@ sub timethese{ # we could save the results in an array and produce a summary here # sum, min, max, avg etc etc - map timethis($n, $alt->{$_}, $_, $style), @names; + foreach my $name (@names) { + timethis ($n, $alt -> {$name}, $name, $style); + } } 1; diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index 430c28ad3d..20cc96f0b5 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -190,44 +190,44 @@ T_HVREF T_CVREF $arg = newRV((SV*)$var); T_IV - SvSetMagicIV($arg, (IV)$var); + sv_setiv($arg, (IV)$var); T_INT - SvSetMagicIV($arg, (IV)$var); + sv_setiv($arg, (IV)$var); T_SYSRET if ($var != -1) { if ($var == 0) - SvSetMagicPVN($arg, "0 but true", 10); + sv_setpvn($arg, "0 but true", 10); else - SvSetMagicIV($arg, (IV)$var); + sv_setiv($arg, (IV)$var); } T_ENUM - SvSetMagicIV($arg, (IV)$var); + sv_setiv($arg, (IV)$var); T_BOOL $arg = boolSV($var); T_U_INT - SvSetMagicIV($arg, (IV)$var); + sv_setiv($arg, (IV)$var); T_SHORT - SvSetMagicIV($arg, (IV)$var); + sv_setiv($arg, (IV)$var); T_U_SHORT - SvSetMagicIV($arg, (IV)$var); + sv_setiv($arg, (IV)$var); T_LONG - SvSetMagicIV($arg, (IV)$var); + sv_setiv($arg, (IV)$var); T_U_LONG - SvSetMagicIV($arg, (IV)$var); + sv_setiv($arg, (IV)$var); T_CHAR - SvSetMagicPVN($arg, (char *)&$var, 1); + sv_setpvn($arg, (char *)&$var, 1); T_U_CHAR - SvSetMagicIV($arg, (IV)$var); + sv_setiv($arg, (IV)$var); T_FLOAT - SvSetMagicNV($arg, (double)$var); + sv_setnv($arg, (double)$var); T_NV - SvSetMagicNV($arg, (double)$var); + sv_setnv($arg, (double)$var); T_DOUBLE - SvSetMagicNV($arg, (double)$var); + sv_setnv($arg, (double)$var); T_PV - SvSetMagicPV((SV*)$arg, $var); + sv_setpv((SV*)$arg, $var); T_PTR - SvSetMagicIV($arg, (IV)$var); + sv_setiv($arg, (IV)$var); T_PTRREF sv_setref_pv($arg, Nullch, (void*)$var); T_REF_IV_REF @@ -244,17 +244,17 @@ T_REFREF T_REFOBJ NOT IMPLEMENTED T_OPAQUE - SvSetMagicPVN($arg, (char *)&$var, sizeof($var)); + sv_setpvn($arg, (char *)&$var, sizeof($var)); T_OPAQUEPTR - SvSetMagicPVN($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var); + sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var); T_PACKED XS_pack_$ntype($arg, $var); T_PACKEDARRAY XS_pack_$ntype($arg, $var, count_$ntype); T_DATAUNIT - SvSetMagicPVN($arg, $var.chp(), $var.size()); + sv_setpvn($arg, $var.chp(), $var.size()); T_CALLBACK - SvSetMagicPVN($arg, $var.context.value().chp(), + sv_setpvn($arg, $var.context.value().chp(), $var.context.value().size()); T_ARRAY ST_EXTEND($var.size); @@ -267,7 +267,7 @@ T_IN { GV *gv = newGVgen("$Package"); if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) - SvSetMagicSV($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &sv_undef; } @@ -275,7 +275,7 @@ T_INOUT { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) - SvSetMagicSV($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &sv_undef; } @@ -283,7 +283,7 @@ T_OUT { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) - SvSetMagicSV($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); + sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1))); else $arg = &sv_undef; } diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 04de166ad6..6fe16dc371 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -87,7 +87,7 @@ sub Q ; # Global Constants -$XSUBPP_version = "1.9505"; +$XSUBPP_version = "1.9506"; my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { @@ -371,6 +371,10 @@ sub INPUT_handler { sub OUTPUT_handler { for (; !/^$BLOCK_re/o; $_ = shift(@line)) { next unless /\S/; + if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { + $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0); + next; + } my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ; blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next if $outargs{$outarg} ++ ; @@ -386,9 +390,10 @@ sub OUTPUT_handler { unless defined $var_types{$outarg} ; if ($outcode) { print "\t$outcode\n"; + print "\tSvSETMAGIC(ST(" . $var_num-1 . "));\n" if $DoSetMagic; } else { $var_num = $args_match{$outarg}; - &generate_output($var_types{$outarg}, $var_num, $outarg); + &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic); } } } @@ -875,6 +880,7 @@ while (fetch_para()) { } $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ; %XsubAliases = %XsubAliasValues = (); + $DoSetMagic = 1; @args = split(/\s*,\s*/, $orig_args); if (defined($class)) { @@ -1059,7 +1065,8 @@ EOF if ($gotRETVAL && $RETVAL_code) { print "\t$RETVAL_code\n"; } elsif ($gotRETVAL || $wantRETVAL) { - &generate_output($ret_type, 0, 'RETVAL'); + # RETVAL almost never needs SvSETMAGIC() + &generate_output($ret_type, 0, 'RETVAL', 0); } # do cleanup @@ -1283,7 +1290,7 @@ sub generate_init { } sub generate_output { - local($type, $num, $var) = @_; + local($type, $num, $var, $do_setmagic) = @_; local($arg) = "ST(" . ($num - ($num != 0)) . ")"; local($argoff) = $num - 1; local($ntype); @@ -1291,6 +1298,7 @@ sub generate_output { $type = TidyType($type) ; if ($type =~ /^array\(([^,]*),(.*)\)/) { print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n"; + print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } else { blurt("Error: '$type' not in typemap"), return unless defined($type_kind{$type}); @@ -1312,6 +1320,7 @@ sub generate_output { $subexpr =~ s/\n\t/\n\t\t/g; $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; eval "print qq\a$expr\a"; + print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; } elsif ($var eq 'RETVAL') { if ($expr =~ /^\t\$arg = new/) { @@ -1319,6 +1328,7 @@ sub generate_output { # mortalize it. eval "print qq\a$expr\a"; print "\tsv_2mortal(ST(0));\n"; + print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; } elsif ($expr =~ /^\s*\$arg\s*=/) { # We expect that $arg has refcnt >=1, so we need @@ -1329,6 +1339,7 @@ sub generate_output { # ignored by REFCNT_dec. Builtin values have REFCNT==0. eval "print qq\a$expr\a"; print "\tif (SvREFCNT(ST(0))) sv_2mortal(ST(0));\n"; + print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; } else { # Just hope that the entry would safely write it @@ -1337,10 +1348,12 @@ sub generate_output { # works too. print "\tST(0) = sv_newmortal();\n"; eval "print qq\a$expr\a"; + # new mortals don't have set magic } } elsif ($arg =~ /^ST\(\d+\)$/) { eval "print qq\a$expr\a"; + print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } } } diff --git a/lib/Fatal.pm b/lib/Fatal.pm new file mode 100644 index 0000000000..a1e5cffcf4 --- /dev/null +++ b/lib/Fatal.pm @@ -0,0 +1,157 @@ +package Fatal; + +use Carp; +use strict; +use vars qw( $AUTOLOAD $Debug $VERSION); + +$VERSION = 1.02; + +$Debug = 0 unless defined $Debug; + +sub import { + my $self = shift(@_); + my($sym, $pkg); + $pkg = (caller)[0]; + foreach $sym (@_) { + &_make_fatal($sym, $pkg); + } +}; + +sub AUTOLOAD { + my $cmd = $AUTOLOAD; + $cmd =~ s/.*:://; + &_make_fatal($cmd, (caller)[0]); + goto &$AUTOLOAD; +} + +sub fill_protos { + my $proto = shift; + my ($n, $isref, @out, @out1, $seen_semi) = -1; + while ($proto =~ /\S/) { + $n++; + push(@out1,[$n,@out]) if $seen_semi; + push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//; + push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([*\$&])//; + push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//; + $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ???? + die "Unknown prototype letters: \"$proto\""; + } + push(@out1,[$n+1,@out]); + @out1; +} + +sub write_invocation { + my ($core, $call, $name, @argvs) = @_; + if (@argvs == 1) { # No optional arguments + my @argv = @{$argvs[0]}; + shift @argv; + return "\t" . one_invocation($core, $call, $name, @argv) . ";\n"; + } else { + my $else = "\t"; + my (@out, @argv, $n); + while (@argvs) { + @argv = @{shift @argvs}; + $n = shift @argv; + push @out, "$ {else}if (\@_ == $n) {\n"; + $else = "\t} els"; + push @out, + "\t\treturn " . one_invocation($core, $call, $name, @argv) . ";\n"; + } + push @out, <<EOC; + } + die "$name(\@_): Do not expect to get ", scalar \@_, " arguments"; +EOC + return join '', @out; + } +} + +sub one_invocation { + my ($core, $call, $name, @argv) = @_; + local $" = ', '; + return qq{$call(@argv) || croak "Can't $name(\@_)} . + ($core ? ': $!' : ', \$! is \"$!\"') . '"'; +} + +sub _make_fatal { + my($sub, $pkg) = @_; + my($name, $code, $sref, $real_proto, $proto, $core, $call); + my $ini = $sub; + + $sub = "${pkg}::$sub" unless $sub =~ /::/; + $name = $sub; + $name =~ s/.*::// or $name =~ s/^&//; + print "# _make_fatal: sub=$sub pkg=$pkg name=$name\n" if $Debug; + croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/; + if (defined(&$sub)) { # user subroutine + $sref = \&$sub; + $proto = prototype $sref; + $call = '&$sref'; + } elsif ($sub eq $ini) { # Stray user subroutine + die "$sub is not a Perl subroutine" + } else { # CORE subroutine + $proto = eval { prototype "CORE::$name" }; + die "$name is neither a builtin, nor a Perl subroutine" + if $@; + die "Cannot make a non-overridable builtin fatal" + if not defined $proto; + $core = 1; + $call = "CORE::$name"; + } + if (defined $proto) { + $real_proto = " ($proto)"; + } else { + $real_proto = ''; + $proto = '@'; + } + $code = <<EOS; +sub$real_proto { + local(\$", \$!) = (', ', 0); +EOS + my @protos = fill_protos($proto); + $code .= write_invocation($core, $call, $name, @protos); + $code .= "}\n"; + print $code if $Debug; + $code = eval($code); + die if $@; + local($^W) = 0; # to avoid: Subroutine foo redefined ... + no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ... + *{$sub} = $code; +} + +1; + +__END__ + +=head1 NAME + +Fatal - replace functions with equivalents which succeed or die + +=head1 SYNOPSIS + + use Fatal qw(open close); + + sub juggle { . . . } + import Fatal 'juggle'; + +=head1 DESCRIPTION + +C<Fatal> provides a way to conveniently replace functions which normally +return a false value when they fail with equivalents which halt execution +if they are not successful. This lets you use these functions without +having to test their return values explicitly on each call. Errors are +reported via C<die>, so you can trap them using C<$SIG{__DIE__}> if you +wish to take some action before the program exits. + +The do-or-die equivalents are set up simply by calling Fatal's +C<import> routine, passing it the names of the functions to be +replaced. You may wrap both user-defined functions and overridable +CORE operators (except C<exec>, C<system> which cannot be expressed +via prototypes) in this way. + +=head1 AUTHOR + +Lionel.Cons@cern.ch + +prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu + +=cut diff --git a/lib/File/Find.pm b/lib/File/Find.pm index 70629d4ce0..11835067ff 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -95,7 +95,6 @@ sub find { my $fixtopdir = $topdir; $fixtopdir =~ s,/$,, ; $fixtopdir =~ s/\.dir$// if $Is_VMS; - $fixtopdir =~ s/\\dir$// if $Is_NT; &finddir($wanted,$fixtopdir,$topnlink); } } @@ -156,7 +155,6 @@ sub finddir { if (!$prune && chdir $_) { $name =~ s/\.dir$// if $Is_VMS; - $name =~ s/\\dir$// if $Is_NT; &finddir($wanted,$name,$nlink); chdir '..'; } @@ -185,7 +183,6 @@ sub finddepth { my $fixtopdir = $topdir; $fixtopdir =~ s,/$,, ; $fixtopdir =~ s/\.dir$// if $Is_VMS; - $fixtopdir =~ s/\\dir$// if $Is_NT; &finddepthdir($wanted,$fixtopdir,$topnlink); ($dir,$_) = ($fixtopdir,'.'); $name = $fixtopdir; @@ -245,7 +242,6 @@ sub finddepthdir { if (chdir $_) { $name =~ s/\.dir$// if $Is_VMS; - $name =~ s/\\dir$// if $Is_NT; &finddepthdir($wanted,$name,$nlink); chdir '..'; } diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm index 64477fa7f3..36ca0602a1 100644 --- a/lib/Math/Complex.pm +++ b/lib/Math/Complex.pm @@ -1,23 +1,20 @@ # # Complex numbers and associated mathematical functions -# -- Raphael Manfredi September 1996 -# -- Jarkko Hietaniemi March-October 1997 -# -- Daniel S. Lewart September-October 1997 +# -- Raphael Manfredi Since Sep 1996 +# -- Jarkko Hietaniemi Since Mar 1997 +# -- Daniel S. Lewart Since Sep 1997 # require Exporter; package Math::Complex; -$VERSION = 1.05; +use strict; -# $Id: Complex.pm,v 1.2 1997/10/15 10:08:39 jhi Exp $ +use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS); -use strict; +my ( $i, $ip2, %logn ); -use vars qw($VERSION @ISA - @EXPORT %EXPORT_TAGS - $package $display - $i $ip2 $logn %logn); +$VERSION = sprintf("%s", q$Id: Complex.pm,v 1.25 1998/02/05 16:07:37 jhi Exp $ =~ /(\d+\.\d+)/); @ISA = qw(Exporter); @@ -34,7 +31,7 @@ my @trig = qw( ); @EXPORT = (qw( - i Re Im arg + i Re Im rho theta arg sqrt log ln log10 logn cbrt root cplx cplxe @@ -65,11 +62,12 @@ use overload qw("" stringify); # -# Package globals +# Package "privates" # -$package = 'Math::Complex'; # Package name -$display = 'cartesian'; # Default display format +my $package = 'Math::Complex'; # Package name +my $display = 'cartesian'; # Default display format +my $eps = 1e-14; # Epsilon # # Object attributes (internal): @@ -80,6 +78,12 @@ $display = 'cartesian'; # Default display format # display display format (package's global when not set) # +# Die on bad *make() arguments. + +sub _cannot_make { + die "@{[(caller(1))[3]]}: Cannot take $_[0] of $_[1].\n"; +} + # # ->make # @@ -88,9 +92,26 @@ $display = 'cartesian'; # Default display format sub make { my $self = bless {}, shift; my ($re, $im) = @_; - $self->{'cartesian'} = [$re, $im]; + my $rre = ref $re; + if ( $rre ) { + if ( $rre eq ref $self ) { + $re = Re($re); + } else { + _cannot_make("real part", $rre); + } + } + my $rim = ref $im; + if ( $rim ) { + if ( $rim eq ref $self ) { + $im = Im($im); + } else { + _cannot_make("imaginary part", $rim); + } + } + $self->{'cartesian'} = [ $re, $im ]; $self->{c_dirty} = 0; $self->{p_dirty} = 1; + $self->display_format('cartesian'); return $self; } @@ -102,6 +123,22 @@ sub make { sub emake { my $self = bless {}, shift; my ($rho, $theta) = @_; + my $rrh = ref $rho; + if ( $rrh ) { + if ( $rrh eq ref $self ) { + $rho = rho($rho); + } else { + _cannot_make("rho", $rrh); + } + } + my $rth = ref $theta; + if ( $rth ) { + if ( $rth eq ref $self ) { + $theta = theta($theta); + } else { + _cannot_make("theta", $rth); + } + } if ($rho < 0) { $rho = -$rho; $theta = ($theta <= 0) ? $theta + pi() : $theta - pi(); @@ -109,6 +146,7 @@ sub emake { $self->{'polar'} = [$rho, $theta]; $self->{p_dirty} = 0; $self->{c_dirty} = 1; + $self->display_format('polar'); return $self; } @@ -438,26 +476,46 @@ sub conjugate { # # (abs) # -# Compute complex's norm (rho). +# Compute or set complex's norm (rho). # sub abs { - my ($z) = @_; - my ($r, $t) = @{$z->polar}; - return $r; + my ($z, $rho) = @_; + return $z unless ref $z; + if (defined $rho) { + $z->{'polar'} = [ $rho, ${$z->polar}[1] ]; + $z->{p_dirty} = 0; + $z->{c_dirty} = 1; + return $rho; + } else { + return ${$z->polar}[0]; + } +} + +sub _theta { + my $theta = $_[0]; + + if ($$theta > pi()) { $$theta -= pit2 } + elsif ($$theta <= -pi()) { $$theta += pit2 } } # # arg # -# Compute complex's argument (theta). +# Compute or set complex's argument (theta). # sub arg { - my ($z) = @_; - return ($z < 0 ? pi : 0) unless ref $z; - my ($r, $t) = @{$z->polar}; - if ($t > pi()) { $t -= pit2 } - elsif ($t <= -pi()) { $t += pit2 } - return $t; + my ($z, $theta) = @_; + return $z unless ref $z; + if (defined $theta) { + _theta(\$theta); + $z->{'polar'} = [ ${$z->polar}[0], $theta ]; + $z->{p_dirty} = 0; + $z->{c_dirty} = 1; + } else { + $theta = ${$z->polar}[1]; + _theta(\$theta); + } + return $theta; } # @@ -465,11 +523,20 @@ sub arg { # # Compute sqrt(z). # +# It is quite tempting to use wantarray here so that in list context +# sqrt() would return the two solutions. This, however, would +# break things like +# +# print "sqrt(z) = ", sqrt($z), "\n"; +# +# The two values would be printed side by side without no intervening +# whitespace, quite confusing. +# Therefore if you want the two solutions use the root(). +# sub sqrt { my ($z) = @_; - return $z >= 0 ? sqrt($z) : cplx(0, sqrt(-$z)) unless ref $z; - my ($re, $im) = @{$z->cartesian}; - return cplx($re < 0 ? (0, sqrt(-$re)) : (sqrt($re), 0)) if $im == 0; + my ($re, $im) = ref $z ? @{$z->cartesian} : ($z, 0); + return $re < 0 ? cplx(0, sqrt(-$re)) : sqrt($re) if $im == 0; my ($r, $t) = @{$z->polar}; return (ref $z)->emake(sqrt($r), $t/2); } @@ -479,6 +546,8 @@ sub sqrt { # # Compute cbrt(z) (cubic root). # +# Why are we not returning three values? The same answer as for sqrt(). +# sub cbrt { my ($z) = @_; return $z < 0 ? -exp(log(-$z)/3) : ($z > 0 ? exp(log($z)/3): 0) @@ -531,25 +600,53 @@ sub root { # # Re # -# Return Re(z). +# Return or set Re(z). # sub Re { - my ($z) = @_; + my ($z, $Re) = @_; return $z unless ref $z; - my ($re, $im) = @{$z->cartesian}; - return $re; + if (defined $Re) { + $z->{'cartesian'} = [ $Re, ${$z->cartesian}[1] ]; + $z->{c_dirty} = 0; + $z->{p_dirty} = 1; + } else { + return ${$z->cartesian}[0]; + } } # # Im # -# Return Im(z). +# Return or set Im(z). # sub Im { - my ($z) = @_; - return 0 unless ref $z; - my ($re, $im) = @{$z->cartesian}; - return $im; + my ($z, $Im) = @_; + return $z unless ref $z; + if (defined $Im) { + $z->{'cartesian'} = [ ${$z->cartesian}[0], $Im ]; + $z->{c_dirty} = 0; + $z->{p_dirty} = 1; + } else { + return ${$z->cartesian}[1]; + } +} + +# +# rho +# +# Return or set rho(w). +# +sub rho { + Math::Complex::abs(@_); +} + +# +# theta +# +# Return or set theta(w). +# +sub theta { + Math::Complex::arg(@_); } # @@ -668,7 +765,7 @@ sub sin { sub tan { my ($z) = @_; my $cz = cos($z); - _divbyzero "tan($z)", "cos($z)" if ($cz == 0); + _divbyzero "tan($z)", "cos($z)" if (abs($cz) < $eps); return sin($z) / $cz; } @@ -817,9 +914,10 @@ sub acosec { Math::Complex::acsc(@_) } # sub acot { my ($z) = @_; + _divbyzero "acot(0)" if (abs($z) < $eps); return ($z >= 0) ? atan2(1, $z) : atan2(-1, -$z) unless ref $z; - _divbyzero "acot(i)", if ( $z == i); - _divbyzero "acot(-i)" if (-$z == i); + _divbyzero "acot(i)" if (abs($z - i) < $eps); + _logofzero "acot(-i)" if (abs($z + i) < $eps); return atan(1 / $z); } @@ -1011,12 +1109,13 @@ sub acosech { Math::Complex::acsch(@_) } # sub acoth { my ($z) = @_; + _divbyzero 'acoth(0)' if (abs($z) < $eps); unless (ref $z) { return log(($z + 1)/($z - 1))/2 if abs($z) > 1; $z = cplx($z, 0); } - _divbyzero 'acoth(1)', "$z - 1" if ($z == 1); - _logofzero 'acoth(-1)' if ($z == -1); + _divbyzero 'acoth(1)', "$z - 1" if (abs($z - 1) < $eps); + _logofzero 'acoth(-1)', "1 / $z" if (abs($z + 1) < $eps); return log((1 + $z) / ($z - 1)) / 2; } @@ -1117,7 +1216,6 @@ sub stringify_cartesian { my $z = shift; my ($x, $y) = @{$z->cartesian}; my ($re, $im); - my $eps = 1e-14; $x = int($x + ($x < 0 ? -1 : 1) * $eps) if int(abs($x)) != int(abs($x) + $eps); @@ -1148,7 +1246,6 @@ sub stringify_polar { my $z = shift; my ($r, $t) = @{$z->polar}; my $theta; - my $eps = 1e-14; return '[0,0]' if $r <= $eps; @@ -1323,6 +1420,8 @@ number) and the above definition states that sqrt([x,pi]) = sqrt(x) * exp(i*pi/2) = [sqrt(x),pi/2] = sqrt(x)*i which is exactly what we had defined for negative real numbers above. +The C<sqrt> returns only one of the solutions: if you want the both, +use the C<root> function. All the common mathematical functions defined on real numbers that are extended to complex numbers share that same property of working @@ -1375,13 +1474,13 @@ the following (overloaded) operations are supported on complex numbers: z1 * z2 = (r1 * r2) * exp(i * (t1 + t2)) z1 / z2 = (r1 / r2) * exp(i * (t1 - t2)) z1 ** z2 = exp(z2 * log z1) - ~z1 = a - bi - abs(z1) = r1 = sqrt(a*a + b*b) - sqrt(z1) = sqrt(r1) * exp(i * t1/2) - exp(z1) = exp(a) * exp(i * b) - log(z1) = log(r1) + i*t1 - sin(z1) = 1/2i (exp(i * z1) - exp(-i * z1)) - cos(z1) = 1/2 (exp(i * z1) + exp(-i * z1)) + ~z = a - bi + abs(z) = r1 = sqrt(a*a + b*b) + sqrt(z) = sqrt(r1) * exp(i * t/2) + exp(z) = exp(a) * exp(i * b) + log(z) = log(r1) + i*t + sin(z) = 1/2i (exp(i * z1) - exp(-i * z)) + cos(z) = 1/2 (exp(i * z1) + exp(-i * z)) atan2(z1, z2) = atan(z1/z2) The following extra operations are supported on both real and complex @@ -1390,6 +1489,7 @@ numbers: Re(z) = a Im(z) = b arg(z) = t + abs(z) = r cbrt(z) = z ** (1/3) log10(z) = log(z) / log(10) @@ -1425,10 +1525,13 @@ numbers: asech(z) = acosh(1 / z) acoth(z) = atanh(1 / z) = 1/2 * log((1+z) / (z-1)) -I<log>, I<csc>, I<cot>, I<acsc>, I<acot>, I<csch>, I<coth>, -I<acosech>, I<acotanh>, have aliases I<ln>, I<cosec>, I<cotan>, -I<acosec>, I<acotan>, I<cosech>, I<cotanh>, I<acosech>, I<acotanh>, -respectively. +I<arg>, I<abs>, I<log>, I<csc>, I<cot>, I<acsc>, I<acot>, I<csch>, +I<coth>, I<acosech>, I<acotanh>, have aliases I<rho>, I<theta>, I<ln>, +I<cosec>, I<cotan>, I<acosec>, I<acotan>, I<cosech>, I<cotanh>, +I<acosech>, I<acotanh>, respectively. C<Re>, C<Im>, C<arg>, C<abs>, +C<rho>, and C<theta> can be used also also mutators. The C<cbrt> +returns only one of the solutions: if you want all three, use the +C<root> function. The I<root> function is available to compute all the I<n> roots of some complex, where I<n> is a strictly positive integer. @@ -1479,6 +1582,13 @@ but that will be silently converted into C<[3,-3pi/4]>, since the modulus must be non-negative (it represents the distance to the origin in the complex plane). +It is also possible to have a complex number as either argument of +either the C<make> or C<emake>: the appropriate component of +the argument will be used. + + $z1 = cplx(-2, 1); + $z2 = cplx($z1, 4); + =head1 STRINGIFICATION When printed, a complex number is usually shown under its cartesian @@ -1527,26 +1637,19 @@ Here are some examples: $k = exp(i * 2*pi/3); print "$j - $k = ", $j - $k, "\n"; -=head1 ERRORS DUE TO DIVISION BY ZERO + $z->Re(3); # Re, Im, arg, abs, + $j->arg(2); # (the last two aka rho, theta) + # can be used also as mutators. + +=head1 ERRORS DUE TO DIVISION BY ZERO OR LOGARITHM OF ZERO The division (/) and the following functions - tan - sec - csc - cot - asec - acsc - atan - acot - tanh - sech - csch - coth - atanh - asech - acsch - acoth + log ln log10 logn + tan sec csc cot + atan asec acsc acot + tanh sech csch coth + atanh asech acsch acoth cannot be computed for all arguments because that would mean dividing by zero or taking logarithm of zero. These situations cause fatal @@ -1562,13 +1665,30 @@ or Died at... For the C<csc>, C<cot>, C<asec>, C<acsc>, C<acot>, C<csch>, C<coth>, -C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the -C<atanh>, C<acoth>, the argument cannot be C<1> (one). For the -C<atanh>, C<acoth>, the argument cannot be C<-1> (minus one). For the -C<atan>, C<acot>, the argument cannot be C<i> (the imaginary unit). -For the C<atan>, C<acoth>, the argument cannot be C<-i> (the negative -imaginary unit). For the C<tan>, C<sec>, C<tanh>, C<sech>, the -argument cannot be I<pi/2 + k * pi>, where I<k> is any integer. +C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the the +logarithmic functions and the C<atanh>, C<acoth>, the argument cannot +be C<1> (one). For the C<atanh>, C<acoth>, the argument cannot be +C<-1> (minus one). For the C<atan>, C<acot>, the argument cannot be +C<i> (the imaginary unit). For the C<atan>, C<acoth>, the argument +cannot be C<-i> (the negative imaginary unit). For the C<tan>, +C<sec>, C<tanh>, the argument cannot be I<pi/2 + k * pi>, where I<k> +is any integer. + +Note that because we are operating on approximations of real numbers, +these errors can happen when merely `too close' to the singularities +listed above. For example C<tan(2*atan2(1,1)+1e-15)> will die of +division by zero. + +=head1 ERRORS DUE TO INDIGESTIBLE ARGUMENTS + +The C<make> and C<emake> accept both real and complex arguments. +When they cannot recognize the arguments they will die with error +messages like the following + + Math::Complex::make: Cannot take real part of ... + Math::Complex::make: Cannot take real part of ... + Math::Complex::emake: Cannot take rho of ... + Math::Complex::emake: Cannot take theta of ... =head1 BUGS @@ -1589,4 +1709,6 @@ Extensive patches by Daniel S. Lewart <F<d-lewart@uiuc.edu>>. =cut +1; + # eof diff --git a/lib/Tie/Array.pm b/lib/Tie/Array.pm index 336e003b25..4041b00e86 100644 --- a/lib/Tie/Array.pm +++ b/lib/Tie/Array.pm @@ -26,7 +26,7 @@ sub POP if ($newsize >= 0) { $val = $obj->FETCH($newsize); - $obj->SETSIZE($newsize); + $obj->STORESIZE($newsize); } $val; } @@ -155,10 +155,10 @@ and C<EXTEND> methods, and implementations of C<PUSH>, C<POP>, C<SHIFT>, C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>, C<FETCHSIZE>, C<STORESIZE>. -The B<Tie::StdHash> package provides efficient methods required for tied arrays +The B<Tie::StdArray> package provides efficient methods required for tied arrays which are implemented as blessed references to an "inner" perl array. It inherits from B<Tie::Array>, and should cause tied arrays to behave exactly -like standard hashes, allowing for selective overloading of methods. +like standard arrays, allowing for selective overloading of methods. For developers wishing to write their own tied arrays, the required methods are briefly defined below. See the L<perltie> section for more detailed diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm index 2117c54c18..89fd61dd74 100644 --- a/lib/Tie/Hash.pm +++ b/lib/Tie/Hash.pm @@ -110,7 +110,7 @@ sub new { sub TIEHASH { my $pkg = shift; - if (defined &{"{$pkg}::new"}) { + if (defined &{"${pkg}::new"}) { carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing" if $^W; $pkg->new(@_); @@ -401,7 +401,8 @@ pad_alloc(I32 optype, U32 tmptype) (unsigned long) thr, (unsigned long) curpad, (long) retval, op_name[optype])); #else - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad alloc %ld for %s\n", + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx alloc %ld for %s\n", + (unsigned long) curpad, (long) retval, op_name[optype])); #endif /* USE_THREADS */ return (PADOFFSET)retval; @@ -422,7 +423,8 @@ pad_sv(PADOFFSET po) #else if (!po) croak("panic: pad_sv po"); - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %d\n", po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx sv %d\n", + (unsigned long) curpad, po)); #endif /* USE_THREADS */ return curpad[po]; /* eventually we'll turn this into a macro */ } @@ -446,7 +448,8 @@ pad_free(PADOFFSET po) DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx free %d\n", (unsigned long) thr, (unsigned long) curpad, po)); #else - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %d\n", po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx free %d\n", + (unsigned long) curpad, po)); #endif /* USE_THREADS */ if (curpad[po] && curpad[po] != &sv_undef) SvPADTMP_off(curpad[po]); @@ -471,7 +474,8 @@ pad_swipe(PADOFFSET po) DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx swipe %d\n", (unsigned long) thr, (unsigned long) curpad, po)); #else - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %d\n", po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx swipe %d\n", + (unsigned long) curpad, po)); #endif /* USE_THREADS */ SvPADTMP_off(curpad[po]); curpad[po] = NEWSV(1107,0); @@ -480,9 +484,16 @@ pad_swipe(PADOFFSET po) padix = po - 1; } +/* XXX pad_reset() is currently disabled because it results in serious bugs. + * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed + * on the stack by OPs that use them, there are several ways to get an alias + * to a shared TARG. Such an alias will change randomly and unpredictably. + * We avoid doing this until we can think of a Better Way. + * GSAR 97-10-29 */ void pad_reset(void) { +#ifdef USE_BROKEN_PAD_RESET dTHR; register I32 po; @@ -492,7 +503,8 @@ pad_reset(void) DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx reset\n", (unsigned long) thr, (unsigned long) curpad)); #else - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad reset\n")); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx reset\n", + (unsigned long) curpad)); #endif /* USE_THREADS */ if (!tainting) { /* Can't mix tainted and non-tainted temporaries. */ for (po = AvMAX(comppad); po > padix_floor; po--) { @@ -501,6 +513,7 @@ pad_reset(void) } padix = padix_floor; } +#endif pad_reset_pending = FALSE; } @@ -522,6 +535,7 @@ find_threadsv(char *name) if (!svp) { SV *sv = NEWSV(0, 0); av_store(thr->threadsv, key, sv); + thr->threadsvp = AvARRAY(thr->threadsv); /* * Some magic variables used to be automagically initialised * in gv_fetchpv. Those which are now per-thread magicals get @@ -1169,6 +1183,7 @@ mod(OP *o, I32 type) /* FALL THROUGH */ case OP_GV: case OP_AV2ARYLEN: + hints |= HINT_BLOCK_SCOPE; case OP_SASSIGN: case OP_AELEMFAST: modcount++; @@ -1594,7 +1609,6 @@ localize(OP *o, I32 lex) if (o->op_flags & OPf_PARENS) list(o); else { - scalar(o); if (dowarn && bufptr > oldbufptr && bufptr[-1] == ',') { char *s; for (s = bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ; @@ -1651,6 +1665,12 @@ fold_constants(register OP *o) case OP_LCFIRST: case OP_UC: case OP_LC: + case OP_SLT: + case OP_SGT: + case OP_SLE: + case OP_SGE: + case OP_SCMP: + if (o->op_private & OPpLOCALE) goto nope; } @@ -2980,10 +3000,14 @@ newLOOPEX(I32 type, OP *label) dTHR; OP *o; if (type != OP_GOTO || label->op_type == OP_CONST) { - o = newPVOP(type, 0, savepv( - label->op_type == OP_CONST - ? SvPVx(((SVOP*)label)->op_sv, na) - : "" )); + /* "last()" means "last" */ + if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) + o = newOP(type, OPf_SPECIAL); + else { + o = newPVOP(type, 0, savepv(label->op_type == OP_CONST + ? SvPVx(((SVOP*)label)->op_sv, na) + : "")); + } op_free(label); } else { @@ -4605,10 +4629,11 @@ ck_subr(OP *o) goto wrapref; { OP* kid = o2; - o2 = newUNOP(OP_RV2GV, 0, kid); - o2->op_sibling = kid->op_sibling; + OP* sib = kid->op_sibling; kid->op_sibling = 0; - prev->op_sibling = o; + o2 = newUNOP(OP_RV2GV, 0, kid); + o2->op_sibling = sib; + prev->op_sibling = o2; } goto wrapref; case '\\': @@ -4637,9 +4662,10 @@ ck_subr(OP *o) wrapref: { OP* kid = o2; - o2 = newUNOP(OP_REFGEN, 0, kid); - o2->op_sibling = kid->op_sibling; + OP* sib = kid->op_sibling; kid->op_sibling = 0; + o2 = newUNOP(OP_REFGEN, 0, kid); + o2->op_sibling = sib; prev->op_sibling = o2; } break; diff --git a/os2/OS2/PrfDB/typemap b/os2/OS2/PrfDB/typemap index 1e01470f87..0b91f3750a 100644 --- a/os2/OS2/PrfDB/typemap +++ b/os2/OS2/PrfDB/typemap @@ -11,4 +11,4 @@ T_PVNULL ############################################################################# OUTPUT T_PVNULL - SvSetMagicPV((SV*)$arg, $var); + sv_setpv((SV*)$arg, $var); diff --git a/patchlevel.h b/patchlevel.h index 4831469ad7..d27f1a3723 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,5 +1,5 @@ #define PATCHLEVEL 4 -#define SUBVERSION 56 +#define SUBVERSION 58 /* local_patches -- list of locally applied less-than-subversion patches. @@ -983,11 +983,7 @@ print \" \\@INC:\\n @INC\\n\";"); /* now that script is parsed, we can modify record separator */ SvREFCNT_dec(rs); rs = SvREFCNT_inc(nrs); -#ifdef USE_THREADS - sv_setsv(*av_fetch(thr->threadsv, find_threadsv("/"), FALSE), rs); -#else - sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs); -#endif /* USE_THREADS */ + sv_setsv(perl_get_sv("/", TRUE), rs); if (do_undump) my_unexec(); @@ -1108,7 +1104,7 @@ perl_get_sv(char *name, I32 create) PADOFFSET tmp = find_threadsv(name); if (tmp != NOT_IN_PAD) { dTHR; - return *av_fetch(thr->threadsv, tmp, FALSE); + return THREADSV(tmp); } } #endif /* USE_THREADS */ @@ -2568,12 +2564,7 @@ init_predump_symbols(void) GV *tmpgv; GV *othergv; -#ifdef USE_THREADS - sv_setpvn(*av_fetch(thr->threadsv,find_threadsv("\""),FALSE)," ", 1); -#else - sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1); -#endif /* USE_THREADS */ - + sv_setpvn(perl_get_sv("\"", TRUE), " ", 1); stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); GvMULTI_on(stdingv); IoIFP(GvIOp(stdingv)) = PerlIO_stdin(); @@ -2767,7 +2758,7 @@ incpush(char *p, int addsubdirs) return; if (addsubdirs) { - subdir = newSV(0); + subdir = NEWSV(55,0); if (!archpat_auto) { STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel) + sizeof("//auto")); @@ -2783,7 +2774,7 @@ incpush(char *p, int addsubdirs) /* Break at all separators */ while (p && *p) { - SV *libdir = newSV(0); + SV *libdir = NEWSV(55,0); char *s; /* skip any consecutive separators */ @@ -2858,6 +2849,7 @@ init_main_thread() curcop = &compiling; thr->cvcache = newHV(); thr->threadsv = newAV(); + /* thr->threadsvp is set when find_threadsv is called */ thr->specific = newAV(); thr->errhv = newHV(); thr->flags = THRf_R_JOINABLE; @@ -504,8 +504,8 @@ Free_t Perl_free _((Malloc_t where)); #ifdef USE_THREADS # define ERRSV (thr->errsv) # define ERRHV (thr->errhv) -# define DEFSV *av_fetch(thr->threadsv, find_threadsv("_"), FALSE) -# define SAVE_DEFSV save_threadsv(find_threadsv("_")) +# define DEFSV THREADSV(0) +# define SAVE_DEFSV save_threadsv(0) #else # define ERRSV GvSV(errgv) # define ERRHV GvHV(errgv) @@ -1442,6 +1442,7 @@ int runops_debug _((void)); #endif #endif /* PERL_OBJECT */ +/* _ (for $_) must be first in the following list (DEFSV requires it) */ #define THREADSV_NAMES "_123456789&`'+/.,\\\";^-%=|~:\001\005!@" /* VMS doesn't use environ array and NeXT has problems with crt0.o globals */ @@ -2132,12 +2133,12 @@ enum { * and queried under the protection of sv_mutex */ #define offer_nice_chunk(chunk, chunk_size) do { \ - MUTEX_LOCK(&sv_mutex); \ + LOCK_SV_MUTEX; \ if (!nice_chunk) { \ nice_chunk = (char*)(chunk); \ nice_chunk_size = (chunk_size); \ } \ - MUTEX_UNLOCK(&sv_mutex); \ + UNLOCK_SV_MUTEX; \ } while (0) @@ -1293,7 +1293,7 @@ int yyerrflag; int yychar; YYSTYPE yyval; YYSTYPE yylval; -#line 632 "perly.y" +#line 633 "perly.y" /* PROGRAM */ #line 1360 "perly.c" #define YYABORT goto yyabort @@ -1343,7 +1343,9 @@ yyparse(void) #endif #endif - struct ysv *ysave = (struct ysv*)safemalloc(sizeof(struct ysv)); + struct ysv *ysave; + + New(73, ysave, 1, struct ysv); SAVEDESTRUCTOR(yydestruct, ysave); ysave->oldyydebug = yydebug; ysave->oldyynerrs = yynerrs; @@ -1368,8 +1370,10 @@ yyparse(void) /* ** Initialize private stacks (yyparse may be called from an action) */ - ysave->yyss = yyss = (short*)safemalloc(yystacksize*sizeof(short)); - ysave->yyvs = yyvs = (YYSTYPE*)safemalloc(yystacksize*sizeof(YYSTYPE)); + New(73, yyss, yystacksize, short); + New(73, yyvs, yystacksize, YYSTYPE); + ysave->yyss = yyss; + ysave->yyvs = yyvs; if (!yyvs || !yyss) goto yyoverflow; @@ -2008,69 +2012,70 @@ case 113: break; case 114: #line 442 "perly.y" -{ yyval.opval = newBINOP(OP_GELEM, 0, newGVREF(0,yyvsp[-4].opval), yyvsp[-2].opval); } +{ yyval.opval = newBINOP(OP_GELEM, 0, newGVREF(0,yyvsp[-4].opval), + scalar(yyvsp[-2].opval)); } break; case 115: -#line 444 "perly.y" +#line 445 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 116: -#line 446 "perly.y" +#line 447 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } break; case 117: -#line 448 "perly.y" +#line 449 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-4].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 118: -#line 452 "perly.y" +#line 453 "perly.y" { assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-3].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 119: -#line 456 "perly.y" +#line 457 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 120: -#line 458 "perly.y" +#line 459 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 121: -#line 460 "perly.y" +#line 461 "perly.y" { yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} break; case 122: -#line 462 "perly.y" +#line 463 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 123: -#line 465 "perly.y" +#line 466 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-5].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 124: -#line 470 "perly.y" +#line 471 "perly.y" { assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-4].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 125: -#line 475 "perly.y" +#line 476 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } break; case 126: -#line 477 "perly.y" +#line 478 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } break; case 127: -#line 479 "perly.y" +#line 480 "perly.y" { yyval.opval = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, @@ -2078,7 +2083,7 @@ case 127: ref(yyvsp[-3].opval, OP_ASLICE))); } break; case 128: -#line 485 "perly.y" +#line 486 "perly.y" { yyval.opval = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -2087,37 +2092,37 @@ case 128: expect = XOPERATOR; } break; case 129: -#line 492 "perly.y" +#line 493 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 130: -#line 494 "perly.y" +#line 495 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; case 131: -#line 496 "perly.y" +#line 497 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); } break; case 132: -#line 498 "perly.y" +#line 499 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); } break; case 133: -#line 501 "perly.y" +#line 502 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 134: -#line 504 "perly.y" +#line 505 "perly.y" { yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } break; case 135: -#line 506 "perly.y" +#line 507 "perly.y" { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; case 136: -#line 508 "perly.y" +#line 509 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, @@ -2127,7 +2132,7 @@ case 136: )),Nullop)); dep();} break; case 137: -#line 516 "perly.y" +#line 517 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, @@ -2138,161 +2143,161 @@ case 137: )))); dep();} break; case 138: -#line 525 "perly.y" +#line 526 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();} break; case 139: -#line 529 "perly.y" +#line 530 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, yyvsp[-1].opval, scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();} break; case 140: -#line 534 "perly.y" +#line 535 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar(yyvsp[-3].opval))); } break; case 141: -#line 537 "perly.y" +#line 538 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, newCVREF(0, scalar(yyvsp[-4].opval)))); } break; case 142: -#line 541 "perly.y" +#line 542 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); hints |= HINT_BLOCK_SCOPE; } break; case 143: -#line 544 "perly.y" +#line 545 "perly.y" { yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; case 144: -#line 546 "perly.y" +#line 547 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 145: -#line 548 "perly.y" +#line 549 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 146: -#line 550 "perly.y" +#line 551 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 147: -#line 552 "perly.y" +#line 553 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 148: -#line 554 "perly.y" +#line 555 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 149: -#line 557 "perly.y" +#line 558 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 150: -#line 559 "perly.y" +#line 560 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, 0); } break; case 151: -#line 561 "perly.y" +#line 562 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[0].opval)); } break; case 152: -#line 564 "perly.y" +#line 565 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; case 153: -#line 566 "perly.y" +#line 567 "perly.y" { yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 154: -#line 568 "perly.y" +#line 569 "perly.y" { yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; case 155: -#line 570 "perly.y" +#line 571 "perly.y" { yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; case 158: -#line 576 "perly.y" +#line 577 "perly.y" { yyval.opval = Nullop; } break; case 159: -#line 578 "perly.y" +#line 579 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 160: -#line 582 "perly.y" +#line 583 "perly.y" { yyval.opval = Nullop; } break; case 161: -#line 584 "perly.y" +#line 585 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 162: -#line 586 "perly.y" +#line 587 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 163: -#line 589 "perly.y" +#line 590 "perly.y" { yyval.ival = 0; } break; case 164: -#line 590 "perly.y" +#line 591 "perly.y" { yyval.ival = 1; } break; case 165: -#line 594 "perly.y" +#line 595 "perly.y" { in_my = 0; yyval.opval = my(yyvsp[0].opval); } break; case 166: -#line 598 "perly.y" +#line 599 "perly.y" { yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); } break; case 167: -#line 602 "perly.y" +#line 603 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; case 168: -#line 606 "perly.y" +#line 607 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 169: -#line 610 "perly.y" +#line 611 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; case 170: -#line 614 "perly.y" +#line 615 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 171: -#line 618 "perly.y" +#line 619 "perly.y" { yyval.opval = newGVREF(0,yyvsp[0].opval); } break; case 172: -#line 622 "perly.y" +#line 623 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 173: -#line 624 "perly.y" +#line 625 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 174: -#line 626 "perly.y" +#line 627 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 175: -#line 629 "perly.y" +#line 630 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2272 "perly.c" +#line 2273 "perly.c" } yyssp -= yym; yystate = *yyssp; diff --git a/perly.c.diff b/perly.c.diff index e13b04bd8c..69555cf2e0 100644 --- a/perly.c.diff +++ b/perly.c.diff @@ -105,7 +105,7 @@ Index: perly.c if (yys = getenv("YYDEBUG")) { ---- 1291,1348 ---- +--- 1291,1349 ---- #define YYACCEPT goto yyaccept #define YYERROR goto yyerrlab + @@ -152,7 +152,8 @@ Index: perly.c + #endif + #endif + -+ struct ysv *ysave = (struct ysv*)safemalloc(sizeof(struct ysv)); ++ struct ysv *ysave; ++ New(73, ysave, 1, struct ysv); + SAVEDESTRUCTOR(yydestruct, ysave); + ysave->oldyydebug = yydebug; + ysave->oldyynerrs = yynerrs; @@ -166,14 +167,16 @@ Index: perly.c { *************** *** 1381,1384 **** ---- 1357,1368 ---- +--- 1357,1370 ---- yychar = (-1); + /* + ** Initialize private stacks (yyparse may be called from an action) + */ -+ ysave->yyss = yyss = (short*)safemalloc(yystacksize*sizeof(short)); -+ ysave->yyvs = yyvs = (YYSTYPE*)safemalloc(yystacksize*sizeof(YYSTYPE)); ++ New(73, yyss, yystacksize, short); ++ New(73, yyvs, yystacksize, YYSTYPE); ++ ysave->yyss = yyss; ++ ysave->yyvs = yyvs; + if (!yyvs || !yyss) + goto yyoverflow; + diff --git a/perly.fixer b/perly.fixer index 156881657f..951da0078f 100755 --- a/perly.fixer +++ b/perly.fixer @@ -105,8 +105,8 @@ short *maxyyps; /yypv *= *&yyv\[ *-1 *\];/c\ \ if (!yyv) {\ -\ yyv = (YYSTYPE*) safemalloc(yymaxdepth * sizeof(YYSTYPE));\ -\ yys = (short*) safemalloc(yymaxdepth * sizeof(short));\ +\ New(73, yyv, yymaxdepth, YYSTYPE);\ +\ New(73, yys, yymaxdepth, short);\ \ if ( !yyv || !yys ) {\ \ yyerror( "out of memory" );\ \ return(1);\ @@ -123,10 +123,8 @@ short *maxyyps; \ int ts = yyps - yys;\ \ \ yymaxdepth *= 2;\ -\ yyv = (YYSTYPE*)realloc((char*)yyv,\ -\ yymaxdepth*sizeof(YYSTYPE));\ -\ yys = (short*)realloc((char*)yys,\ -\ yymaxdepth*sizeof(short));\ +\ Renew(yyv, yymaxdepth, YYSTYPE);\ +\ Renew(yys, yymaxdepth, short);\ \ if ( !yyv || !yys ) {\ \ yyerror( "yacc stack overflow" );\ \ return(1);\ @@ -170,8 +168,8 @@ int *maxyyps; /yypv *= *&yyv\[ *-1 *\];/c\ \ if (!yyv) {\ -\ yyv = (YYSTYPE*) safemalloc(yymaxdepth * sizeof(YYSTYPE));\ -\ yys = (int*) safemalloc(yymaxdepth * sizeof(int));\ +\ New(73, yyv, yymaxdepth, YYSTYPE);\ +\ New(73, yys, yymaxdepth, int);\ \ maxyyps = &yys[yymaxdepth];\ \ }\ \ yyps = &yys[-1];\ @@ -183,10 +181,8 @@ int *maxyyps; \ int ts = yy_ps - yys;\ \ \ yymaxdepth *= 2;\ -\ yyv = (YYSTYPE*)realloc((char*)yyv,\ -\ yymaxdepth*sizeof(YYSTYPE));\ -\ yys = (int*)realloc((char*)yys,\ -\ yymaxdepth*sizeof(int));\ +\ Renew(yyv, yymaxdepth, YYSTYPE);\ +\ Renew(yys, yymaxdepth, int);\ \ yy_ps = yyps = yys + ts;\ \ yy_pv = yypv = yyv + tv;\ \ maxyyps = &yys[yymaxdepth];\ @@ -439,7 +439,8 @@ term : term ASSIGNOP term | scalar %prec '(' { $$ = $1; } | star '{' expr ';' '}' - { $$ = newBINOP(OP_GELEM, 0, newGVREF(0,$1), $3); } + { $$ = newBINOP(OP_GELEM, 0, newGVREF(0,$1), + scalar($3)); } | star %prec '(' { $$ = $1; } | scalar '[' expr ']' %prec '(' diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 166e046f22..20c0ae1325 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -883,6 +883,11 @@ a B<-e> switch. Maybe your /tmp partition is full, or clobbered. an assignment operator, which implies modifying the value itself. Perhaps you need to copy the value to a temporary, and repeat that. +=item Cannot find an opnumber for "%s" + +(F) A string of a form C<CORE::word> was given to prototype(), but +there is no builtin with the name C<word>. + =item Cannot open temporary file (F) The create routine failed for some reason while trying to process diff --git a/pod/perlembed.pod b/pod/perlembed.pod index c43ed556aa..e7164b58f9 100644 --- a/pod/perlembed.pod +++ b/pod/perlembed.pod @@ -392,7 +392,7 @@ been wrapped here): I32 match(SV *string, char *pattern) { - SV *command = newSV(0), *retval; + SV *command = NEWSV(1099, 0), *retval; sv_setpvf(command, "my $string = '%s'; $string =~ %s", SvPV(string,na), pattern); @@ -413,7 +413,7 @@ been wrapped here): I32 substitute(SV **string, char *pattern) { - SV *command = newSV(0), *retval; + SV *command = NEWSV(1099, 0), *retval; sv_setpvf(command, "$string = '%s'; ($string =~ %s)", SvPV(*string,na), pattern); @@ -435,7 +435,7 @@ been wrapped here): I32 matches(SV *string, char *pattern, AV **match_list) { - SV *command = newSV(0); + SV *command = NEWSV(1099, 0); I32 num_matches; sv_setpvf(command, "my $string = '%s'; @array = ($string =~ %s)", @@ -456,7 +456,7 @@ been wrapped here): char *embedding[] = { "", "-e", "0" }; AV *match_list; I32 num_matches, i; - SV *text = newSV(0); + SV *text = NEWSV(1099,0); perl_construct(my_perl); perl_parse(my_perl, NULL, 3, embedding, NULL); diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index a1184c8a08..0570c8fe64 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -2374,6 +2374,13 @@ Returns the prototype of a function as a string (or C<undef> if the function has no prototype). FUNCTION is a reference to, or the name of, the function whose prototype you want to retrieve. +If FUNCTION is a string starting with C<CORE::>, the rest is taken as +a name for Perl builtin. If builtin is not I<overridable> (such as +C<qw>) or its arguments cannot be expressed by a prototype (such as +C<system>) - in other words, the builtin does not behave like a Perl +function - returns C<undef>. Otherwise, the string describing the +equivalent prototype is returned. + =item push ARRAY,LIST Treats ARRAY as a stack, and pushes the values of LIST @@ -3688,6 +3695,8 @@ Unlike dbmopen(), the tie() function will not use or require a module for you--you need to do that explicitly yourself. See L<DB_File> or the F<Config> module for interesting tie() implementations. +For further details see L<perltie>, L<tied VARIABLE>. + =item tied VARIABLE Returns a reference to the object underlying VARIABLE (the same value diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 1db8249d24..111baf0899 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -34,17 +34,19 @@ An SV can be created and loaded with one command. There are four types of values that can be loaded: an integer value (IV), a double (NV), a string, (PV), and another scalar (SV). -The five routines are: +The six routines are: SV* newSViv(IV); SV* newSVnv(double); SV* newSVpv(char*, int); + SV* newSVpvn(char*, int); SV* newSVpvf(const char*, ...); SV* newSVsv(SV*); -To change the value of an *already-existing* SV, there are six routines: +To change the value of an *already-existing* SV, there are seven routines: void sv_setiv(SV*, IV); + void sv_setuv(SV*, UV); void sv_setnv(SV*, double); void sv_setpv(SV*, char*); void sv_setpvn(SV*, char*, int) @@ -52,14 +54,14 @@ To change the value of an *already-existing* SV, there are six routines: void sv_setsv(SV*, SV*); Notice that you can choose to specify the length of the string to be -assigned by using C<sv_setpvn> or C<newSVpv>, or you may allow Perl to -calculate the length by using C<sv_setpv> or by specifying 0 as the second -argument to C<newSVpv>. Be warned, though, that Perl will determine the -string's length by using C<strlen>, which depends on the string terminating -with a NUL character. The arguments of C<sv_setpvf> are processed like -C<sprintf>, and the formatted output becomes the value. The C<sv_set*()> -functions are not generic enough to operate on values that have "magic". -See L<Magic Virtual Tables> later in this document. +assigned by using C<sv_setpvn>, C<newSVpvn>, or C<newSVpv>, or you may +allow Perl to calculate the length by using C<sv_setpv> or by specifying +0 as the second argument to C<newSVpv>. Be warned, though, that Perl will +determine the string's length by using C<strlen>, which depends on the +string terminating with a NUL character. The arguments of C<sv_setpvf> +are processed like C<sprintf>, and the formatted output becomes the value. +The C<sv_set*()> functions are not generic enough to operate on values +that have "magic". See L<Magic Virtual Tables> later in this document. All SVs that will contain strings should, but need not, be terminated with a NUL character. If it is not NUL-terminated there is a risk of @@ -835,13 +837,14 @@ as the extension is sufficient. For '~' magic, it may also be appropriate to add an I32 'signature' at the top of the private data area and check that. -Also note that most of the C<sv_set*()> functions that modify scalars do -B<not> invoke 'set' magic on their targets. This must be done by the user -either by calling the C<SvSETMAGIC()> macro after calling these functions, -or by using one of the C<SvSetMagic*()> macros. Similarly, generic C code -must call the C<SvGETMAGIC()> macro to invoke any 'get' magic if they use -an SV obtained from external sources in functions that don't handle magic. -L<API LISTING> later in this document identifies such macros and functions. +Also note that the C<sv_set*()> and C<sv_cat*()> functions described +earlier do B<not> invoke 'set' magic on their targets. This must +be done by the user either by calling the C<SvSETMAGIC()> macro after +calling these functions, or by using one of the C<sv_set*_mg()> or +C<sv_cat*_mg()> functions. Similarly, generic C code must call the +C<SvGETMAGIC()> macro to invoke any 'get' magic if they use an SV +obtained from external sources in functions that don't handle magic. +L<API LISTING> later in this document identifies such functions. For example, calls to the C<sv_cat*()> functions typically need to be followed by C<SvSETMAGIC()>, but they don't need a prior C<SvGETMAGIC()> since their implementation handles 'get' magic. @@ -1426,14 +1429,14 @@ Same as C<av_len>. Clears an array, making it empty. Does not free the memory used by the array itself. - void av_clear _((AV* ar)); + void av_clear (AV* ar) =item av_extend Pre-extend an array. The C<key> is the index to which the array should be extended. - void av_extend _((AV* ar, I32 key)); + void av_extend (AV* ar, I32 key) =item av_fetch @@ -1444,13 +1447,13 @@ that the return value is non-null before dereferencing it to a C<SV*>. See L<Understanding the Magic of Tied Hashes and Arrays> for more information on how to use this function on tied arrays. - SV** av_fetch _((AV* ar, I32 key, I32 lval)); + SV** av_fetch (AV* ar, I32 key, I32 lval) =item av_len Returns the highest index in the array. Returns -1 if the array is empty. - I32 av_len _((AV* ar)); + I32 av_len (AV* ar) =item av_make @@ -1458,27 +1461,27 @@ Creates a new AV and populates it with a list of SVs. The SVs are copied into the array, so they may be freed after the call to av_make. The new AV will have a reference count of 1. - AV* av_make _((I32 size, SV** svp)); + AV* av_make (I32 size, SV** svp) =item av_pop Pops an SV off the end of the array. Returns C<&sv_undef> if the array is empty. - SV* av_pop _((AV* ar)); + SV* av_pop (AV* ar) =item av_push Pushes an SV onto the end of the array. The array will grow automatically to accommodate the addition. - void av_push _((AV* ar, SV* val)); + void av_push (AV* ar, SV* val) =item av_shift Shifts an SV off the beginning of the array. - SV* av_shift _((AV* ar)); + SV* av_shift (AV* ar) =item av_store @@ -1492,13 +1495,13 @@ before the call, and decrementing it if the function returned NULL. See L<Understanding the Magic of Tied Hashes and Arrays> for more information on how to use this function on tied arrays. - SV** av_store _((AV* ar, I32 key, SV* val)); + SV** av_store (AV* ar, I32 key, SV* val) =item av_undef Undefines the array. Frees the memory used by the array itself. - void av_undef _((AV* ar)); + void av_undef (AV* ar) =item av_unshift @@ -1506,7 +1509,7 @@ Unshift the given number of C<undef> values onto the beginning of the array. The array will grow automatically to accommodate the addition. You must then use C<av_store> to assign values to these new elements. - void av_unshift _((AV* ar, I32 num)); + void av_unshift (AV* ar, I32 num) =item CLASS @@ -1520,7 +1523,7 @@ The XSUB-writer's interface to the C C<memcpy> function. The C<s> is the source, C<d> is the destination, C<n> is the number of items, and C<t> is the type. May fail on overlapping copies. See also C<Move>. - (void) Copy( s, d, n, t ); + (void) Copy( s, d, n, t ) =item croak @@ -1593,7 +1596,7 @@ Opening bracket on a callback. See C<LEAVE> and L<perlcall>. Used to extend the argument stack for an XSUB's return values. - EXTEND( sp, int x ); + EXTEND( sp, int x ) =item FREETMPS @@ -1657,7 +1660,7 @@ which is not visible to Perl code. So when calling C<perl_call_sv>, you should not use the GV directly; instead, you should use the method's CV, which can be obtained from the GV with the C<GvCV> macro. - GV* gv_fetchmeth _((HV* stash, char* name, STRLEN len, I32 level)); + GV* gv_fetchmeth (HV* stash, char* name, STRLEN len, I32 level) =item gv_fetchmethod @@ -1686,9 +1689,8 @@ C<level==0>. C<name> should be writable if contains C<':'> or C<'\''>. The warning against passing the GV returned by C<gv_fetchmeth> to C<perl_call_sv> apply equally to these functions. - GV* gv_fetchmethod _((HV* stash, char* name)); - GV* gv_fetchmethod_autoload _((HV* stash, char* name, - I32 autoload)); + GV* gv_fetchmethod (HV* stash, char* name) + GV* gv_fetchmethod_autoload (HV* stash, char* name, I32 autoload) =item gv_stashpv @@ -1696,13 +1698,13 @@ Returns a pointer to the stash for a specified package. If C<create> is set then the package will be created if it does not already exist. If C<create> is not set and the package does not exist then NULL is returned. - HV* gv_stashpv _((char* name, I32 create)); + HV* gv_stashpv (char* name, I32 create) =item gv_stashsv Returns a pointer to the stash for a specified package. See C<gv_stashpv>. - HV* gv_stashsv _((SV* sv, I32 create)); + HV* gv_stashsv (SV* sv, I32 create) =item GvSV @@ -1783,7 +1785,7 @@ Returns the value slot (type C<SV*>) stored in the hash entry. Clears a hash, making it empty. - void hv_clear _((HV* tb)); + void hv_clear (HV* tb) =item hv_delayfree_ent @@ -1792,7 +1794,7 @@ delays actual freeing of key and value until the end of the current statement (or thereabouts) with C<sv_2mortal>. See C<hv_iternext> and C<hv_free_ent>. - void hv_delayfree_ent _((HV* hv, HE* entry)); + void hv_delayfree_ent (HV* hv, HE* entry) =item hv_delete @@ -1801,7 +1803,7 @@ and returned to the caller. The C<klen> is the length of the key. The C<flags> value will normally be zero; if set to G_DISCARD then NULL will be returned. - SV* hv_delete _((HV* tb, char* key, U32 klen, I32 flags)); + SV* hv_delete (HV* tb, char* key, U32 klen, I32 flags) =item hv_delete_ent @@ -1810,21 +1812,21 @@ and returned to the caller. The C<flags> value will normally be zero; if set to G_DISCARD then NULL will be returned. C<hash> can be a valid precomputed hash value, or 0 to ask for it to be computed. - SV* hv_delete_ent _((HV* tb, SV* key, I32 flags, U32 hash)); + SV* hv_delete_ent (HV* tb, SV* key, I32 flags, U32 hash) =item hv_exists Returns a boolean indicating whether the specified hash key exists. The C<klen> is the length of the key. - bool hv_exists _((HV* tb, char* key, U32 klen)); + bool hv_exists (HV* tb, char* key, U32 klen) =item hv_exists_ent Returns a boolean indicating whether the specified hash key exists. C<hash> can be a valid precomputed hash value, or 0 to ask for it to be computed. - bool hv_exists_ent _((HV* tb, SV* key, U32 hash)); + bool hv_exists_ent (HV* tb, SV* key, U32 hash) =item hv_fetch @@ -1836,7 +1838,7 @@ dereferencing it to a C<SV*>. See L<Understanding the Magic of Tied Hashes and Arrays> for more information on how to use this function on tied hashes. - SV** hv_fetch _((HV* tb, char* key, U32 klen, I32 lval)); + SV** hv_fetch (HV* tb, char* key, U32 klen, I32 lval) =item hv_fetch_ent @@ -1851,20 +1853,20 @@ structure if you need to store it somewhere. See L<Understanding the Magic of Tied Hashes and Arrays> for more information on how to use this function on tied hashes. - HE* hv_fetch_ent _((HV* tb, SV* key, I32 lval, U32 hash)); + HE* hv_fetch_ent (HV* tb, SV* key, I32 lval, U32 hash) =item hv_free_ent Releases a hash entry, such as while iterating though the hash. See C<hv_iternext> and C<hv_delayfree_ent>. - void hv_free_ent _((HV* hv, HE* entry)); + void hv_free_ent (HV* hv, HE* entry) =item hv_iterinit Prepares a starting point to traverse a hash table. - I32 hv_iterinit _((HV* tb)); + I32 hv_iterinit (HV* tb) Note that hv_iterinit I<currently> returns the number of I<buckets> in the hash and I<not> the number of keys (as indicated in the Advanced @@ -1876,7 +1878,7 @@ macro to find the number of keys in a hash. Returns the key from the current position of the hash iterator. See C<hv_iterinit>. - char* hv_iterkey _((HE* entry, I32* retlen)); + char* hv_iterkey (HE* entry, I32* retlen) =item hv_iterkeysv @@ -1884,33 +1886,33 @@ Returns the key as an C<SV*> from the current position of the hash iterator. The return value will always be a mortal copy of the key. Also see C<hv_iterinit>. - SV* hv_iterkeysv _((HE* entry)); + SV* hv_iterkeysv (HE* entry) =item hv_iternext Returns entries from a hash iterator. See C<hv_iterinit>. - HE* hv_iternext _((HV* tb)); + HE* hv_iternext (HV* tb) =item hv_iternextsv Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one operation. - SV * hv_iternextsv _((HV* hv, char** key, I32* retlen)); + SV * hv_iternextsv (HV* hv, char** key, I32* retlen) =item hv_iterval Returns the value from the current position of the hash iterator. See C<hv_iterkey>. - SV* hv_iterval _((HV* tb, HE* entry)); + SV* hv_iterval (HV* tb, HE* entry) =item hv_magic Adds magic to a hash. See C<sv_magic>. - void hv_magic _((HV* hv, GV* gv, int how)); + void hv_magic (HV* hv, GV* gv, int how) =item HvNAME @@ -1932,7 +1934,7 @@ before the call, and decrementing it if the function returned NULL. See L<Understanding the Magic of Tied Hashes and Arrays> for more information on how to use this function on tied hashes. - SV** hv_store _((HV* tb, char* key, U32 klen, SV* val, U32 hash)); + SV** hv_store (HV* tb, char* key, U32 klen, SV* val, U32 hash) =item hv_store_ent @@ -1949,13 +1951,13 @@ it if the function returned NULL. See L<Understanding the Magic of Tied Hashes and Arrays> for more information on how to use this function on tied hashes. - HE* hv_store_ent _((HV* tb, SV* key, SV* val, U32 hash)); + HE* hv_store_ent (HV* tb, SV* key, SV* val, U32 hash) =item hv_undef Undefines the hash. - void hv_undef _((HV* tb)); + void hv_undef (HV* tb) =item isALNUM @@ -2019,49 +2021,49 @@ Stack marker variable for the XSUB. See C<dMARK>. Clear something magical that the SV represents. See C<sv_magic>. - int mg_clear _((SV* sv)); + int mg_clear (SV* sv) =item mg_copy Copies the magic from one SV to another. See C<sv_magic>. - int mg_copy _((SV *, SV *, char *, STRLEN)); + int mg_copy (SV *, SV *, char *, STRLEN) =item mg_find Finds the magic pointer for type matching the SV. See C<sv_magic>. - MAGIC* mg_find _((SV* sv, int type)); + MAGIC* mg_find (SV* sv, int type) =item mg_free Free any magic storage used by the SV. See C<sv_magic>. - int mg_free _((SV* sv)); + int mg_free (SV* sv) =item mg_get Do magic after a value is retrieved from the SV. See C<sv_magic>. - int mg_get _((SV* sv)); + int mg_get (SV* sv) =item mg_len Report on the SV's length. See C<sv_magic>. - U32 mg_len _((SV* sv)); + U32 mg_len (SV* sv) =item mg_magical Turns on the magical status of an SV. See C<sv_magic>. - void mg_magical _((SV* sv)); + void mg_magical (SV* sv) =item mg_set Do magic after a value is assigned to the SV. See C<sv_magic>. - int mg_set _((SV* sv)); + int mg_set (SV* sv) =item Move @@ -2069,7 +2071,7 @@ The XSUB-writer's interface to the C C<memmove> function. The C<s> is the source, C<d> is the destination, C<n> is the number of items, and C<t> is the type. Can do overlapping moves. See also C<Copy>. - (void) Move( s, d, n, t ); + (void) Move( s, d, n, t ) =item na @@ -2099,20 +2101,20 @@ memory is zeroed with C<memzero>. Creates a new AV. The reference count is set to 1. - AV* newAV _((void)); + AV* newAV (void) =item newHV Creates a new HV. The reference count is set to 1. - HV* newHV _((void)); + HV* newHV (void) =item newRV_inc Creates an RV wrapper for an SV. The reference count for the original SV is incremented. - SV* newRV_inc _((SV* ref)); + SV* newRV_inc (SV* ref) For historical reasons, "newRV" is a synonym for "newRV_inc". @@ -2121,36 +2123,45 @@ For historical reasons, "newRV" is a synonym for "newRV_inc". Creates an RV wrapper for an SV. The reference count for the original SV is B<not> incremented. - SV* newRV_noinc _((SV* ref)); + SV* newRV_noinc (SV* ref) -=item newSV +=item NEWSV Creates a new SV. The C<len> parameter indicates the number of bytes of preallocated string space the SV should have. The reference count for the -new SV is set to 1. +new SV is set to 1. C<id> is an integer id between 0 and 1299 (used to +identify leaks). - SV* newSV _((STRLEN len)); + SV* NEWSV (int id, STRLEN len) =item newSViv Creates a new SV and copies an integer into it. The reference count for the SV is set to 1. - SV* newSViv _((IV i)); + SV* newSViv (IV i) =item newSVnv Creates a new SV and copies a double into it. The reference count for the SV is set to 1. - SV* newSVnv _((NV i)); + SV* newSVnv (NV i) =item newSVpv Creates a new SV and copies a string into it. The reference count for the SV is set to 1. If C<len> is zero then Perl will compute the length. - SV* newSVpv _((char* s, STRLEN len)); + SV* newSVpv (char* s, STRLEN len) + +=item newSVpvn + +Creates a new SV and copies a string into it. The reference count for the +SV is set to 1. If C<len> is zero then Perl will create a zero length +string. + + SV* newSVpvn (char* s, STRLEN len) =item newSVrv @@ -2159,13 +2170,13 @@ it will be upgraded to one. If C<classname> is non-null then the new SV will be blessed in the specified package. The new SV is returned and its reference count is 1. - SV* newSVrv _((SV* rv, char* classname)); + SV* newSVrv (SV* rv, char* classname) =item newSVsv Creates a new SV which is an exact duplicate of the original SV. - SV* newSVsv _((SV* old)); + SV* newSVsv (SV* old) =item newXS @@ -2208,27 +2219,27 @@ Allocates a new Perl interpreter. See L<perlembed>. Performs a callback to the specified Perl sub. See L<perlcall>. - I32 perl_call_argv _((char* subname, I32 flags, char** argv)); + I32 perl_call_argv (char* subname, I32 flags, char** argv) =item perl_call_method Performs a callback to the specified Perl method. The blessed object must be on the stack. See L<perlcall>. - I32 perl_call_method _((char* methname, I32 flags)); + I32 perl_call_method (char* methname, I32 flags) =item perl_call_pv Performs a callback to the specified Perl sub. See L<perlcall>. - I32 perl_call_pv _((char* subname, I32 flags)); + I32 perl_call_pv (char* subname, I32 flags) =item perl_call_sv Performs a callback to the Perl sub whose name is in the SV. See L<perlcall>. - I32 perl_call_sv _((SV* sv, I32 flags)); + I32 perl_call_sv (SV* sv, I32 flags) =item perl_construct @@ -2242,13 +2253,13 @@ Shuts down a Perl interpreter. See L<perlembed>. Tells Perl to C<eval> the string in the SV. - I32 perl_eval_sv _((SV* sv, I32 flags)); + I32 perl_eval_sv (SV* sv, I32 flags) =item perl_eval_pv Tells Perl to C<eval> the given string and return an SV* result. - SV* perl_eval_pv _((char* p, I32 croak_on_error)); + SV* perl_eval_pv (char* p, I32 croak_on_error) =item perl_free @@ -2260,7 +2271,7 @@ Returns the AV of the specified Perl array. If C<create> is set and the Perl variable does not exist then it will be created. If C<create> is not set and the variable does not exist then NULL is returned. - AV* perl_get_av _((char* name, I32 create)); + AV* perl_get_av (char* name, I32 create) =item perl_get_cv @@ -2268,7 +2279,7 @@ Returns the CV of the specified Perl sub. If C<create> is set and the Perl variable does not exist then it will be created. If C<create> is not set and the variable does not exist then NULL is returned. - CV* perl_get_cv _((char* name, I32 create)); + CV* perl_get_cv (char* name, I32 create) =item perl_get_hv @@ -2276,7 +2287,7 @@ Returns the HV of the specified Perl hash. If C<create> is set and the Perl variable does not exist then it will be created. If C<create> is not set and the variable does not exist then NULL is returned. - HV* perl_get_hv _((char* name, I32 create)); + HV* perl_get_hv (char* name, I32 create) =item perl_get_sv @@ -2284,7 +2295,7 @@ Returns the SV of the specified Perl scalar. If C<create> is set and the Perl variable does not exist then it will be created. If C<create> is not set and the variable does not exist then NULL is returned. - SV* perl_get_sv _((char* name, I32 create)); + SV* perl_get_sv (char* name, I32 create) =item perl_parse @@ -2294,7 +2305,7 @@ Tells a Perl interpreter to parse a Perl script. See L<perlembed>. Tells Perl to C<require> a module. - void perl_require_pv _((char* pv)); + void perl_require_pv (char* pv) =item perl_run @@ -2304,31 +2315,31 @@ Tells a Perl interpreter to run. See L<perlembed>. Pops an integer off the stack. - int POPi(); + int POPi() =item POPl Pops a long off the stack. - long POPl(); + long POPl() =item POPp Pops a string off the stack. - char * POPp(); + char * POPp() =item POPn Pops a double off the stack. - double POPn(); + double POPn() =item POPs Pops an SV off the stack. - SV* POPs(); + SV* POPs() =item PUSHMARK @@ -2406,14 +2417,14 @@ The XSUB-writer's interface to the C C<realloc> function. Copy a string to a safe spot. This does not use an SV. - char* savepv _((char* sv)); + char* savepv (char* sv) =item savepvn Copy a string to a safe spot. The C<len> indicates number of bytes to copy. This does not use an SV. - char* savepvn _((char* sv, I32 len)); + char* savepvn (char* sv, I32 len) =item SAVETMPS @@ -2498,7 +2509,7 @@ indicates the number of bytes to compare. Returns true or false. Marks an SV as mortal. The SV will be destroyed when the current context ends. - SV* sv_2mortal _((SV* sv)); + SV* sv_2mortal (SV* sv) =item sv_bless @@ -2506,28 +2517,34 @@ Blesses an SV into a specified package. The SV must be an RV. The package must be designated by its stash (see C<gv_stashpv()>). The reference count of the SV is unaffected. - SV* sv_bless _((SV* sv, HV* stash)); + SV* sv_bless (SV* sv, HV* stash) -=item SvCatMagicPV +=item sv_catpv -=item SvCatMagicPVN +Concatenates the string onto the end of the string which is in the SV. +Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>. -=item SvCatMagicSV + void sv_catpv (SV* sv, char* ptr) -=item sv_catpv +=item sv_catpv_mg -Concatenates the string onto the end of the string which is in the SV. -Handles 'get' magic, but not 'set' magic. See C<SvCatMagicPV>. +Like C<sv_catpv>, but also handles 'set' magic. - void sv_catpv _((SV* sv, char* ptr)); + void sv_catpvn (SV* sv, char* ptr) =item sv_catpvn Concatenates the string onto the end of the string which is in the SV. The C<len> indicates number of bytes to copy. Handles 'get' magic, but not -'set' magic. See C<SvCatMagicPVN). +'set' magic. See C<sv_catpvn_mg>. + + void sv_catpvn (SV* sv, char* ptr, STRLEN len) + +=item sv_catpvn_mg + +Like C<sv_catpvn>, but also handles 'set' magic. - void sv_catpvn _((SV* sv, char* ptr, STRLEN len)); + void sv_catpvn_mg (SV* sv, char* ptr, STRLEN len) =item sv_catpvf @@ -2535,14 +2552,26 @@ Processes its arguments like C<sprintf> and appends the formatted output to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must typically be called after calling this function to handle 'set' magic. - void sv_catpvf _((SV* sv, const char* pat, ...)); + void sv_catpvf (SV* sv, const char* pat, ...) + +=item sv_catpvf_mg + +Like C<sv_catpvf>, but also handles 'set' magic. + + void sv_catpvf_mg (SV* sv, const char* pat, ...) =item sv_catsv Concatenates the string from SV C<ssv> onto the end of the string in SV -C<dsv>. Handles 'get' magic, but not 'set' magic. See C<SvCatMagicSV). +C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>. + + void sv_catsv (SV* dsv, SV* ssv) - void sv_catsv _((SV* dsv, SV* ssv)); +=item sv_catsv_mg + +Like C<sv_catsv>, but also handles 'set' magic. + + void sv_catsv_mg (SV* dsv, SV* ssv) =item sv_cmp @@ -2550,7 +2579,7 @@ Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the string in C<sv1> is less than, equal to, or greater than the string in C<sv2>. - I32 sv_cmp _((SV* sv1, SV* sv2)); + I32 sv_cmp (SV* sv1, SV* sv2) =item SvCUR @@ -2568,7 +2597,7 @@ Set the length of the string which is in the SV. See C<SvCUR>. Auto-decrement of the value in the SV. - void sv_dec _((SV* sv)); + void sv_dec (SV* sv) =item SvEND @@ -2582,7 +2611,7 @@ See C<SvCUR>. Access the character as Returns a boolean indicating whether the strings in the two SVs are identical. - I32 sv_eq _((SV* sv1, SV* sv2)); + I32 sv_eq (SV* sv1, SV* sv2) =item SvGETMAGIC @@ -2608,7 +2637,7 @@ Use C<SvGROW>. Auto-increment of the value in the SV. - void sv_inc _((SV* sv)); + void sv_inc (SV* sv) =item SvIOK @@ -2647,7 +2676,7 @@ Returns a boolean indicating whether the SV is blessed into the specified class. This does not know how to check for subtype, so it doesn't work in an inheritance relationship. - int sv_isa _((SV* sv, char* name)); + int sv_isa (SV* sv, char* name) =item SvIV @@ -2661,13 +2690,13 @@ Returns a boolean indicating whether the SV is an RV pointing to a blessed object. If the SV is not an RV, or if the object is not blessed, then this will return false. - int sv_isobject _((SV* sv)); + int sv_isobject (SV* sv) =item SvIVX Returns the integer which is stored in the SV. - int SvIVX (SV* sv); + int SvIVX (SV* sv) =item SvLEN @@ -2679,20 +2708,20 @@ Returns the size of the string buffer in the SV. See C<SvCUR>. Returns the length of the string in the SV. Use C<SvCUR>. - STRLEN sv_len _((SV* sv)); + STRLEN sv_len (SV* sv) =item sv_magic Adds magic to an SV. - void sv_magic _((SV* sv, SV* obj, int how, char* name, I32 namlen)); + void sv_magic (SV* sv, SV* obj, int how, char* name, I32 namlen) =item sv_mortalcopy Creates a new SV which is a copy of the original SV. The new SV is marked as mortal. - SV* sv_mortalcopy _((SV* oldsv)); + SV* sv_mortalcopy (SV* oldsv) =item SvOK @@ -2704,7 +2733,7 @@ Returns a boolean indicating whether the value is an SV. Creates a new SV which is mortal. The reference count of the SV is set to 1. - SV* sv_newmortal _((void)); + SV* sv_newmortal (void) =item sv_no @@ -2765,13 +2794,13 @@ B<private> setting. Use C<SvNOK>. Returns the double which is stored in the SV. - double SvNV (SV* sv); + double SvNV (SV* sv) =item SvNVX Returns the double which is stored in the SV. - double SvNVX (SV* sv); + double SvNVX (SV* sv) =item SvPOK @@ -2822,7 +2851,7 @@ Returns a pointer to the string in the SV. The SV must contain a string. Returns the value of the object's reference count. - int SvREFCNT (SV* sv); + int SvREFCNT (SV* sv) =item SvREFCNT_dec @@ -2858,7 +2887,7 @@ Tells an SV that it is an RV. Dereferences an RV to return the SV. - SV* SvRV (SV* sv); + SV* SvRV (SV* sv) =item SvSETMAGIC @@ -2871,13 +2900,13 @@ its argument more than once. Taints an SV if tainting is enabled - SvTAINT (SV* sv); + SvTAINT (SV* sv) =item SvTAINTED Checks to see if an SV is tainted. Returns TRUE if it is, FALSE if not. - SvTAINTED (SV* sv); + SvTAINTED (SV* sv) =item SvTAINTED_off @@ -2888,112 +2917,91 @@ of unconditionally untainting the value. Untainting should be done in the standard perl fashion, via a carefully crafted regexp, rather than directly untainting variables. - SvTAINTED_off (SV* sv); + SvTAINTED_off (SV* sv) =item SvTAINTED_on Marks an SV as tainted. - SvTAINTED_on (SV* sv); - -=item SvSetMagicIV - -A macro that calls C<sv_setiv>, and invokes 'set' magic on the SV. -May evaluate arguments more than once. - - void SvSetMagicIV (SV* sv, IV num) - -=item SvSetMagicNV - -A macro that calls C<sv_setnv>, and invokes 'set' magic on the SV. -May evaluate arguments more than once. + SvTAINTED_on (SV* sv) - void SvSetMagicNV (SV* sv, double num) +=item sv_setiv -=item SvSetMagicPV +Copies an integer into the given SV. Does not handle 'set' magic. +See C<sv_setiv_mg>. -A macro that calls C<sv_setpv>, and invokes 'set' magic on the SV. -May evaluate arguments more than once. + void sv_setiv (SV* sv, IV num) - void SvSetMagicPV (SV* sv, char *ptr) +=item sv_setiv_mg -=item SvSetMagicPVIV +Like C<sv_setiv>, but also handles 'set' magic. -A macro that calls C<sv_setpviv>, and invokes 'set' magic on the SV. -May evaluate arguments more than once. + void sv_setiv_mg (SV* sv, IV num) - void SvSetMagicPVIV (SV* sv, IV num) +=item sv_setnv -=item SvSetMagicPVN +Copies a double into the given SV. Does not handle 'set' magic. +See C<sv_setnv_mg>. -A macro that calls C<sv_setpvn>, and invokes 'set' magic on the SV. -May evaluate arguments more than once. + void sv_setnv (SV* sv, double num) - void SvSetMagicPVN (SV* sv, char* ptr, STRLEN len) +=item sv_setnv_mg -=item SvSetMagicSV +Like C<sv_setnv>, but also handles 'set' magic. -Same as C<SvSetSV>, but also invokes 'set' magic on the SV. -May evaluate arguments more than once. + void sv_setnv_mg (SV* sv, double num) - void SvSetMagicSV (SV* dsv, SV* ssv) +=item sv_setpv -=item SvSetMagicSV_nosteal +Copies a string into an SV. The string must be null-terminated. +Does not handle 'set' magic. See C<sv_setpv_mg>. -Same as C<SvSetSV_nosteal>, but also invokes 'set' magic on the SV. -May evaluate arguments more than once. + void sv_setpv (SV* sv, char* ptr) - void SvSetMagicSV_nosteal (SV* dsv, SV* ssv) +=item sv_setpv_mg -=item SvSetMagicUV +Like C<sv_setpv>, but also handles 'set' magic. -A macro that calls C<sv_setuv>, and invokes 'set' magic on the SV. -May evaluate arguments more than once. + void sv_setpv_mg (SV* sv, char* ptr) - void SvSetMagicUV (SV* sv, UV num) +=item sv_setpviv -=item sv_setiv +Copies an integer into the given SV, also updating its string value. +Does not handle 'set' magic. See C<sv_setpviv_mg>. -Copies an integer into the given SV. Does not handle 'set' magic. -See C<SvSetMagicIV>. + void sv_setpviv (SV* sv, IV num) - void sv_setiv _((SV* sv, IV num)); +=item sv_setpviv_mg -=item sv_setnv +Like C<sv_setpviv>, but also handles 'set' magic. -Copies a double into the given SV. Does not handle 'set' magic. -See C<SvSetMagicNV>. - - void sv_setnv _((SV* sv, double num)); + void sv_setpviv_mg (SV* sv, IV num) -=item sv_setpv +=item sv_setpvn -Copies a string into an SV. The string must be null-terminated. -Does not handle 'set' magic. See C<SvSetMagicPV>. +Copies a string into an SV. The C<len> parameter indicates the number of +bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>. - void sv_setpv _((SV* sv, char* ptr)); + void sv_setpvn (SV* sv, char* ptr, STRLEN len) -=item sv_setpviv +=item sv_setpvn_mg -Copies an integer into the given SV, also updating its string value. -Does not handle 'set' magic. See C<SvSetMagicPVIV>. +Like C<sv_setpvn>, but also handles 'set' magic. - void sv_setpviv _((SV* sv, IV num)); + void sv_setpvn_mg (SV* sv, char* ptr, STRLEN len) -=item sv_setpvn +=item sv_setpvf -Copies a string into an SV. The C<len> parameter indicates the number of -bytes to be copied. Does not handle 'set' magic. See C<SvSetMagicPVN>. +Processes its arguments like C<sprintf> and sets an SV to the formatted +output. Does not handle 'set' magic. See C<sv_setpvf_mg>. - void sv_setpvn _((SV* sv, char* ptr, STRLEN len)); + void sv_setpvf (SV* sv, const char* pat, ...) -=item sv_setpvf +=item sv_setpvf_mg -Processes its arguments like C<sprintf> and sets an SV to the formatted -output. Does not handle 'set' magic. C<SvSETMAGIC()> must typically -be called after calling this function to handle 'set' magic. +Like C<sv_setpvf>, but also handles 'set' magic. - void sv_setpvf _((SV* sv, const char* pat, ...)); + void sv_setpvf_mg (SV* sv, const char* pat, ...) =item sv_setref_iv @@ -3003,7 +3011,7 @@ the new SV. The C<classname> argument indicates the package for the blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV will be returned and will have a reference count of 1. - SV* sv_setref_iv _((SV *rv, char *classname, IV iv)); + SV* sv_setref_iv (SV *rv, char *classname, IV iv) =item sv_setref_nv @@ -3013,7 +3021,7 @@ the new SV. The C<classname> argument indicates the package for the blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV will be returned and will have a reference count of 1. - SV* sv_setref_nv _((SV *rv, char *classname, double nv)); + SV* sv_setref_nv (SV *rv, char *classname, double nv) =item sv_setref_pv @@ -3024,7 +3032,7 @@ into the SV. The C<classname> argument indicates the package for the blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV will be returned and will have a reference count of 1. - SV* sv_setref_pv _((SV *rv, char *classname, void* pv)); + SV* sv_setref_pv (SV *rv, char *classname, void* pv) Do not use with integral Perl types such as HV, AV, SV, CV, because those objects will become corrupted by the pointer copy process. @@ -3040,7 +3048,7 @@ argument indicates the package for the blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV will be returned and will have a reference count of 1. - SV* sv_setref_pvn _((SV *rv, char *classname, char* pv, I32 n)); + SV* sv_setref_pvn (SV *rv, char *classname, char* pv, I32 n) Note that C<sv_setref_pv> copies the pointer while this copies the string. @@ -3062,17 +3070,28 @@ May evaluate arguments more than once. Copies the contents of the source SV C<ssv> into the destination SV C<dsv>. The source SV may be destroyed if it is mortal. Does not handle 'set' magic. -See the macro forms C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and -C<SvSetMagicSV_nosteal>. +See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and C<sv_setsv_mg>. + + void sv_setsv (SV* dsv, SV* ssv) + +=item sv_setsv_mg - void sv_setsv _((SV* dsv, SV* ssv)); +Like C<sv_setsv>, but also handles 'set' magic. + + void sv_setsv_mg (SV* dsv, SV* ssv) =item sv_setuv Copies an unsigned integer into the given SV. Does not handle 'set' magic. -See C<SvSetMagicUV>. +See C<sv_setuv_mg>. + + void sv_setuv (SV* sv, UV num) + +=item sv_setuv_mg + +Like C<sv_setuv>, but also handles 'set' magic. - void sv_setuv _((SV* sv, UV num)); + void sv_setuv_mg (SV* sv, UV num) =item SvSTASH @@ -3131,7 +3150,7 @@ C<svtype> enum. Test these flags with the C<SvTYPE> macro. Used to upgrade an SV to a more complex form. Uses C<sv_upgrade> to perform the upgrade if necessary. See C<svtype>. - bool SvUPGRADE _((SV* sv, svtype mt)); + bool SvUPGRADE (SV* sv, svtype mt) =item sv_upgrade @@ -3147,9 +3166,7 @@ Unsets the RV status of the SV, and decrements the reference count of whatever was being referenced by the RV. This can almost be thought of as a reversal of C<newSVrv>. See C<SvROK_off>. - void sv_unref _((SV* sv)); - -=item SvUseMagicPVN + void sv_unref (SV* sv) =item sv_usepvn @@ -3159,9 +3176,15 @@ The C<ptr> should point to memory that was allocated by C<malloc>. The string length, C<len>, must be supplied. This function will realloc the memory pointed to by C<ptr>, so that pointer should not be freed or used by the programmer after giving it to sv_usepvn. Does not handle 'set' magic. -See C<SvUseMagicPVN>. +See C<sv_usepvn_mg>. + + void sv_usepvn (SV* sv, char* ptr, STRLEN len) + +=item sv_usepvn_mg + +Like C<sv_usepvn>, but also handles 'set' magic. - void sv_usepvn _((SV* sv, char* ptr, STRLEN len)); + void sv_usepvn_mg (SV* sv, char* ptr, STRLEN len) =item sv_yes @@ -3228,7 +3251,7 @@ C<xsubpp>. Return from XSUB, indicating number of items on the stack. This is usually handled by C<xsubpp>. - XSRETURN(int x); + XSRETURN(int x) =item XSRETURN_EMPTY @@ -3240,7 +3263,7 @@ Return an empty list from an XSUB immediately. Return an integer from an XSUB immediately. Uses C<XST_mIV>. - XSRETURN_IV(IV v); + XSRETURN_IV(IV v) =item XSRETURN_NO @@ -3252,13 +3275,13 @@ Return C<&sv_no> from an XSUB immediately. Uses C<XST_mNO>. Return an double from an XSUB immediately. Uses C<XST_mNV>. - XSRETURN_NV(NV v); + XSRETURN_NV(NV v) =item XSRETURN_PV Return a copy of a string from an XSUB immediately. Uses C<XST_mPV>. - XSRETURN_PV(char *v); + XSRETURN_PV(char *v) =item XSRETURN_UNDEF @@ -3277,39 +3300,39 @@ Return C<&sv_yes> from an XSUB immediately. Uses C<XST_mYES>. Place an integer into the specified position C<i> on the stack. The value is stored in a new mortal SV. - XST_mIV( int i, IV v ); + XST_mIV( int i, IV v ) =item XST_mNV Place a double into the specified position C<i> on the stack. The value is stored in a new mortal SV. - XST_mNV( int i, NV v ); + XST_mNV( int i, NV v ) =item XST_mNO Place C<&sv_no> into the specified position C<i> on the stack. - XST_mNO( int i ); + XST_mNO( int i ) =item XST_mPV Place a copy of a string into the specified position C<i> on the stack. The value is stored in a new mortal SV. - XST_mPV( int i, char *v ); + XST_mPV( int i, char *v ) =item XST_mUNDEF Place C<&sv_undef> into the specified position C<i> on the stack. - XST_mUNDEF( int i ); + XST_mUNDEF( int i ) =item XST_mYES Place C<&sv_yes> into the specified position C<i> on the stack. - XST_mYES( int i ); + XST_mYES( int i ) =item XS_VERSION @@ -3327,7 +3350,7 @@ C<xsubpp>. See L<perlxs/"The VERSIONCHECK: Keyword">. The XSUB-writer's interface to the C C<memzero> function. The C<d> is the destination, C<n> is the number of items, and C<t> is the type. - (void) Zero( d, n, t ); + (void) Zero( d, n, t ) =back diff --git a/pod/perlmodlib.pod b/pod/perlmodlib.pod index cfb281dcc7..14bb7ebfa4 100644 --- a/pod/perlmodlib.pod +++ b/pod/perlmodlib.pod @@ -225,6 +225,10 @@ write linker options files for dynamic extension add blib/* directories to @INC +=item Fatal + +make errors in builtins or Perl functions fatal + =item Fcntl load the C Fcntl.h defines diff --git a/pod/perlobj.pod b/pod/perlobj.pod index 7428334ee2..3d7bee8647 100644 --- a/pod/perlobj.pod +++ b/pod/perlobj.pod @@ -331,14 +331,24 @@ automatically destroyed. (This may even be after you exit, if you've stored references in global variables.) If you want to capture control just before the object is freed, you may define a DESTROY method in your class. It will automatically be called at the appropriate moment, -and you can do any extra cleanup you need to do. - -Perl doesn't do nested destruction for you. If your constructor -re-blessed a reference from one of your base classes, your DESTROY may -need to call DESTROY for any base classes that need it. But this applies -to only re-blessed objects--an object reference that is merely -I<CONTAINED> in the current object will be freed and destroyed -automatically when the current object is freed. +and you can do any extra cleanup you need to do. Perl passes a reference +to the object under destruction as the first (and only) argument. Beware +that the reference is a read-only value, and cannot be modified by +manipulating C<$_[0]> within the destructor. The object itself (i.e. +the thingy the reference points to, namely C<${$_[0]}>, C<@{$_[0]}>, +C<%{$_[0]}> etc.) is not similarly constrained. + +If you arrange to re-bless the reference before the destructor returns, +perl will again call the DESTROY method for the re-blessed object after +the current one returns. This can be used for clean delegation of +object destruction, or for ensuring that destructors in the base classes +of your choosing get called. Explicitly calling DESTROY is also possible, +but is usually never needed. + +Do not confuse the foregoing with how objects I<CONTAINED> in the current +one are destroyed. Such objects will be freed and destroyed automatically +when the current object is freed, provided no other references to them exist +elsewhere. =head2 WARNING diff --git a/pod/perlre.pod b/pod/perlre.pod index 7d0ba542f8..373e1ca84e 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -251,12 +251,12 @@ function of the extension. Several extensions are already supported: =over 10 -=item (?#text) +=item C<(?#text)> A comment. The text is ignored. If the C</x> switch is used to enable whitespace formatting, a simple C<#> will suffice. -=item (?:regexp) +=item C<(?:regexp)> This groups things like "()" but doesn't make backreferences like "()" does. So @@ -268,12 +268,12 @@ is like but doesn't spit out extra fields. -=item (?=regexp) +=item C<(?=regexp)> A zero-width positive lookahead assertion. For example, C</\w+(?=\t)/> matches a word followed by a tab, without including the tab in C<$&>. -=item (?!regexp) +=item C<(?!regexp)> A zero-width negative lookahead assertion. For example C</foo(?!bar)/> matches any occurrence of "foo" that isn't followed by "bar". Note @@ -291,24 +291,23 @@ easier just to say: For lookbehind see below. -=item (?<=regexp) +=item C<(?<=regexp)> A zero-width positive lookbehind assertion. For example, C</(?=\t)\w+/> matches a word following a tab, without including the tab in C<$&>. Works only for fixed-width lookbehind. -=item (?<!regexp) +=item C<(?<!regexp)> A zero-width negative lookbehind assertion. For example C</(?<!bar)foo/> matches any occurrence of "foo" that isn't following "bar". Works only for fixed-width lookbehind. -=item (?{ code }) +=item C<(?{ code })> Experimental "evaluate any Perl code" zero-width assertion. Always -succeeds. Currently the quoting rules are somewhat convoluted, as is the -determination where the C<code> ends. - +succeeds. C<code> is not interpolated. Currently the rules to +determine where the C<code> ends are somewhat convoluted. =item C<(?E<gt>regexp)> @@ -371,9 +370,9 @@ Note that on simple groups like the above C<(?> [^()]+ )> a similar effect may be achieved by negative lookahead, as in C<[^()]+ (?! [^()] )>. This was only 4 times slower on a string with 1000000 C<a>s. -=item (?(condition)yes-regexp|no-regexp) +=item C<(?(condition)yes-regexp|no-regexp)> -=item (?(condition)yes-regexp) +=item C<(?(condition)yes-regexp)> Conditional expression. C<(condition)> should be either an integer in parentheses (which is valid if the corresponding pair of parentheses @@ -388,7 +387,7 @@ Say, matches a chunk of non-parentheses, possibly included in parentheses themselves. -=item (?imsx) +=item C<(?imsx)> One or more embedded pattern-match modifiers. This is particularly useful for patterns that are specified in a table somewhere, some of diff --git a/pod/perlrun.pod b/pod/perlrun.pod index eccb5e00b7..01ad16783d 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -252,11 +252,15 @@ equivalent to B<-Dtls>): 512 r Regular expression parsing and execution 1024 x Syntax tree dump 2048 u Tainting checks - 4096 L Memory leaks (not supported anymore) + 4096 L Memory leaks (needs C<-DLEAKTEST> when compiling Perl) 8192 H Hash dump -- usurps values() 16384 X Scratchpad allocation 32768 D Cleaning up +All these flags require C<-DDEBUGGING> when you compile the Perl +executable. This flag is automatically set if you include C<-g> +option when C<Configure> asks you about optimizer/debugger flags. + =item B<-e> I<commandline> may be used to enter one line of script. diff --git a/pod/perltoc.pod b/pod/perltoc.pod index 74b0029d73..d3f3a812b1 100644 --- a/pod/perltoc.pod +++ b/pod/perltoc.pod @@ -2420,9 +2420,9 @@ hv_iternext, hv_iternextsv, hv_iterval, hv_magic, HvNAME, hv_store, hv_store_ent, hv_undef, isALNUM, isALPHA, isDIGIT, isLOWER, isSPACE, isUPPER, items, ix, LEAVE, MARK, mg_clear, mg_copy, mg_find, mg_free, mg_get, mg_len, mg_magical, mg_set, Move, na, New, Newc, Newz, newAV, -newHV, newRV_inc, newRV_noinc, newSV, newSViv, newSVnv, newSVpv, newSVrv, -newSVsv, newXS, newXSproto, Nullav, Nullch, Nullcv, Nullhv, Nullsv, -ORIGMARK, perl_alloc, perl_call_argv, perl_call_method, perl_call_pv, +newHV, newRV_inc, newRV_noinc, NEWSV, newSViv, newSVnv, newSVpv, newSVpvn, +newSVpvf, newSVrv, newSVsv, newXS, newXSproto, Nullav, Nullch, Nullcv, Nullhv, +Nullsv, ORIGMARK, perl_alloc, perl_call_argv, perl_call_method, perl_call_pv, perl_call_sv, perl_construct, perl_destruct, perl_eval_sv, perl_eval_pv, perl_free, perl_get_av, perl_get_cv, perl_get_hv, perl_get_sv, perl_parse, perl_require_pv, perl_run, POPi, POPl, POPp, POPn, POPs, PUSHMARK, PUSHi, diff --git a/pod/perlxs.pod b/pod/perlxs.pod index d257b196eb..07abd10564 100644 --- a/pod/perlxs.pod +++ b/pod/perlxs.pod @@ -268,17 +268,25 @@ be seen by Perl. The OUTPUT: keyword will also allow an output parameter to be mapped to a matching piece of code rather than to a -typemap. The following duplicates the behavior of the -typemap: +typemap. bool_t rpcb_gettime(host,timep) char *host time_t &timep OUTPUT: - timep SvSetMagicNV(ST(1), (double)timep); - -See L<perlguts> for details about C<SvSetMagicNV()>. + timep sv_setnv(ST(1), (double)timep); + +B<xsubpp> emits an automatic C<SvSETMAGIC()> for all parameters in the +OUTPUT section of the XSUB, except RETVAL. This is the usually desired +behavior, as it takes care of properly invoking 'set' magic on output +parameters (needed for hash or array element parameters that must be +created if they didn't exist). If for some reason, this behavior is +not desired, the OUTPUT section may contain a C<SETMAGIC: DISABLE> line +to disable it for the remainder of the parameters in the OUTPUT section. +Likewise, C<SETMAGIC: ENABLE> can be used to reenable it for the +remainder of the OUTPUT section. See L<perlguts> for more details +about 'set' magic. =head2 The CODE: Keyword @@ -575,6 +583,9 @@ the following statement. ($status, $timep) = rpcb_gettime("localhost"); +When handling output parameters with a PPCODE section, be sure to handle +'set' magic properly. See L<perlguts> for details about 'set' magic. + =head2 Returning Undef And Empty Lists Occasionally the programmer will want to return simply diff --git a/pod/perlxstut.pod b/pod/perlxstut.pod index dfc56ffbf1..867d42a8c2 100644 --- a/pod/perlxstut.pod +++ b/pod/perlxstut.pod @@ -428,7 +428,7 @@ Let's now take a look at a portion of the .c file created for our extension. } else { arg = 0.0; } - SvSetMagicNV(ST(0), (double)arg); /* XXXXX */ + sv_setnv(ST(0), (double)arg); /* XXXXX */ } XSRETURN(1); } @@ -438,10 +438,10 @@ the typemap file, you'll see that doubles are of type T_DOUBLE. In the INPUT section, an argument that is T_DOUBLE is assigned to the variable arg by calling the routine SvNV on something, then casting it to double, then assigned to the variable arg. Similarly, in the OUTPUT section, -once arg has its final value, it is passed to the SvSetMagicNV() macro -(which calls the sv_setnv() function) to be passed back to the calling -subroutine. These macros/functions are explained in L<perlguts>; we'll talk -more later about what that "ST(0)" means in the section on the argument stack. +once arg has its final value, it is passed to the sv_setnv function to +be passed back to the calling subroutine. These two functions are explained +in L<perlguts>; we'll talk more later about what that "ST(0)" means in the +section on the argument stack. =head2 WARNING @@ -362,9 +362,54 @@ PP(pp_prototype) SV *ret; ret = &sv_undef; + if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { + char *s = SvPVX(TOPs); + if (strnEQ(s, "CORE::", 6)) { + int code; + + code = keyword(s + 6, SvCUR(TOPs) - 6); + if (code < 0) { /* Overridable. */ +#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2) + int i = 0, n = 0, seen_question = 0; + I32 oa; + char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */ + + while (i < MAXO) { /* The slow way. */ + if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i])) + goto found; + i++; + } + goto nonesuch; /* Should not happen... */ + found: + oa = opargs[i] >> OASHIFT; + while (oa) { + if (oa & OA_OPTIONAL) { + seen_question = 1; + str[n++] = ';'; + } else if (seen_question) + goto set; /* XXXX system, exec */ + if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF + && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) { + str[n++] = '\\'; + } + /* What to do with R ((un)tie, tied, (sys)read, recv)? */ + str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; + oa = oa >> 4; + } + str[n++] = '\0'; + ret = sv_2mortal(newSVpv(str, n - 1)); + } else if (code) /* Non-Overridable */ + goto set; + else { /* None such */ + nonesuch: + croak("Cannot find an opnumber for \"%s\"", s+6); + } + } + } cv = sv_2cv(TOPs, &stash, &gv, FALSE); if (cv && SvPOK(cv)) ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv))); + set: SETs(ret); RETURN; } @@ -1868,7 +1913,7 @@ PP(pp_vec) } } - sv_setiv(TARG, (IV)retnum); + sv_setuv(TARG, (UV)retnum); PUSHs(TARG); RETURN; } @@ -4394,7 +4439,7 @@ PP(pp_threadsv) if (op->op_private & OPpLVAL_INTRO) PUSHs(*save_threadsv(op->op_targ)); else - PUSHs(*av_fetch(thr->threadsv, op->op_targ, FALSE)); + PUSHs(THREADSV(op->op_targ)); RETURN; #else DIE("tried to access per-thread data in non-threaded perl"); @@ -91,10 +91,12 @@ PP(pp_regcomp) { else { t = SvPV(tmpstr, len); - /* JMR: Check against the last compiled regexp */ - if ( ! pm->op_pmregexp || ! pm->op_pmregexp->precomp - || strnNE(pm->op_pmregexp->precomp, t, len) - || pm->op_pmregexp->precomp[len]) { + /* JMR: Check against the last compiled regexp + To know for sure, we'd need the length of precomp. + But we don't have it, so we must ... take a guess. */ + if (!pm->op_pmregexp || !pm->op_pmregexp->precomp || + memNE(pm->op_pmregexp->precomp, t, len + 1)) + { if (pm->op_pmregexp) { ReREFCNT_dec(pm->op_pmregexp); pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */ @@ -552,7 +554,7 @@ PP(pp_grepstart) SAVETMPS; #ifdef USE_THREADS /* SAVE_DEFSV does *not* suffice here */ - save_sptr(av_fetch(thr->threadsv, find_threadsv("_"), FALSE)); + save_sptr(&THREADSV(0)); #else SAVESPTR(GvSV(defgv)); #endif /* USE_THREADS */ @@ -1135,6 +1137,7 @@ PP(pp_caller) register PERL_CONTEXT *cx; I32 dbcxix; I32 gimme; + HV *hv; SV *sv; I32 count = 0; @@ -1164,14 +1167,22 @@ PP(pp_caller) } if (GIMME != G_ARRAY) { - dTARGET; - - sv_setpv(TARG, HvNAME(cx->blk_oldcop->cop_stash)); - PUSHs(TARG); + hv = cx->blk_oldcop->cop_stash; + if (!hv) + PUSHs(&sv_undef); + else { + dTARGET; + sv_setpv(TARG, HvNAME(hv)); + PUSHs(TARG); + } RETURN; } - PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0))); + hv = cx->blk_oldcop->cop_stash; + if (!hv) + PUSHs(&sv_undef); + else + PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0))); PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0))); PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line))); if (!MAXARG) @@ -2288,7 +2288,7 @@ vivify_ref(SV *sv, U32 to_what) } switch (to_what) { case OPpDEREF_SV: - SvRV(sv) = newSV(0); + SvRV(sv) = NEWSV(355,0); break; case OPpDEREF_AV: SvRV(sv) = (SV*)newAV(); @@ -1069,11 +1069,12 @@ reg(I32 paren, I32 *flagp) rx->data->data[n+1] = (void*)av; rx->data->data[n+2] = (void*)sop; SvREFCNT_dec(sv); + } else { /* First pass */ + if (tainted) + FAIL("Eval-group in insecure regular expression"); } nextchar(); - if (tainted) - FAIL("Eval-group in insecure regular expression"); return reganode(EVAL, n); } case '(': @@ -346,7 +346,7 @@ save_threadsv(PADOFFSET i) { #ifdef USE_THREADS dTHR; - SV **svp = av_fetch(thr->threadsv, i, FALSE); + SV **svp = &THREADSV(i); /* XXX Change to save by offset */ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "save_threadsv %u: %p %p:%s\n", i, svp, *svp, SvPEEK(*svp))); save_svref(svp); @@ -65,6 +65,10 @@ static void sv_mortalgrow _((void)); static void sv_unglob _((SV* sv)); static void sv_check_thinkfirst _((SV *sv)); +#ifndef PURIFY +static void *my_safemalloc(MEM_SIZE size); +#endif + typedef void (*SVFUNC) _((SV*)); #define VTBL *vtbl #define FCALL *f @@ -75,18 +79,18 @@ typedef void (*SVFUNC) _((SV*)); #define new_SV(p) \ do { \ - MUTEX_LOCK(&sv_mutex); \ + LOCK_SV_MUTEX; \ (p) = (SV*)safemalloc(sizeof(SV)); \ reg_add(p); \ - MUTEX_UNLOCK(&sv_mutex); \ + UNLOCK_SV_MUTEX; \ } while (0) #define del_SV(p) \ do { \ - MUTEX_LOCK(&sv_mutex); \ + LOCK_SV_MUTEX; \ reg_remove(p); \ Safefree((char*)(p)); \ - MUTEX_UNLOCK(&sv_mutex); \ + UNLOCK_SV_MUTEX; \ } while (0) static SV **registry; @@ -121,8 +125,7 @@ SV* sv; I32 oldsize = regsize; regsize = regsize ? ((regsize << 2) + 1) : 2037; - registry = (SV**)safemalloc(regsize * sizeof(SV*)); - memzero(registry, regsize * sizeof(SV*)); + Newz(707, registry, regsize, SV*); if (oldreg) { I32 i; @@ -193,24 +196,24 @@ U32 flags; ++sv_count; \ } while (0) -#define new_SV(p) do { \ - MUTEX_LOCK(&sv_mutex); \ - if (sv_root) \ - uproot_SV(p); \ - else \ - (p) = more_sv(); \ - MUTEX_UNLOCK(&sv_mutex); \ +#define new_SV(p) do { \ + LOCK_SV_MUTEX; \ + if (sv_root) \ + uproot_SV(p); \ + else \ + (p) = more_sv(); \ + UNLOCK_SV_MUTEX; \ } while (0) #ifdef DEBUGGING -#define del_SV(p) do { \ - MUTEX_LOCK(&sv_mutex); \ - if (debug & 32768) \ - del_sv(p); \ - else \ - plant_SV(p); \ - MUTEX_UNLOCK(&sv_mutex); \ +#define del_SV(p) do { \ + LOCK_SV_MUTEX; \ + if (debug & 32768) \ + del_sv(p); \ + else \ + plant_SV(p); \ + UNLOCK_SV_MUTEX; \ } while (0) STATIC void @@ -426,7 +429,8 @@ more_xiv(void) { register IV** xiv; register IV** xivend; - XPV* ptr = (XPV*)safemalloc(1008); + XPV* ptr; + New(705, ptr, 1008/sizeof(XPV), XPV); ptr->xpv_pv = (char*)xiv_arenaroot; /* linked list of xiv arenas */ xiv_arenaroot = ptr; /* to keep Purify happy */ @@ -467,7 +471,7 @@ more_xnv(void) { register double* xnv; register double* xnvend; - xnv = (double*)safemalloc(1008); + New(711, xnv, 1008/sizeof(double), double); xnvend = &xnv[1008 / sizeof(double) - 1]; xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */ xnv_root = xnv; @@ -503,7 +507,7 @@ more_xrv(void) { register XRV* xrv; register XRV* xrvend; - xrv_root = (XRV*)safemalloc(1008); + New(712, xrv_root, 1008/sizeof(XRV), XRV); xrv = xrv_root; xrvend = &xrv[1008 / sizeof(XRV) - 1]; while (xrv < xrvend) { @@ -538,7 +542,7 @@ more_xpv(void) { register XPV* xpv; register XPV* xpvend; - xpv_root = (XPV*)safemalloc(1008); + New(713, xpv_root, 1008/sizeof(XPV), XPV); xpv = xpv_root; xpvend = &xpv[1008 / sizeof(XPV) - 1]; while (xpv < xpvend) { @@ -581,38 +585,52 @@ more_xpv(void) #define del_XPV(p) del_xpv((XPV *)p) #endif -#define new_XPVIV() (void*)safemalloc(sizeof(XPVIV)) -#define del_XPVIV(p) Safefree((char*)p) - -#define new_XPVNV() (void*)safemalloc(sizeof(XPVNV)) -#define del_XPVNV(p) Safefree((char*)p) - -#define new_XPVMG() (void*)safemalloc(sizeof(XPVMG)) -#define del_XPVMG(p) Safefree((char*)p) - -#define new_XPVLV() (void*)safemalloc(sizeof(XPVLV)) -#define del_XPVLV(p) Safefree((char*)p) - -#define new_XPVAV() (void*)safemalloc(sizeof(XPVAV)) -#define del_XPVAV(p) Safefree((char*)p) - -#define new_XPVHV() (void*)safemalloc(sizeof(XPVHV)) -#define del_XPVHV(p) Safefree((char*)p) - -#define new_XPVCV() (void*)safemalloc(sizeof(XPVCV)) -#define del_XPVCV(p) Safefree((char*)p) - -#define new_XPVGV() (void*)safemalloc(sizeof(XPVGV)) -#define del_XPVGV(p) Safefree((char*)p) - -#define new_XPVBM() (void*)safemalloc(sizeof(XPVBM)) -#define del_XPVBM(p) Safefree((char*)p) - -#define new_XPVFM() (void*)safemalloc(sizeof(XPVFM)) -#define del_XPVFM(p) Safefree((char*)p) - -#define new_XPVIO() (void*)safemalloc(sizeof(XPVIO)) -#define del_XPVIO(p) Safefree((char*)p) +#ifdef PURIFY +# define my_safemalloc(s) safemalloc(s) +# define my_safefree(s) free(s) +#else +static void* +my_safemalloc(MEM_SIZE size) +{ + char *p; + New(717, p, size, char); + return (void*)p; +} +# define my_safefree(s) Safefree(s) +#endif + +#define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV)) +#define del_XPVIV(p) my_safefree((char*)p) + +#define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV)) +#define del_XPVNV(p) my_safefree((char*)p) + +#define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG)) +#define del_XPVMG(p) my_safefree((char*)p) + +#define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV)) +#define del_XPVLV(p) my_safefree((char*)p) + +#define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV)) +#define del_XPVAV(p) my_safefree((char*)p) + +#define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV)) +#define del_XPVHV(p) my_safefree((char*)p) + +#define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV)) +#define del_XPVCV(p) my_safefree((char*)p) + +#define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV)) +#define del_XPVGV(p) my_safefree((char*)p) + +#define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM)) +#define del_XPVBM(p) my_safefree((char*)p) + +#define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM)) +#define del_XPVFM(p) my_safefree((char*)p) + +#define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO)) +#define del_XPVIO(p) my_safefree((char*)p) bool sv_upgrade(register SV *sv, U32 mt) @@ -1130,6 +1148,13 @@ sv_setiv(register SV *sv, IV i) } void +sv_setiv_mg(register SV *sv, IV i) +{ + sv_setiv(sv,i); + SvSETMAGIC(sv); +} + +void sv_setuv(register SV *sv, UV u) { if (u <= IV_MAX) @@ -1139,6 +1164,13 @@ sv_setuv(register SV *sv, UV u) } void +sv_setuv_mg(register SV *sv, UV u) +{ + sv_setuv(sv,u); + SvSETMAGIC(sv); +} + +void sv_setnv(register SV *sv, double num) { sv_check_thinkfirst(sv); @@ -1182,6 +1214,13 @@ sv_setnv(register SV *sv, double num) SvTAINT(sv); } +void +sv_setnv_mg(register SV *sv, double num) +{ + sv_setnv(sv,num); + SvSETMAGIC(sv); +} + STATIC void not_a_number(SV *sv) { @@ -1654,7 +1693,7 @@ sv_2pv(register SV *sv, STRLEN *lp) case SVt_PVHV: s = "HASH"; break; case SVt_PVCV: s = "CODE"; break; case SVt_PVGV: s = "GLOB"; break; - case SVt_PVFM: s = "FORMATLINE"; break; + case SVt_PVFM: s = "FORMLINE"; break; case SVt_PVIO: s = "IO"; break; default: s = "UNKNOWN"; break; } @@ -1926,7 +1965,7 @@ sv_setsv(SV *dstr, register SV *sstr) STRLEN len = GvNAMELEN(sstr); sv_upgrade(dstr, SVt_PVGV); sv_magic(dstr, dstr, '*', name, len); - GvSTASH(dstr) = GvSTASH(sstr); + GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr)); GvNAME(dstr) = savepvn(name, len); GvNAMELEN(dstr) = len; SvFAKE_on(dstr); /* can coerce to non-glob */ @@ -2161,6 +2200,13 @@ sv_setsv(SV *dstr, register SV *sstr) } void +sv_setsv_mg(SV *dstr, register SV *sstr) +{ + sv_setsv(dstr,sstr); + SvSETMAGIC(dstr); +} + +void sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len) { assert(len >= 0); /* STRLEN is probably unsigned, so this may @@ -2185,6 +2231,13 @@ sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len) } void +sv_setpvn_mg(register SV *sv, register const char *ptr, register STRLEN len) +{ + sv_setpvn(sv,ptr,len); + SvSETMAGIC(sv); +} + +void sv_setpv(register SV *sv, register const char *ptr) { register STRLEN len; @@ -2209,6 +2262,13 @@ sv_setpv(register SV *sv, register const char *ptr) } void +sv_setpv_mg(register SV *sv, register const char *ptr) +{ + sv_setpv(sv,ptr); + SvSETMAGIC(sv); +} + +void sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) { sv_check_thinkfirst(sv); @@ -2229,6 +2289,13 @@ sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) SvTAINT(sv); } +void +sv_usepvn_mg(register SV *sv, register char *ptr, register STRLEN len) +{ + sv_usepvn_mg(sv,ptr,len); + SvSETMAGIC(sv); +} + STATIC void sv_check_thinkfirst(register SV *sv) { @@ -2286,6 +2353,13 @@ sv_catpvn(register SV *sv, register char *ptr, register STRLEN len) } void +sv_catpvn_mg(register SV *sv, register char *ptr, register STRLEN len) +{ + sv_catpvn(sv,ptr,len); + SvSETMAGIC(sv); +} + +void sv_catsv(SV *dstr, register SV *sstr) { char *s; @@ -2297,6 +2371,13 @@ sv_catsv(SV *dstr, register SV *sstr) } void +sv_catsv_mg(SV *dstr, register SV *sstr) +{ + sv_catsv(dstr,sstr); + SvSETMAGIC(dstr); +} + +void sv_catpv(register SV *sv, register char *ptr) { register STRLEN len; @@ -2316,14 +2397,19 @@ sv_catpv(register SV *sv, register char *ptr) SvTAINT(sv); } +void +sv_catpv_mg(register SV *sv, register char *ptr) +{ + sv_catpv_mg(sv,ptr); + SvSETMAGIC(sv); +} + SV * #ifdef LEAKTEST -newSV(x,len) -I32 x; +newSV(I32 x, STRLEN len) #else newSV(STRLEN len) #endif - { register SV *sv; @@ -2640,37 +2726,37 @@ sv_clear(register SV *sv) if (defstash) { /* Still have a symbol table? */ djSP; GV* destructor; + HV* stash; + SV tmpref; - ENTER; - SAVEFREESV(SvSTASH(sv)); - - destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); - if (destructor) { - SV tmpRef; - - Zero(&tmpRef, 1, SV); - sv_upgrade(&tmpRef, SVt_RV); - SvRV(&tmpRef) = SvREFCNT_inc(sv); - SvROK_on(&tmpRef); - SvREFCNT(&tmpRef) = 1; /* Fake, but otherwise - creating+destructing a ref - leads to disaster. */ - - EXTEND(SP, 2); - PUSHMARK(SP); - PUSHs(&tmpRef); - PUTBACK; - perl_call_sv((SV*)GvCV(destructor), - G_DISCARD|G_EVAL|G_KEEPERR); - del_XRV(SvANY(&tmpRef)); - SvREFCNT(sv)--; - } + Zero(&tmpref, 1, SV); + sv_upgrade(&tmpref, SVt_RV); + SvROK_on(&tmpref); + SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */ + SvREFCNT(&tmpref) = 1; - LEAVE; + do { + stash = SvSTASH(sv); + destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); + if (destructor) { + ENTER; + SvRV(&tmpref) = SvREFCNT_inc(sv); + EXTEND(SP, 2); + PUSHMARK(SP); + PUSHs(&tmpref); + PUTBACK; + perl_call_sv((SV*)GvCV(destructor), + G_DISCARD|G_EVAL|G_KEEPERR); + SvREFCNT(sv)--; + LEAVE; + } + } while (SvOBJECT(sv) && SvSTASH(sv) != stash); + + del_XRV(SvANY(&tmpref)); } - else - SvREFCNT_dec(SvSTASH(sv)); + if (SvOBJECT(sv)) { + SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */ SvOBJECT_off(sv); /* Curse the object. */ if (SvTYPE(sv) != SVt_PVIO) --sv_objcount; /* XXX Might want something more general */ @@ -2709,6 +2795,7 @@ sv_clear(register SV *sv) case SVt_PVGV: gp_free((GV*)sv); Safefree(GvNAME(sv)); + SvREFCNT_dec(GvSTASH(sv)); /* FALL THROUGH */ case SVt_PVLV: case SVt_PVMG: @@ -3440,6 +3527,21 @@ newSVpv(char *s, STRLEN len) return sv; } +SV * +newSVpvn(s,len) +char *s; +STRLEN len; +{ + register SV *sv; + + new_SV(sv); + SvANY(sv) = 0; + SvREFCNT(sv) = 1; + SvFLAGS(sv) = 0; + sv_setpvn(sv,s,len); + return sv; +} + #ifdef I_STDARG SV * newSVpvf(const char* pat, ...) @@ -3562,6 +3664,9 @@ sv_reset(register char *s, HV *stash) register I32 max; char todo[256]; + if (!stash) + return; + if (!*s) { /* reset ?? searches */ for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) { pm->op_pmflags &= ~PMf_USED; @@ -4064,6 +4169,14 @@ sv_setpviv(SV *sv, IV iv) SvCUR(sv) = p - SvPVX(sv); } + +void +sv_setpviv_mg(SV *sv, IV iv) +{ + sv_setpviv(sv,iv); + SvSETMAGIC(sv); +} + #ifdef I_STDARG void sv_setpvf(SV *sv, const char* pat, ...) @@ -4086,6 +4199,30 @@ sv_setpvf(sv, pat, va_alist) va_end(args); } + +#ifdef I_STDARG +void +sv_setpvf_mg(SV *sv, const char* pat, ...) +#else +/*VARARGS0*/ +void +sv_setpvf_mg(sv, pat, va_alist) + SV *sv; + const char *pat; + va_dcl +#endif +{ + va_list args; +#ifdef I_STDARG + va_start(args, pat); +#else + va_start(args); +#endif + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + va_end(args); + SvSETMAGIC(sv); +} + #ifdef I_STDARG void sv_catpvf(SV *sv, const char* pat, ...) @@ -4108,6 +4245,29 @@ sv_catpvf(sv, pat, va_alist) va_end(args); } +#ifdef I_STDARG +void +sv_catpvf_mg(SV *sv, const char* pat, ...) +#else +/*VARARGS0*/ +void +sv_catpvf_mg(sv, pat, va_alist) + SV *sv; + const char *pat; + va_dcl +#endif +{ + va_list args; +#ifdef I_STDARG + va_start(args, pat); +#else + va_start(args); +#endif + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + va_end(args); + SvSETMAGIC(sv); +} + void sv_vsetpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale) { @@ -611,7 +611,7 @@ struct xpvio { # endif #endif /* __GNUC__ */ -/* the following macros updates any magic values this sv is associated with */ +/* the following macros update any magic values this sv is associated with */ #define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #define SvSETMAGIC(x) STMT_START { if (SvSMAGICAL(x)) mg_set(x); } STMT_END @@ -644,27 +644,6 @@ struct xpvio { #define SvSetMagicSV_nosteal(dst,src) \ SvSetSV_nosteal_and(dst,src,SvSETMAGIC(dst)) -#define SvSetMagicPV(dst,s) \ - STMT_START { sv_setpv(dst,s); SvSETMAGIC(dst); } STMT_END -#define SvSetMagicPVN(dst,s,l) \ - STMT_START { sv_setpvn(dst,s,l); SvSETMAGIC(dst); } STMT_END -#define SvSetMagicIV(dst,i) \ - STMT_START { sv_setiv(dst,i); SvSETMAGIC(dst); } STMT_END -#define SvSetMagicPVIV(dst,i) \ - STMT_START { sv_setpviv(dst,i); SvSETMAGIC(dst); } STMT_END -#define SvSetMagicUV(dst,u) \ - STMT_START { sv_setuv(dst,u); SvSETMAGIC(dst); } STMT_END -#define SvSetMagicNV(dst,n) \ - STMT_START { sv_setnv(dst,n); SvSETMAGIC(dst); } STMT_END -#define SvCatMagicPV(dst,s) \ - STMT_START { sv_catpv(dst,s); SvSETMAGIC(dst); } STMT_END -#define SvCatMagicPVN(dst,s,l) \ - STMT_START { sv_catpvn(dst,s,l); SvSETMAGIC(dst); } STMT_END -#define SvCatMagicSV(dst,src) \ - STMT_START { sv_catsv(dst,src); SvSETMAGIC(dst); } STMT_END -#define SvUseMagicPVN(dst,s,l) \ - STMT_START { sv_usepvn(dst,s,l); SvSETMAGIC(dst); } STMT_END - #define SvPEEK(sv) sv_peek(sv) #define SvIMMORTAL(sv) ((sv)==&sv_undef || (sv)==&sv_yes || (sv)==&sv_no) diff --git a/t/comp/proto.t b/t/comp/proto.t index d1cfede8af..2a4c9ccce5 100755 --- a/t/comp/proto.t +++ b/t/comp/proto.t @@ -16,7 +16,7 @@ BEGIN { use strict; -print "1..76\n"; +print "1..80\n"; my $i = 1; @@ -362,20 +362,35 @@ printf "ok %d\n",$i++; ## ## -testing \&an_array_ref, '\@'; +testing \&array_ref_plus, '\@@'; -sub an_array_ref (\@) { +sub array_ref_plus (\@@) { print "# \@_ = (",join(",",@_),")\n"; - print "not " unless ref($_[0]) && 1 == @{$_[0]}; + print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x'; printf "ok %d\n",$i++; @{$_[0]} = (qw(ok)," ",$i++,"\n"); } @array = ('a'); -an_array_ref @array; +{ my @more = ('x'); + array_ref_plus @array, @more; } print "not " unless @array == 4; print @array; +my $p; +print "not " if defined prototype('CORE::print'); +print "ok ", $i++, "\n"; + +print "not " if defined prototype('CORE::system'); +print "ok ", $i++, "\n"; + +print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$'; +print "ok ", $i++, "\n"; + +print "# CORE:Foo => ($p), \$@ => `$@'\nnot " + if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Cannot find an opnumber/; +print "ok ", $i++, "\n"; + # correctly note too-short parameter lists that don't end with '$', # a possible regression. diff --git a/t/lib/complex.t b/t/lib/complex.t index 3390334d34..2783e42f66 100755 --- a/t/lib/complex.t +++ b/t/lib/complex.t @@ -3,13 +3,9 @@ # $RCSfile: complex.t,v $ # # Regression tests for the Math::Complex pacakge -# -- Raphael Manfredi September 1996 -# -- Jarkko Hietaniemi March-October 1997 -# -- Daniel S. Lewart September-October 1997 - -$VERSION = '1.05'; - -# $Id: complex.t,v 1.1 1997/10/15 10:02:15 jhi Exp jhi $ +# -- Raphael Manfredi since Sep 1996 +# -- Jarkko Hietaniemi since Mar 1997 +# -- Daniel S. Lewart since Sep 1997 BEGIN { chdir 't' if -d 't'; @@ -18,6 +14,8 @@ BEGIN { use Math::Complex; +$VERSION = sprintf("%s", q$Id: complex.t,v 1.8 1998/02/05 16:03:39 jhi Exp $ =~ /(\d+\.d+)/); + my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val); $test = 0; @@ -26,7 +24,7 @@ my @script = ( 'my ($res, $s0,$s1,$s2,$s3,$s4,$s5,$s6,$s7,$s8,$s9,$s10, $z0,$z1,$z2);' . "\n\n" ); -my $eps = 1e-11; +my $eps = 1e-13; while (<DATA>) { s/^\s+//; @@ -59,16 +57,70 @@ while (<DATA>) { } } +# + +sub test_mutators { + my $op; + + $test++; +push(@script, <<'EOT'); +{ + my $z = cplx( 1, 1); + $z->Re(2); + $z->Im(3); + print 'not ' unless Re($z) == 2 and Im($z) == 3; +EOT + push(@script, qq(print "ok $test\\n"}\n)); + + $test++; +push(@script, <<'EOT'); +{ + my $z = cplx( 1, 1); + $z->abs(3 * sqrt(2)); + print 'not ' unless (abs($z) - 3 * sqrt(2)) < $eps and + (arg($z) - pi / 4 ) < $eps and + (Re($z) - 3 ) < $eps and + (Im($z) - 3 ) < $eps; +EOT + push(@script, qq(print "ok $test\\n"}\n)); + + $test++; +push(@script, <<'EOT'); +{ + my $z = cplx( 1, 1); + $z->arg(-3 / 4 * pi); + print 'not ' unless (arg($z) + 3 / 4 * pi) < $eps and + (abs($z) - sqrt(2) ) < $eps and + (Re($z) + 1 ) < $eps and + (Im($z) + 1 ) < $eps; +EOT + push(@script, qq(print "ok $test\\n"}\n)); +} + +test_mutators(); + +my $constants = ' +my $i = cplx(0, 1); +my $pi = cplx(pi, 0); +my $pii = cplx(0, pi); +my $pip2 = cplx(pi/2, 0); +my $zero = cplx(0, 0); +'; + +push(@script, $constants); + + # test the divbyzeros sub test_dbz { for my $op (@_) { $test++; -# push(@script, qq(print "# '$op'\n";)); - push(@script, qq(eval '$op';)); - push(@script, qq(print 'not ' unless (\$@ =~ /Division by zero/);)); - push(@script, qq( print "ok $test\\n";\n)); + push(@script, <<EOT); +eval '$op'; +print 'not ' unless (\$@ =~ /Division by zero/); +EOT + push(@script, qq(print "ok $test\\n";\n)); } } @@ -78,41 +130,40 @@ sub test_loz { for my $op (@_) { $test++; -# push(@script, qq(print "# '$op'\n";)); - push(@script, qq(eval '$op';)); - push(@script, qq(print 'not ' unless (\$@ =~ /Logarithm of zero/);)); - push(@script, qq( print "ok $test\\n";\n)); + push(@script, <<EOT); +eval '$op'; +print 'not ' unless (\$@ =~ /Logarithm of zero/); +EOT + push(@script, qq(print "ok $test\\n";\n)); } } -my $minusi = cplx(0, -1); - test_dbz( 'i/0', -# 'tan(pi/2)', # may succeed thanks to floating point inaccuracies -# 'sec(pi/2)', # may succeed thanks to floating point inaccuracies - 'csc(0)', - 'cot(0)', - 'atan(i)', - 'atan($minusi)', - 'asec(0)', + 'acot(0)', + 'acot(+$i)', +# 'acoth(-1)', # Log of zero. + 'acoth(0)', + 'acoth(+1)', 'acsc(0)', - 'acot(i)', - 'acot($minusi)', -# 'tanh(pi/2)', # may succeed thanks to floating point inaccuracies -# 'sech(pi/2)', # may succeed thanks to floating point inaccuracies - 'csch(0)', - 'coth(0)', - 'atanh(1)', - 'asech(0)', 'acsch(0)', - 'acoth(1)', + 'asec(0)', + 'asech(0)', + 'atan(-$i)', + 'atan($i)', +# 'atanh(-1)', # Log of zero. + 'atanh(+1)', + 'cot(0)', + 'coth(0)', + 'csc(0)', + 'tan($pip2)', + 'csch(0)', + 'tan($pip2)', ); -my $zero = cplx(0, 0); - test_loz( 'log($zero)', + 'acot(-$i)', 'atanh(-1)', 'acoth(-1)', ); @@ -120,12 +171,13 @@ test_loz( # test the 0**0 sub test_ztz { - $test++; + $test++; -# push(@script, qq(print "# 0**0\n";)); - push(@script, qq(eval 'cplx(0)**cplx(0)';)); - push(@script, qq(print 'not ' unless (\$@ =~ /zero raised to the/);)); - push(@script, qq( print "ok $test\\n";\n)); + push(@script, <<'EOT'); +eval 'cplx(0)**cplx(0)'; +print 'not ' unless ($@ =~ /zero raised to the zeroth/); +EOT + push(@script, qq(print "ok $test\\n";\n)); } test_ztz; @@ -136,10 +188,11 @@ sub test_broot { for my $op (@_) { $test++; -# push(@script, qq(print "# root(2, $op)\n";)); - push(@script, qq(eval 'root(2, $op)';)); - push(@script, qq(print 'not ' unless (\$@ =~ /root must be/);)); - push(@script, qq( print "ok $test\\n";\n)); + push(@script, <<EOT); +eval 'root(2, $op)'; +print 'not ' unless (\$@ =~ /root must be/); +EOT + push(@script, qq(print "ok $test\\n";\n)); } } @@ -200,7 +253,7 @@ EOB $test++; # check that the rhs has not changed push @script, qq(print "not " unless (\$zbr == \$z1r and \$zbi == \$z1i);); - push @script, qq( print "ok $test\\n";\n); + push @script, qq(print "ok $test\\n";\n); push @script, "}\n"; } } @@ -226,6 +279,9 @@ sub value { if (/^\s*\((.*),(.*)\)/) { return "cplx($1,$2)"; } + elsif (/^\s*([\-\+]?(?:\d+(\.\d+)?|\.\d+)(?:[e[\-\+]\d+])?)/) { + return "cplx($1,0)"; + } elsif (/^\s*\[(.*),(.*)\]/) { return "cplxe($1,$2)"; } diff --git a/t/lib/ph.t b/t/lib/ph.t new file mode 100755 index 0000000000..d0a48f6c51 --- /dev/null +++ b/t/lib/ph.t @@ -0,0 +1,98 @@ +#!./perl + +# Check for presence and correctness of .ph files; for now, +# just socket.ph and pals. +# -- Kurt Starsinic <kstar@isinet.com> + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Config; + +# All the constants which Socket.pm tries to make available: +my @possibly_defined = qw( + INADDR_ANY INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK AF_CCITT + AF_CHAOS AF_DATAKIT AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK + AF_INET AF_LAT AF_MAX AF_NBS AF_NIT AF_NS AF_OSI AF_OSINET AF_PUP + AF_SNA AF_UNIX AF_UNSPEC AF_X25 MSG_DONTROUTE MSG_MAXIOVLEN MSG_OOB + MSG_PEEK PF_802 PF_APPLETALK PF_CCITT PF_CHAOS PF_DATAKIT PF_DECnet PF_DLI + PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_LAT PF_MAX PF_NBS PF_NIT + PF_NS PF_OSI PF_OSINET PF_PUP PF_SNA PF_UNIX PF_UNSPEC PF_X25 SOCK_DGRAM + SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM SOL_SOCKET SOMAXCONN + SO_ACCEPTCONN SO_BROADCAST SO_DEBUG SO_DONTLINGER SO_DONTROUTE SO_ERROR + SO_KEEPALIVE SO_LINGER SO_OOBINLINE SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO + SO_REUSEADDR SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO SO_TYPE SO_USELOOPBACK +); + + +# The libraries which I'm going to require: +my @libs = qw(Socket "sys/types.ph" "sys/socket.ph" "netinet/in.ph"); + + +# These are defined by Socket.pm even if the C header files don't define them: +my %ok_to_miss = ( + INADDR_NONE => 1, + INADDR_LOOPBACK => 1, +); + + +my $total_tests = scalar @libs + scalar @possibly_defined; +my $i = 0; + +print "1..$total_tests\n"; + + +foreach (@libs) { + $i++; + + if (eval "require $_" ) { + print "ok $i\n"; + } else { + print "# Skipping tests; $_ may be missing\n"; + foreach ($i .. $total_tests) { print "ok $_\n" } + exit; + } +} + + +foreach (@possibly_defined) { + $i++; + + $pm_val = eval "Socket::$_()"; + $ph_val = eval "main::$_()"; + + if (defined $pm_val and !defined $ph_val) { + if ($ok_to_miss{$_}) { print "ok $i\n" } + else { print "not ok $i\n" } + next; + } elsif (defined $ph_val and !defined $pm_val) { + print "not ok $i\n"; + next; + } + + # Socket.pm converts these to network byte order, so we convert the + # socket.ph version to match; note that these cases skip the following + # `elsif', which is only applied to _numeric_ values, not literal + # bitmasks. + if ($_ eq 'INADDR_ANY' + or $_ eq 'INADDR_LOOPBACK' + or $_ eq 'INADDR_NONE') { + $ph_val = pack("N*", $ph_val); # htonl(3) equivalent + } + + # Since Socket.pm and socket.ph wave their hands over macros differently, + # they could return functionally equivalent bitmaps with different numeric + # interpretations (due to sign extension). The only apparent case of this + # is SO_DONTLINGER (only on Solaris, and deprecated, at that): + elsif ($pm_val != $ph_val) { + $pm_val = oct(sprintf "0x%lx", $pm_val); + $ph_val = oct(sprintf "0x%lx", $ph_val); + } + + if ($pm_val == $ph_val) { print "ok $i\n" } + else { print "not ok $i\n" } +} + + diff --git a/t/lib/posix.t b/t/lib/posix.t index 6ae88c0dd2..d63e695f02 100755 --- a/t/lib/posix.t +++ b/t/lib/posix.t @@ -10,11 +10,11 @@ BEGIN { } } -use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read write); +use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write); use strict subs; $| = 1; -print "1..17\n"; +print "1..18\n"; $testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n"; read($testfd, $buffer, 9) if $testfd > 2; @@ -80,6 +80,12 @@ if ($Config{d_strtoul}) { # Pick up whether we're really able to dynamically load everything. print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n"; +# This can coredump if struct tm has a timezone field and we +# didn't detect it. If this fails, try adding +# -DSTRUCT_TM_HASZONE to your cflags when compiling ext/POSIX/POSIX.c. +# See ext/POSIX/hints/sunos_4.pl and ext/POSIX/hints/linux.pl +print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime()); + $| = 0; print '@#!*$@(!@#$'; _exit(0); @@ -4,7 +4,7 @@ # various typeglob tests # -print "1..11\n"; +print "1..13\n"; # type coersion on assignment $foo = 'foo'; @@ -57,3 +57,11 @@ if (defined $baa) { print ref(\$baa) eq 'GLOB' ? "ok 11\n" : "not ok 11\n"; } +# nested package globs +# NOTE: It's probably OK if these semantics change, because the +# fact that %X::Y:: is stored in %X:: isn't documented. +# (I hope.) + +{ package Foo::Bar } +print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n"; +print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n"; diff --git a/t/op/local.t b/t/op/local.t index f527c9c9a9..3e30306218 100755 --- a/t/op/local.t +++ b/t/op/local.t @@ -2,7 +2,7 @@ # $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $ -print "1..23\n"; +print "1..24\n"; sub foo { local($a, $b) = @_; @@ -52,3 +52,9 @@ print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 22\n"; eval 'local(%$e)'; print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 23\n"; + +# check for scope leakage +$a = 'outer'; +if (1) { local $a = 'inner' } +print +($a eq 'outer') ? "" : "not ", "ok 24\n"; + diff --git a/t/op/misc.t b/t/op/misc.t index 326273aff1..7a7fc334d3 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -338,6 +338,7 @@ print "you die joe!\n" unless "@x" eq 'x y z'; ######## /(?{"{"})/ # Check it outside of eval too EXPECT +Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern /(?{"{"})/: Sequence (?{...}) not terminated or not {}-balanced at - line 1. ######## /(?{"{"}})/ # Check it outside of eval too @@ -2,7 +2,7 @@ # $RCSfile: my.t,v $ -print "1..28\n"; +print "1..30\n"; sub foo { my($a, $b) = @_; @@ -83,3 +83,11 @@ foreach my $i (26, 27) { print "not " if $i ne "outer"; print "ok 28\n"; + +# Ensure that C<my @y> (without parens) doesn't force scalar context. +my @x; +{ @x = my @y } +print +(@x ? "not " : ""), "ok 29\n"; +{ @x = my %y } +print +(@x ? "not " : ""), "ok 30\n"; + diff --git a/t/op/pat.t b/t/op/pat.t index a9e6869a4a..5d8bf8ad78 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -2,7 +2,7 @@ # $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:12 $ -print "1..100\n"; +print "1..101\n"; $x = "abc\ndef\n"; @@ -274,7 +274,7 @@ $_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e"; $expect = "(bla()) ((l)u((e))) (l(e)e)"; sub matchit { - m' + m/ ( \( (?{ $c = 1 }) # Initialize @@ -301,7 +301,7 @@ sub matchit { (?! ) # Fail ) # Otherwise the chunk 1 may succeed with $c>0 - 'xg; + /xg; } push @ans, $res while $res = matchit; @@ -321,9 +321,15 @@ print "not " if "@ans" ne 'a/ b'; print "ok $test\n"; $test++; -$code = '$blah = 45'; +$code = '{$blah = 45}'; $blah = 12; -/(?{$code})/; +/(?$code)/; +print "not " if $blah != 45; +print "ok $test\n"; +$test++; + +$blah = 12; +/(?{$blah = 45})/; print "not " if $blah != 45; print "ok $test\n"; $test++; diff --git a/t/op/ref.t b/t/op/ref.t index 56925177d1..1d70f9fd4c 100755 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -1,6 +1,6 @@ #!./perl -print "1..52\n"; +print "1..55\n"; # Test glob operations. @@ -235,12 +235,50 @@ $var = "ok 49"; $_ = \$var; print $$_,"\n"; +# test if reblessing during destruction results in more destruction + +{ + package A; + sub new { bless {}, shift } + DESTROY { print "# destroying 'A'\nok 51\n" } + package B; + sub new { bless {}, shift } + DESTROY { print "# destroying 'B'\nok 50\n"; bless shift, 'A' } + package main; + my $b = B->new; +} + +# test if $_[0] is properly protected in DESTROY() + +{ + my $i = 0; + local $SIG{'__DIE__'} = sub { + my $m = shift; + if ($i++ > 4) { + print "# infinite recursion, bailing\nnot ok 52\n"; + exit 1; + } + print "# $m"; + if ($m =~ /^Modification of a read-only/) { print "ok 52\n" } + }; + package C; + sub new { bless {}, shift } + DESTROY { $_[0] = 'foo' } + { + print "# should generate an error...\n"; + my $c = C->new; + } + print "# good, didn't recurse\n"; +} + +# test global destruction + package FINALE; { - $ref3 = bless ["ok 52\n"]; # package destruction - my $ref2 = bless ["ok 51\n"]; # lexical destruction - local $ref1 = bless ["ok 50\n"]; # dynamic destruction + $ref3 = bless ["ok 55\n"]; # package destruction + my $ref2 = bless ["ok 54\n"]; # lexical destruction + local $ref1 = bless ["ok 53\n"]; # dynamic destruction 1; # flush any temp values on stack } diff --git a/t/op/vec.t b/t/op/vec.t index 97b6d60989..71171447d6 100755 --- a/t/op/vec.t +++ b/t/op/vec.t @@ -2,7 +2,7 @@ # $RCSfile: vec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:36 $ -print "1..13\n"; +print "1..15\n"; print vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n"; print length($foo) == 0 ? "ok 2\n" : "not ok 2\n"; @@ -21,4 +21,7 @@ print vec($foo,1,8) == 0xf1 ? "ok 10\n" : "not ok 10\n"; print ((ord(substr($foo,1,1)) & 255) == 0xf1 ? "ok 11\n" : "not ok 11\n"); print vec($foo,2,4) == 1 ? "ok 12\n" : "not ok 12\n"; print vec($foo,3,4) == 15 ? "ok 13\n" : "not ok 13\n"; +vec($Vec, 0, 32) = 0xbaddacab; +print $Vec eq "\xba\xdd\xac\xab" ? "ok 14\n" : "not ok 14\n"; +print vec($Vec, 0, 32) == 3135089835 ? "ok 15\n" : "not ok 15\n"; @@ -87,6 +87,7 @@ PERLVAR(cvcache, HV *) PERLVAR(self, perl_os_thread) /* Underlying thread object */ PERLVAR(flags, U32) PERLVAR(threadsv, AV *) /* Per-thread SVs ($_, $@ etc.) */ +PERLVAR(threadsvp, SV **) /* AvARRAY(threadsv) */ PERLVAR(specific, AV *) /* Thread-specific user data */ PERLVAR(errsv, SV *) /* Backing SV for $@ */ PERLVAR(errhv, HV *) /* HV for what was %@ in pp_ctl.c */ @@ -20,10 +20,19 @@ #else # define pthread_mutexattr_default NULL # define pthread_condattr_default NULL -# define pthread_attr_default NULL #endif /* OLD_PTHREADS_API */ #endif +#ifdef PTHREADS_CREATED_JOINABLE +# define ATTR_JOINABLE PTHREAD_CREATE_JOINABLE +#else +# ifdef PTHREAD_CREATE_UNDETACHED +# define ATTR_JOINABLE PTHREAD_CREATE_UNDETACHED +# else +# define ATTR_JOINABLE PTHREAD_CREATE_JOINABLE +# endif +#endif + #ifndef YIELD # ifdef HAS_PTHREAD_YIELD # define YIELD pthread_yield() @@ -119,8 +128,16 @@ struct perl_thread *getTHR _((void)); # endif /* OLD_PTHREADS_API */ #endif /* THR */ +/* + * dTHR is performance-critical. Here, we only do the pthread_get_specific + * if there may be more than one thread in existence, otherwise we get thr + * from thrsv which is cached in the per-interpreter structure. + * Systems with very fast pthread_get_specific (which should be all systems + * but unfortunately isn't) may wish to simplify to "...*thr = THR". + */ #ifndef dTHR -# define dTHR struct perl_thread *thr = THR +# define dTHR \ + struct perl_thread *thr = threadnum? THR : (struct perl_thread*)SvPVX(thrsv) #endif /* dTHR */ #ifndef INIT_THREADS @@ -131,6 +148,26 @@ struct perl_thread *getTHR _((void)); # endif #endif +/* Accessor for per-thread SVs */ +#define THREADSV(i) (thr->threadsvp[i]) + +/* + * LOCK_SV_MUTEX and UNLOCK_SV_MUTEX are performance-critical. Here, we + * try only locking them if there may be more than one thread in existence. + * Systems with very fast mutexes (and/or slow conditionals) may wish to + * remove the "if (threadnum) ..." test. + */ +#define LOCK_SV_MUTEX \ + STMT_START { \ + if (threadnum) \ + MUTEX_LOCK(&sv_mutex); \ + } STMT_END + +#define UNLOCK_SV_MUTEX \ + STMT_START { \ + if (threadnum) \ + MUTEX_UNLOCK(&sv_mutex); \ + } STMT_END #ifndef THREAD_RET_TYPE # define THREAD_RET_TYPE void * @@ -180,6 +217,8 @@ typedef struct condpair { #define COND_BROADCAST(c) #define COND_WAIT(c, m) #define COND_DESTROY(c) +#define LOCK_SV_MUTEX +#define UNLOCK_SV_MUTEX #define THR /* Rats: if dTHR is just blank then the subsequent ";" throws an error */ @@ -50,6 +50,8 @@ static int uni _((I32 f, char *s)); #endif static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append)); static void restore_rsfp _((void *f)); +static void restore_expect _((void *e)); +static void restore_lex_expect _((void *e)); #endif /* PERL_OBJECT */ static char ident_too_long[] = "Identifier too long"; @@ -259,6 +261,11 @@ lex_start(SV *line) SAVEPPTR(lex_brackstack); SAVEPPTR(lex_casestack); SAVEDESTRUCTOR(restore_rsfp, rsfp); + SAVESPTR(lex_stuff); + SAVEI32(lex_defer); + SAVESPTR(lex_repl); + SAVEDESTRUCTOR(restore_expect, tokenbuf + expect); /* encode as pointer */ + SAVEDESTRUCTOR(restore_lex_expect, tokenbuf + expect); lex_state = LEX_NORMAL; lex_defer = 0; @@ -273,11 +280,7 @@ lex_start(SV *line) *lex_casestack = '\0'; lex_dojoin = 0; lex_starts = 0; - if (lex_stuff) - SvREFCNT_dec(lex_stuff); lex_stuff = Nullsv; - if (lex_repl) - SvREFCNT_dec(lex_repl); lex_repl = Nullsv; lex_inpat = 0; lex_inwhat = 0; @@ -317,6 +320,22 @@ restore_rsfp(void *f) } STATIC void +restore_expect(e) +void *e; +{ + /* a safe way to store a small integer in a pointer */ + expect = (expectation)((char *)e - tokenbuf); +} + +STATIC void +restore_lex_expect(e) +void *e; +{ + /* a safe way to store a small integer in a pointer */ + lex_expect = (expectation)((char *)e - tokenbuf); +} + +STATIC void incline(char *s) { dTHR; @@ -785,9 +804,31 @@ scan_const(char *start) s++; } } - else if (*s == '(' && lex_inpat && s[1] == '?' && s[2] == '#') { - while (s < send && *s != ')') - *d++ = *s++; + else if (*s == '(' && lex_inpat && s[1] == '?') { + if (s[2] == '#') { + while (s < send && *s != ')') + *d++ = *s++; + } else if (s[2] == '{') { /* This should march regcomp.c */ + I32 count = 1; + char *regparse = s + 3; + char c; + + while (count && (c = *regparse)) { + if (c == '\\' && regparse[1]) + regparse++; + else if (c == '{') + count++; + else if (c == '}') + count--; + regparse++; + } + if (*regparse == ')') + regparse++; + else + yyerror("Sequence (?{...}) not terminated or not {}-balanced"); + while (s < regparse && *s != ')') + *d++ = *s++; + } } else if (*s == '#' && lex_inpat && ((PMOP*)lex_inpat)->op_pmflags & PMf_EXTENDED) { @@ -1025,9 +1066,18 @@ intuit_method(char *start, GV *gv) GV* indirgv; if (gv) { + CV *cv; if (GvIO(gv)) return 0; - if (!GvCVu(gv)) + if ((cv = GvCVu(gv))) { + char *proto = SvPVX(cv); + if (proto) { + if (*proto == ';') + proto++; + if (*proto == '*') + return 0; + } + } else gv = 0; } s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); @@ -1104,7 +1154,7 @@ filter_add(filter_t funcp, SV *datasv) if (!rsfp_filters) rsfp_filters = newAV(); if (!datasv) - datasv = newSV(0); + datasv = NEWSV(255,0); if (!SvUPGRADE(datasv, SVt_PVIO)) die("Can't upgrade filter_add data to SVt_PVIO"); IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */ @@ -2016,8 +2066,13 @@ yylex(void) else lex_brackstack[lex_brackets++] = XOPERATOR; s = skipspace(s); - if (*s == '}') + if (*s == '}') { + if (expect == XSTATE) { + lex_brackstack[lex_brackets-1] = XSTATE; + break; + } OPERATOR(HASHBRACK); + } /* This hack serves to disambiguate a pair of curlies * as being a block or an anon hash. Normally, expectation * determines that, but in cases where we're not in a @@ -4838,6 +4893,8 @@ scan_heredoc(register char *s) } sv_setpvn(tmpstr,d+1,s-d); s += len - 1; + curcop->cop_line++; /* the preceding stmt passes a newline */ + sv_catpvn(herewas,s,bufend-s); sv_setsv(linestr,herewas); oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr); @@ -54,12 +54,14 @@ #define FLUSH #ifdef LEAKTEST -static void xstat _((void)); -#endif -#ifdef USE_THREADS -static U32 threadnum = 0; -#endif /* USE_THREADS */ +static void xstat _((int)); +long xcount[MAXXCOUNT]; +long lastxcount[MAXXCOUNT]; +long xycount[MAXXCOUNT][MAXYCOUNT]; +long lastxycount[MAXXCOUNT][MAXYCOUNT]; + +#endif #ifndef MYMALLOC @@ -211,63 +213,141 @@ safecalloc(MEM_SIZE count, MEM_SIZE size) #ifdef LEAKTEST -#define ALIGN sizeof(long) +struct mem_test_strut { + union { + long type; + char c[2]; + } u; + long size; +}; + +# define ALIGN sizeof(struct mem_test_strut) + +# define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size) +# define typeof_chunk(ch) \ + (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100) +# define set_typeof_chunk(ch,t) \ + (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100) +#define SIZE_TO_Y(size) ( (size) > MAXY_SIZE \ + ? MAXYCOUNT - 1 \ + : ( (size) > 40 \ + ? ((size) - 1)/8 + 5 \ + : ((size) - 1)/4)) Malloc_t safexmalloc(I32 x, MEM_SIZE size) { - register Malloc_t where; + register char* where = (char*)safemalloc(size + ALIGN); - where = safemalloc(size + ALIGN); - xcount[x]++; - where[0] = x % 100; - where[1] = x / 100; - return where + ALIGN; + xcount[x] += size; + xycount[x][SIZE_TO_Y(size)]++; + set_typeof_chunk(where, x); + sizeof_chunk(where) = size; + return (Malloc_t)(where + ALIGN); } Malloc_t -safexrealloc(Malloc_t where, MEM_SIZE size) +safexrealloc(Malloc_t wh, MEM_SIZE size) { - register Malloc_t new = saferealloc(where - ALIGN, size + ALIGN); - return new + ALIGN; + char *where = (char*)wh; + + if (!wh) + return safexmalloc(0,size); + + { + MEM_SIZE old = sizeof_chunk(where - ALIGN); + int t = typeof_chunk(where - ALIGN); + register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN); + + xycount[t][SIZE_TO_Y(old)]--; + xycount[t][SIZE_TO_Y(size)]++; + xcount[t] += size - old; + sizeof_chunk(new) = size; + return (Malloc_t)(new + ALIGN); + } } void -safexfree(Malloc_t where) +safexfree(Malloc_t wh) { I32 x; - + char *where = (char*)wh; + MEM_SIZE size; + if (!where) return; where -= ALIGN; + size = sizeof_chunk(where); x = where[0] + 100 * where[1]; - xcount[x]--; + xcount[x] -= size; + xycount[x][SIZE_TO_Y(size)]--; safefree(where); } Malloc_t safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size) { - register Malloc_t where; - - where = safexmalloc(x, size * count + ALIGN); - xcount[x]++; - memset((void*)where + ALIGN, 0, size * count); - where[0] = x % 100; - where[1] = x / 100; - return where + ALIGN; + register char * where = (char*)safexmalloc(x, size * count + ALIGN); + xcount[x] += size; + xycount[x][SIZE_TO_Y(size)]++; + memset((void*)(where + ALIGN), 0, size * count); + set_typeof_chunk(where, x); + sizeof_chunk(where) = size; + return (Malloc_t)(where + ALIGN); } static void -xstat(void) +xstat(int flag) { - register I32 i; + register I32 i, j, total = 0; + I32 subtot[MAXYCOUNT]; + for (j = 0; j < MAXYCOUNT; j++) { + subtot[j] = 0; + } + + PerlIO_printf(PerlIO_stderr(), " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total); for (i = 0; i < MAXXCOUNT; i++) { - if (xcount[i] > lastxcount[i]) { - PerlIO_printf(PerlIO_stderr(),"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]); + total += xcount[i]; + for (j = 0; j < MAXYCOUNT; j++) { + subtot[j] += xycount[i][j]; + } + if (flag == 0 + ? xcount[i] /* Have something */ + : (flag == 2 + ? xcount[i] != lastxcount[i] /* Changed */ + : xcount[i] > lastxcount[i])) { /* Growed */ + PerlIO_printf(PerlIO_stderr(),"%2d %02d %7ld ", i / 100, i % 100, + flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]); lastxcount[i] = xcount[i]; + for (j = 0; j < MAXYCOUNT; j++) { + if ( flag == 0 + ? xycount[i][j] /* Have something */ + : (flag == 2 + ? xycount[i][j] != lastxycount[i][j] /* Changed */ + : xycount[i][j] > lastxycount[i][j])) { /* Growed */ + PerlIO_printf(PerlIO_stderr(),"%3ld ", + flag == 2 + ? xycount[i][j] - lastxycount[i][j] + : xycount[i][j]); + lastxycount[i][j] = xycount[i][j]; + } else { + PerlIO_printf(PerlIO_stderr(), " . ", xycount[i][j]); + } + } + PerlIO_printf(PerlIO_stderr(), "\n"); + } + } + if (flag != 2) { + PerlIO_printf(PerlIO_stderr(), "Total %7ld ", total); + for (j = 0; j < MAXYCOUNT; j++) { + if (subtot[j]) { + PerlIO_printf(PerlIO_stderr(), "%3ld ", subtot[j]); + } else { + PerlIO_printf(PerlIO_stderr(), " . "); + } } + PerlIO_printf(PerlIO_stderr(), "\n"); } } @@ -1366,7 +1446,12 @@ warn(pat,va_alist) } PerlIO_puts(PerlIO_stderr(),message); #ifdef LEAKTEST - DEBUG_L(xstat()); + DEBUG_L(*message == '!' + ? (xstat(message[1]=='!' + ? (message[2]=='!' ? 2 : 1) + : 0) + , 0) + : 0); #endif (void)PerlIO_flush(PerlIO_stderr()); } @@ -2444,11 +2529,11 @@ condpair_magic(SV *sv) COND_INIT(&cp->owner_cond); COND_INIT(&cp->cond); cp->owner = 0; - MUTEX_LOCK(&sv_mutex); + LOCK_SV_MUTEX; mg = mg_find(sv, 'm'); if (mg) { /* someone else beat us to initialising it */ - MUTEX_UNLOCK(&sv_mutex); + UNLOCK_SV_MUTEX; MUTEX_DESTROY(&cp->mutex); COND_DESTROY(&cp->owner_cond); COND_DESTROY(&cp->cond); @@ -2459,7 +2544,7 @@ condpair_magic(SV *sv) mg = SvMAGIC(sv); mg->mg_ptr = (char *)cp; mg->mg_len = sizeof(cp); - MUTEX_UNLOCK(&sv_mutex); + UNLOCK_SV_MUTEX; DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(), "%p: condpair_magic %p\n", thr, sv));) } @@ -2553,6 +2638,7 @@ new_struct_thread(struct perl_thread *t) "new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr)); } } + thr->threadsvp = AvARRAY(thr->threadsv); MUTEX_LOCK(&threads_mutex); nthreads++; diff --git a/utils/h2ph.PL b/utils/h2ph.PL index 1b469daab8..5c17e97ca0 100644 --- a/utils/h2ph.PL +++ b/utils/h2ph.PL @@ -36,12 +36,14 @@ print OUT <<'!NO!SUBS!'; use Config; use File::Path qw(mkpath); +use Getopt::Std; + +getopts('d:rlh'); + my $Exit = 0; -my $Dest_dir = (@ARGV && $ARGV[0] =~ s/^-d//) - ? shift || shift - : $Config{installsitearch}; +my $Dest_dir = $opt_d || $Config{installsitearch}; die "Destination directory $Dest_dir doesn't exist or isn't a directory\n" unless -d $Dest_dir; @@ -58,11 +60,19 @@ $inif = 0; @ARGV = ('-') unless @ARGV; -foreach $file (@ARGV) { +while (defined ($file = next_file())) { + if (-l $file and -d $file) { + link_if_possible($file) if ($opt_l); + next; + } + # Recover from header files with unbalanced cpp directives $t = ''; $tab = 0; + # $eval_index goes into ``#line'' directives, to help locate syntax errors: + $eval_index = 1; + if ($file eq '-') { open(IN, "-"); open(OUT, ">-"); @@ -115,8 +125,14 @@ foreach $file (@ARGV) { $new =~ s/(["\\])/\\$1/g; if ($t ne '') { $new =~ s/(['\\])/\\$1/g; - print OUT $t, - "eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n"; + if ($opt_h) { + print OUT $t, + "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n"; + $eval_index++; + } else { + print OUT $t, + "eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n"; + } } else { print OUT "unless defined(\&$name) {\nsub $name $proto\{\n ${args}eval \"$new\";\n}\n}\n"; @@ -129,7 +145,12 @@ foreach $file (@ARGV) { $new = 1 if $new eq ''; if ($t ne '') { $new =~ s/(['\\])/\\$1/g; - print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n"; + if ($opt_h) { + print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n"; + $eval_index++; + } else { + print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n"; + } } else { print OUT $t,"unless(defined(\&$name)) {\nsub $name () {",$new,";}\n}\n"; @@ -191,10 +212,12 @@ exit $Exit; sub expr { while ($_ ne '') { + s/^\&\&// && do { $new .= "&&"; next;}; # handle && operator s/^\&//; # hack for things that take the address of s/^(\s+)// && do {$new .= ' '; next;}; - s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;}; - s/^(\d+)\s*[LlUu]*// && do {$new .= $1; next;}; + s/^(0X[0-9A-F]+)[UL]*//i && do {$new .= lc($1); next;}; + s/^(-?\d+\.\d+E[-+]\d+)F?//i && do {$new .= $1; next;}; + s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;}; s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; s/^'((\\"|[^"])*)'// && do { if ($curargs{$1}) { @@ -230,6 +253,19 @@ sub expr { substr($_, 0, $index - 1) =~ s/\*//g; next; }; + # Eliminate typedefs + /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do { + foreach (split /\s+/, $1) { # Make sure all the words are types, + last unless ($isatype{$_} or $_ eq 'struct'); + } + s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them. + }; + # struct/union member: + s/^([_A-Z]\w*((\.|->)[_A-Z]\w*)+)//i && do { + $id = $1; + $id =~ s/(\.|(->))([^\.-]*)/->\{$3\}/g; + $new .= ' ($' . $id . ')'; + }; s/^([_a-zA-Z]\w*)// && do { $id = $1; if ($id eq 'struct') { @@ -237,9 +273,8 @@ sub expr { $id .= ' ' . $1; $isatype{$id} = 1; } - elsif ($id eq 'unsigned' || $id eq 'long') { - s/^\s+(\w+)//; - $id .= ' ' . $1; + elsif ($id =~ /^((un)?signed)|(long)|(short)$/) { + while (s/^\s+(\w+)//) { $id .= ' ' . $1; } $isatype{$id} = 1; } if ($curargs{$id}) { @@ -280,6 +315,91 @@ sub expr { s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;}; } } + + +# Handle recursive subdirectories without getting a grotesquely big stack. +# Could this be implemented using File::Find? +sub next_file +{ + my $file; + + while (@ARGV) { + $file = shift @ARGV; + + if ($file eq '-' or -f $file or -l $file) { + return $file; + } elsif (-d $file) { + if ($opt_r) { + expand_glob($file); + } else { + print STDERR "Skipping directory `$file'\n"; + } + } else { + print STDERR "Skipping `$file': not a file or directory\n"; + } + } + + return undef; +} + + +# Put all the files in $directory into @ARGV for processing. +sub expand_glob +{ + my ($directory) = @_; + + $directory =~ s:/$::; + + opendir DIR, $directory; + foreach (readdir DIR) { + next if ($_ eq '.' or $_ eq '..'); + + # expand_glob() is going to be called until $ARGV[0] isn't a + # directory; so push directories, and unshift everything else. + if (-d "$directory/$_") { push @ARGV, "$directory/$_" } + else { unshift @ARGV, "$directory/$_" } + } + closedir DIR; +} + + +# Given $file, a symbolic link to a directory in the C include directory, +# make an equivalent symbolic link in $Dest_dir, if we can figure out how. +# Otherwise, just duplicate the file or directory. +sub link_if_possible +{ + my ($dirlink) = @_; + my $target = eval 'readlink($dirlink)'; + + if ($target =~ m:^\.\./: or $target =~ m:^/:) { + # The target of a parent or absolute link could leave the $Dest_dir + # hierarchy, so let's put all of the contents of $dirlink (actually, + # the contents of $target) into @ARGV; as a side effect down the + # line, $dirlink will get created as an _actual_ directory. + expand_glob($dirlink); + } else { + if (-l "$Dest_dir/$dirlink") { + unlink "$Dest_dir/$dirlink" or + print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n"; + } + + if (eval 'symlink($target, "$Dest_dir/$dirlink")') { + print "Linking $target -> $Dest_dir/$dirlink\n"; + + # Make sure that the link _links_ to something: + if (! -e "$Dest_dir/$target") { + mkdir("$Dest_dir/$target", 0755) or + print STDERR "Could not create $Dest_dir/$target/\n"; + } + } else { + print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n"; + } + } +} + + +1; + ############################################################################## __END__ @@ -289,7 +409,7 @@ h2ph - convert .h C header files to .ph Perl header files =head1 SYNOPSIS -B<h2ph [headerfiles]> +B<h2ph [-d destination directory] [-r] [-l] [headerfiles]> =head1 DESCRIPTION @@ -300,12 +420,51 @@ It is most easily run while in /usr/include: cd /usr/include; h2ph * sys/* +or + + cd /usr/include; h2ph -r -l . + The output files are placed in the hierarchy rooted at Perl's architecture dependent library directory. You can specify a different hierarchy with a B<-d> switch. If run with no arguments, filters standard input to standard output. +=head1 OPTIONS + +=over 4 + +=item -d destination_dir + +Put the resulting B<.ph> files beneath B<destination_dir>, instead of +beneath the default Perl library location (C<$Config{'installsitsearch'}>). + +=item -r + +Run recursively; if any of B<headerfiles> are directories, then run I<h2ph> +on all files in those directories (and their subdirectories, etc.). + +=item -l + +Symbolic links will be replicated in the destination directory. If B<-l> +is not specified, then links are skipped over. + +=item -h + +Put ``hints'' in the .ph files which will help in locating problems with +I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax +errors, instead of the cryptic + + [ some error condition ] at (eval mmm) line nnn + +you will see the slightly more helpful + + [ some error condition ] at filename.ph line nnn + +However, the B<.ph> files almost double in size when built using B<-h>. + +=back + =head1 ENVIRONMENT No environment variables are used. diff --git a/vms/perly_c.vms b/vms/perly_c.vms index 8495c4d955..80b1d08c32 100644 --- a/vms/perly_c.vms +++ b/vms/perly_c.vms @@ -1285,7 +1285,7 @@ dEXT int yyerrflag; dEXT int yychar; dEXT YYSTYPE yyval; dEXT YYSTYPE yylval; -#line 632 "perly.y" +#line 633 "perly.y" /* PROGRAM */ #line 1360 "perly.c" #define YYABORT goto yyabort @@ -1337,7 +1337,8 @@ yyparse(void) #endif #endif - struct ysv *ysave = (struct ysv*)safemalloc(sizeof(struct ysv)); + struct ysv *ysave; + New(73, ysave, 1, struct ysv); SAVEDESTRUCTOR(yydestruct, ysave); ysave->oldyydebug = yydebug; ysave->oldyynerrs = yynerrs; @@ -1363,8 +1364,10 @@ yyparse(void) /* ** Initialize private stacks (yyparse may be called from an action) */ - ysave->yyss = yyss = (short*)safemalloc(yystacksize*sizeof(short)); - ysave->yyvs = yyvs = (YYSTYPE*)safemalloc(yystacksize*sizeof(YYSTYPE)); + New(73, yyss, yystacksize, short); + New(73, yyvs, yystacksize, YYSTYPE); + ysave->yyss = yyss; + ysave->yyvs = yyvs; if (!yyvs || !yyss) goto yyoverflow; @@ -2003,69 +2006,70 @@ case 113: break; case 114: #line 442 "perly.y" -{ yyval.opval = newBINOP(OP_GELEM, 0, newGVREF(0,yyvsp[-4].opval), yyvsp[-2].opval); } +{ yyval.opval = newBINOP(OP_GELEM, 0, newGVREF(0,yyvsp[-4].opval), + scalar(yyvsp[-2].opval)); } break; case 115: -#line 444 "perly.y" +#line 445 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 116: -#line 446 "perly.y" +#line 447 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); } break; case 117: -#line 448 "perly.y" +#line 449 "perly.y" { yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-4].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 118: -#line 452 "perly.y" +#line 453 "perly.y" { assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0, ref(newAVREF(yyvsp[-3].opval),OP_RV2AV), scalar(yyvsp[-1].opval));} break; case 119: -#line 456 "perly.y" +#line 457 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 120: -#line 458 "perly.y" +#line 459 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 121: -#line 460 "perly.y" +#line 461 "perly.y" { yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));} break; case 122: -#line 462 "perly.y" +#line 463 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 123: -#line 465 "perly.y" +#line 466 "perly.y" { yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-5].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 124: -#line 470 "perly.y" +#line 471 "perly.y" { assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0, ref(newHVREF(yyvsp[-4].opval),OP_RV2HV), jmaybe(yyvsp[-2].opval)); expect = XOPERATOR; } break; case 125: -#line 475 "perly.y" +#line 476 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); } break; case 126: -#line 477 "perly.y" +#line 478 "perly.y" { yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); } break; case 127: -#line 479 "perly.y" +#line 480 "perly.y" { yyval.opval = prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, @@ -2073,7 +2077,7 @@ case 127: ref(yyvsp[-3].opval, OP_ASLICE))); } break; case 128: -#line 485 "perly.y" +#line 486 "perly.y" { yyval.opval = prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -2082,37 +2086,37 @@ case 128: expect = XOPERATOR; } break; case 129: -#line 492 "perly.y" +#line 493 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 130: -#line 494 "perly.y" +#line 495 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); } break; case 131: -#line 496 "perly.y" +#line 497 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); } break; case 132: -#line 498 "perly.y" +#line 499 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); } break; case 133: -#line 501 "perly.y" +#line 502 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 134: -#line 504 "perly.y" +#line 505 "perly.y" { yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); } break; case 135: -#line 506 "perly.y" +#line 507 "perly.y" { yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); } break; case 136: -#line 508 "perly.y" +#line 509 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, @@ -2122,7 +2126,7 @@ case 136: )),Nullop)); dep();} break; case 137: -#line 516 "perly.y" +#line 517 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, append_elem(OP_LIST, @@ -2133,161 +2137,161 @@ case 137: )))); dep();} break; case 138: -#line 525 "perly.y" +#line 526 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();} break; case 139: -#line 529 "perly.y" +#line 530 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED, prepend_elem(OP_LIST, yyvsp[-1].opval, scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();} break; case 140: -#line 534 "perly.y" +#line 535 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar(yyvsp[-3].opval))); } break; case 141: -#line 537 "perly.y" +#line 538 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[-1].opval, newCVREF(0, scalar(yyvsp[-4].opval)))); } break; case 142: -#line 541 "perly.y" +#line 542 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL); hints |= HINT_BLOCK_SCOPE; } break; case 143: -#line 544 "perly.y" +#line 545 "perly.y" { yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); } break; case 144: -#line 546 "perly.y" +#line 547 "perly.y" { yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); } break; case 145: -#line 548 "perly.y" +#line 549 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 146: -#line 550 "perly.y" +#line 551 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 147: -#line 552 "perly.y" +#line 553 "perly.y" { yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); } break; case 148: -#line 554 "perly.y" +#line 555 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); } break; case 149: -#line 557 "perly.y" +#line 558 "perly.y" { yyval.opval = newOP(yyvsp[0].ival, 0); } break; case 150: -#line 559 "perly.y" +#line 560 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, 0); } break; case 151: -#line 561 "perly.y" +#line 562 "perly.y" { yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[0].opval)); } break; case 152: -#line 564 "perly.y" +#line 565 "perly.y" { yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); } break; case 153: -#line 566 "perly.y" +#line 567 "perly.y" { yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); } break; case 154: -#line 568 "perly.y" +#line 569 "perly.y" { yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); } break; case 155: -#line 570 "perly.y" +#line 571 "perly.y" { yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); } break; case 158: -#line 576 "perly.y" +#line 577 "perly.y" { yyval.opval = Nullop; } break; case 159: -#line 578 "perly.y" +#line 579 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 160: -#line 582 "perly.y" +#line 583 "perly.y" { yyval.opval = Nullop; } break; case 161: -#line 584 "perly.y" +#line 585 "perly.y" { yyval.opval = yyvsp[0].opval; } break; case 162: -#line 586 "perly.y" +#line 587 "perly.y" { yyval.opval = yyvsp[-1].opval; } break; case 163: -#line 589 "perly.y" +#line 590 "perly.y" { yyval.ival = 0; } break; case 164: -#line 590 "perly.y" +#line 591 "perly.y" { yyval.ival = 1; } break; case 165: -#line 594 "perly.y" +#line 595 "perly.y" { in_my = 0; yyval.opval = my(yyvsp[0].opval); } break; case 166: -#line 598 "perly.y" +#line 599 "perly.y" { yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); } break; case 167: -#line 602 "perly.y" +#line 603 "perly.y" { yyval.opval = newSVREF(yyvsp[0].opval); } break; case 168: -#line 606 "perly.y" +#line 607 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 169: -#line 610 "perly.y" +#line 611 "perly.y" { yyval.opval = newHVREF(yyvsp[0].opval); } break; case 170: -#line 614 "perly.y" +#line 615 "perly.y" { yyval.opval = newAVREF(yyvsp[0].opval); } break; case 171: -#line 618 "perly.y" +#line 619 "perly.y" { yyval.opval = newGVREF(0,yyvsp[0].opval); } break; case 172: -#line 622 "perly.y" +#line 623 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 173: -#line 624 "perly.y" +#line 625 "perly.y" { yyval.opval = scalar(yyvsp[0].opval); } break; case 174: -#line 626 "perly.y" +#line 627 "perly.y" { yyval.opval = scope(yyvsp[0].opval); } break; case 175: -#line 629 "perly.y" +#line 630 "perly.y" { yyval.opval = yyvsp[0].opval; } break; -#line 2272 "perly.c" +#line 2273 "perly.c" } yyssp -= yym; yystate = *yyssp; diff --git a/win32/makedef.pl b/win32/makedef.pl index b4097d5c23..aa0fe34096 100644 --- a/win32/makedef.pl +++ b/win32/makedef.pl @@ -221,6 +221,7 @@ Perl_nthreads Perl_nthreads_cond Perl_per_thread_magicals Perl_thread_create +Perl_threadnum Perl_find_threadsv Perl_threadsv_names Perl_thrsv @@ -510,6 +511,7 @@ win32_alarm win32_open_osfhandle win32_get_osfhandle win32_ioctl +win32_utime win32_wait win32_str_os_error Perl_win32_init diff --git a/win32/win32.c b/win32/win32.c index 9ae2a7d70f..01c43b840b 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -35,6 +35,12 @@ #include <string.h> #include <stdarg.h> #include <float.h> +#include <time.h> +#ifdef _MSC_VER +#include <sys/utime.h> +#else +#include <utime.h> +#endif #ifdef __GNUC__ /* Mingw32 defaults to globing command line @@ -53,6 +59,7 @@ static long tokenize(char *str, char **dest, char ***destv); static int do_spawn2(char *cmd, int exectype); static BOOL has_redirection(char *ptr); static long filetime_to_clock(PFILETIME ft); +static BOOL filetime_from_time(PFILETIME ft, time_t t); char * w32_perlshell_tokens = Nullch; char ** w32_perlshell_vec; @@ -800,6 +807,68 @@ win32_times(struct tms *timebuf) return 0; } +/* fix utime() so it works on directories in NT + * thanks to Jan Dubois <jan.dubois@ibm.net> + */ +static BOOL +filetime_from_time(PFILETIME pFileTime, time_t Time) +{ + struct tm *pTM = gmtime(&Time); + SYSTEMTIME SystemTime; + + if (pTM == NULL) + return FALSE; + + SystemTime.wYear = pTM->tm_year + 1900; + SystemTime.wMonth = pTM->tm_mon + 1; + SystemTime.wDay = pTM->tm_mday; + SystemTime.wHour = pTM->tm_hour; + SystemTime.wMinute = pTM->tm_min; + SystemTime.wSecond = pTM->tm_sec; + SystemTime.wMilliseconds = 0; + + return SystemTimeToFileTime(&SystemTime, pFileTime); +} + +DllExport int +win32_utime(const char *filename, struct utimbuf *times) +{ + HANDLE handle; + FILETIME ftCreate; + FILETIME ftAccess; + FILETIME ftWrite; + struct utimbuf TimeBuffer; + + int rc = utime(filename,times); + /* EACCES: path specifies directory or readonly file */ + if (rc == 0 || errno != EACCES /* || !IsWinNT() */) + return rc; + + if (times == NULL) { + times = &TimeBuffer; + time(×->actime); + times->modtime = times->actime; + } + + /* This will (and should) still fail on readonly files */ + handle = CreateFile(filename, GENERIC_READ | GENERIC_WRITE, + FILE_SHARE_READ | FILE_SHARE_DELETE, NULL, + OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); + if (handle == INVALID_HANDLE_VALUE) + return rc; + + if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) && + filetime_from_time(&ftAccess, times->actime) && + filetime_from_time(&ftWrite, times->modtime) && + SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite)) + { + rc = 0; + } + + CloseHandle(handle); + return rc; +} + DllExport int win32_wait(int *status) { @@ -1885,15 +1954,22 @@ XS(w32_GetShortPathName) XSRETURN(1); } +static +XS(w32_Sleep) +{ + dXSARGS; + if (items != 1) + croak("usage: Win32::Sleep($milliseconds)"); + Sleep(SvIV(ST(0))); + XSRETURN_YES; +} + void Perl_init_os_extras() { char *file = __FILE__; dXSUB_SYS; - /* XXX should be removed after checking with Nick */ - newXS("Win32::GetCurrentDirectory", w32_GetCwd, file); - /* these names are Activeware compatible */ newXS("Win32::GetCwd", w32_GetCwd, file); newXS("Win32::SetCwd", w32_SetCwd, file); @@ -1910,6 +1986,7 @@ Perl_init_os_extras() newXS("Win32::Spawn", w32_Spawn, file); newXS("Win32::GetTickCount", w32_GetTickCount, file); newXS("Win32::GetShortPathName", w32_GetShortPathName, file); + newXS("Win32::Sleep", w32_Sleep, file); /* XXX Bloat Alert! The following Activeware preloads really * ought to be part of Win32::Sys::*, so they're not included @@ -1962,11 +2039,3 @@ win32_strip_return(SV *sv) } #endif - - - - - - - - diff --git a/win32/win32iop.h b/win32/win32iop.h index 98627e4c6b..7e03a9aeb4 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -13,6 +13,12 @@ #endif #endif +#ifdef _MSC_VER +# include <sys/utime.h> +#else +# include <utime.h> +#endif + /* * defines for flock emulation */ @@ -114,6 +120,7 @@ DllExport int win32_times(struct tms *timebuf); DllExport unsigned win32_alarm(unsigned int sec); DllExport int win32_stat(const char *path, struct stat *buf); DllExport int win32_ioctl(int i, unsigned int u, char *data); +DllExport int win32_utime(const char *f, struct utimbuf *t); DllExport int win32_wait(int *status); #ifdef HAVE_DES_FCRYPT @@ -140,6 +147,7 @@ END_EXTERN_C #undef times #undef alarm #undef ioctl +#undef utime #undef wait #ifdef __BORLANDC__ @@ -246,6 +254,7 @@ END_EXTERN_C #define times win32_times #define alarm win32_alarm #define ioctl win32_ioctl +#define utime win32_utime #define wait win32_wait #endif /* PERL_OBJECT */ diff --git a/win32/win32sck.c b/win32/win32sck.c index 5ac2ef6c65..14d2e6a45f 100644 --- a/win32/win32sck.c +++ b/win32/win32sck.c @@ -269,6 +269,15 @@ win32_select(int nfds, Perl_fd_set* rd, Perl_fd_set* wr, Perl_fd_set* ex, const int i, fd, bit, offset; FD_SET nrd, nwr, nex, *prd, *pwr, *pex; + /* winsock seems incapable of dealing with all three null fd_sets, + * so do the (millisecond) sleep as a special case + */ + if (!(rd || wr || ex)) { + Sleep(timeout->tv_sec * 1000 + + timeout->tv_usec / 1000); /* do the best we can */ + return 0; + } + StartSockets(); PERL_FD_ZERO(&dummy); if (!rd) rd = &dummy, prd = NULL; diff --git a/x2p/hash.c b/x2p/hash.c index 9f6bbe9015..f11f7dfc55 100644 --- a/x2p/hash.c +++ b/x2p/hash.c @@ -65,7 +65,7 @@ hstore(register HASH *tb, char *key, STR *val) if (strNE(entry->hent_key,key)) /* is this it? */ continue; /*NOSTRICT*/ - Safefree(entry->hent_val); + safefree(entry->hent_val); entry->hent_val = val; return TRUE; } @@ -216,7 +216,7 @@ str_grow(register STR *str, int len) void str_replace(register STR *str, register STR *nstr) { - Safefree(str->str_ptr); + safefree(str->str_ptr); str->str_ptr = nstr->str_ptr; str->str_len = nstr->str_len; str->str_cur = nstr->str_cur; |