diff options
| -rw-r--r-- | Changes | 2 | ||||
| -rw-r--r-- | Changes5.005 | 2 | ||||
| -rw-r--r-- | embed.h | 1 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | mg.c | 95 | ||||
| -rw-r--r-- | objXSUB.h | 2 | ||||
| -rw-r--r-- | objpp.h | 2 | ||||
| -rw-r--r-- | perl.h | 8 | ||||
| -rw-r--r-- | proto.h | 1 | ||||
| -rw-r--r-- | scope.c | 19 | ||||
| -rw-r--r-- | scope.h | 18 | ||||
| -rwxr-xr-x | t/io/tell.t | 41 |
12 files changed, 147 insertions, 45 deletions
@@ -42,7 +42,7 @@ current addresses (as of July 1998): Dean Roehrich <roehrich@cray.com> Hugo van der Sanden <hv@crypt0.demon.co.uk> Roderick Schertler <roderick@argon.org> - Kurt D. Starsinic <kstar@chapin.edu> + Kurt D. Starsinic <kstar@isinet.com> Dan Sugalski <sugalskd@osshe.edu> Larry W. Virden <lvirden@cas.org> Ilya Zakharevich <ilya@math.ohio-state.edu> diff --git a/Changes5.005 b/Changes5.005 index 4980250c2c..cfd6e59a44 100644 --- a/Changes5.005 +++ b/Changes5.005 @@ -42,7 +42,7 @@ current addresses (as of July 1998): Dean Roehrich <roehrich@cray.com> Hugo van der Sanden <hv@crypt0.demon.co.uk> Roderick Schertler <roderick@argon.org> - Kurt D. Starsinic <kstar@chapin.edu> + Kurt D. Starsinic <kstar@isinet.com> Dan Sugalski <sugalskd@osshe.edu> Larry W. Virden <lvirden@cas.org> Ilya Zakharevich <ilya@math.ohio-state.edu> @@ -878,6 +878,7 @@ #define save_I16 Perl_save_I16 #define save_I32 Perl_save_I32 #define save_aelem Perl_save_aelem +#define save_alloc Perl_save_alloc #define save_aptr Perl_save_aptr #define save_ary Perl_save_ary #define save_clearsv Perl_save_clearsv diff --git a/global.sym b/global.sym index c4f2229f92..676cb2a3c1 100644 --- a/global.sym +++ b/global.sym @@ -933,6 +933,7 @@ same_dirent save_I16 save_I32 save_aelem +save_alloc save_aptr save_ary save_clearsv @@ -26,34 +26,36 @@ # endif #endif +#ifdef PERL_OBJECT +# define VTBL this->*vtbl +#else +# define VTBL *vtbl +static void restore_magic _((void *p)); +#endif + /* * Use the "DESTRUCTOR" scope cleanup to reinstate magic. */ -#ifdef PERL_OBJECT - -#define VTBL this->*vtbl - -#else struct magic_state { SV* mgs_sv; U32 mgs_flags; + I32 mgs_ss_ix; }; -typedef struct magic_state MGS; - -static void restore_magic _((void *p)); -#define VTBL *vtbl - -#endif +/* MGS is typedef'ed to struct magic_state in perl.h */ STATIC void -save_magic(MGS *mgs, SV *sv) +save_magic(I32 mgs_ix, SV *sv) { + MGS* mgs; assert(SvMAGICAL(sv)); + SAVEDESTRUCTOR(restore_magic, (void*)mgs_ix); + + mgs = SSPTR(mgs_ix, MGS*); mgs->mgs_sv = sv; mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv); - SAVEDESTRUCTOR(restore_magic, mgs); + mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */ SvMAGICAL_off(sv); SvREADONLY_off(sv); @@ -63,9 +65,12 @@ save_magic(MGS *mgs, SV *sv) STATIC void restore_magic(void *p) { - MGS* mgs = (MGS*)p; + MGS* mgs = SSPTR((I32)p, MGS*); SV* sv = mgs->mgs_sv; + if (!sv) + return; + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { if (mgs->mgs_flags) @@ -75,6 +80,24 @@ restore_magic(void *p) if (SvGMAGICAL(sv)) SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); } + + mgs->mgs_sv = NULL; /* mark the MGS structure as restored */ + + /* If we're still on top of the stack, pop us off. (That condition + * will be satisfied if restore_magic was called explicitly, but *not* + * if it's being called via leave_scope.) + * The reason for doing this is that otherwise, things like sv_2cv() + * may leave alloc gunk on the savestack, and some code + * (e.g. sighandler) doesn't expect that... + */ + if (PL_savestack_ix == mgs->mgs_ss_ix) + { + assert(SSPOPINT == SAVEt_DESTRUCTOR); + PL_savestack_ix -= 2; + assert(SSPOPINT == SAVEt_ALLOC); + PL_savestack_ix -= SSPOPINT; + } + } void @@ -97,13 +120,13 @@ mg_magical(SV *sv) int mg_get(SV *sv) { - MGS mgs; + I32 mgs_ix; MAGIC* mg; MAGIC** mgp; int mgp_valid = 0; - ENTER; - save_magic(&mgs, sv); + mgs_ix = SSNEW(sizeof(MGS)); + save_magic(mgs_ix, sv); mgp = &SvMAGIC(sv); while ((mg = *mgp) != 0) { @@ -113,7 +136,7 @@ mg_get(SV *sv) /* Ignore this magic if it's been deleted */ if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) && (mg->mg_flags & MGf_GSKIP)) - mgs.mgs_flags = 0; + (SSPTR(mgs_ix, MGS*))->mgs_flags = 0; } /* Advance to next magic (complicated by possible deletion) */ if (mg == (mgp_valid ? *mgp : SvMAGIC(sv))) { @@ -124,32 +147,32 @@ mg_get(SV *sv) mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */ } - LEAVE; + restore_magic((void*)mgs_ix); return 0; } int mg_set(SV *sv) { - MGS mgs; + I32 mgs_ix; MAGIC* mg; MAGIC* nextmg; - ENTER; - save_magic(&mgs, sv); + mgs_ix = SSNEW(sizeof(MGS)); + save_magic(mgs_ix, sv); for (mg = SvMAGIC(sv); mg; mg = nextmg) { MGVTBL* vtbl = mg->mg_virtual; nextmg = mg->mg_moremagic; /* it may delete itself */ if (mg->mg_flags & MGf_GSKIP) { mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ - mgs.mgs_flags = 0; + (SSPTR(mgs_ix, MGS*))->mgs_flags = 0; } if (vtbl && (vtbl->svt_set != NULL)) (VTBL->svt_set)(sv, mg); } - LEAVE; + restore_magic((void*)mgs_ix); return 0; } @@ -163,13 +186,13 @@ mg_length(SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (vtbl && (vtbl->svt_len != NULL)) { - MGS mgs; + I32 mgs_ix; - ENTER; - save_magic(&mgs, sv); + mgs_ix = SSNEW(sizeof(MGS)); + save_magic(mgs_ix, sv); /* omit MGf_GSKIP -- not changed here */ len = (VTBL->svt_len)(sv, mg); - LEAVE; + restore_magic((void*)mgs_ix); return len; } } @@ -187,11 +210,13 @@ mg_size(SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (vtbl && (vtbl->svt_len != NULL)) { - MGS mgs; - ENTER; + I32 mgs_ix; + + mgs_ix = SSNEW(sizeof(MGS)); + save_magic(mgs_ix, sv); /* omit MGf_GSKIP -- not changed here */ len = (VTBL->svt_len)(sv, mg); - LEAVE; + restore_magic((void*)mgs_ix); return len; } } @@ -212,11 +237,11 @@ mg_size(SV *sv) int mg_clear(SV *sv) { - MGS mgs; + I32 mgs_ix; MAGIC* mg; - ENTER; - save_magic(&mgs, sv); + mgs_ix = SSNEW(sizeof(MGS)); + save_magic(mgs_ix, sv); for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; @@ -226,7 +251,7 @@ mg_clear(SV *sv) (VTBL->svt_clear)(sv, mg); } - LEAVE; + restore_magic((void*)mgs_ix); return 0; } @@ -1613,6 +1613,8 @@ #define savestack_grow pPerl->Perl_savestack_grow #undef save_aelem #define save_aelem pPerl->Perl_save_aelem +#undef save_alloc +#define save_alloc pPerl->Perl_save_alloc #undef save_aptr #define save_aptr pPerl->Perl_save_aptr #undef save_ary @@ -1144,6 +1144,8 @@ #define savestack_grow CPerlObj::Perl_savestack_grow #undef save_aelem #define save_aelem CPerlObj::Perl_save_aelem +#undef save_alloc +#define save_alloc CPerlObj::Perl_save_alloc #undef save_aptr #define save_aptr CPerlObj::Perl_save_aptr #undef save_ary @@ -1300,13 +1300,9 @@ struct _sublex_info { OP *sub_op; /* "lex_op" to use */ }; -#ifdef PERL_OBJECT -struct magic_state { - SV* mgs_sv; - U32 mgs_flags; -}; -typedef struct magic_state MGS; +typedef struct magic_state MGS; /* struct magic_state defined in mg.c */ +#ifdef PERL_OBJECT typedef struct { I32 len_min; I32 len_delta; @@ -498,6 +498,7 @@ VIRTUAL char* savepv _((char* sv)); VIRTUAL char* savepvn _((char* sv, I32 len)); VIRTUAL void savestack_grow _((void)); VIRTUAL void save_aelem _((AV* av, I32 idx, SV **sptr)); +VIRTUAL I32 save_alloc _((I32 size, I32 pad)); VIRTUAL void save_aptr _((AV** aptr)); VIRTUAL AV* save_ary _((GV* gv)); VIRTUAL void save_clearsv _((SV** svp)); @@ -532,6 +532,24 @@ save_op(void) SSPUSHINT(SAVEt_OP); } +I32 +save_alloc(I32 size, I32 pad) +{ + dTHR; + register I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix] + - (char*)PL_savestack); + register I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack)); + + /* SSCHECK may not be good enough */ + while (PL_savestack_ix + elems + 2 > PL_savestack_max) + savestack_grow(); + + PL_savestack_ix += elems; + SSPUSHINT(elems); + SSPUSHINT(SAVEt_ALLOC); + return start; +} + void leave_scope(I32 base) { @@ -759,6 +777,7 @@ leave_scope(I32 base) (CALLDESTRUCTOR)(ptr); break; case SAVEt_REGCONTEXT: + case SAVEt_ALLOC: i = SSPOPINT; PL_savestack_ix -= i; /* regexp must have croaked */ break; @@ -26,6 +26,7 @@ #define SAVEt_HELEM 25 #define SAVEt_OP 26 #define SAVEt_HINTS 27 +#define SAVEt_ALLOC 28 #define SSCHECK(need) if (PL_savestack_ix + need > PL_savestack_max) savestack_grow() #define SSPUSHINT(i) (PL_savestack[PL_savestack_ix++].any_i32 = (I32)(i)) @@ -110,6 +111,23 @@ } \ } STMT_END +/* SSNEW() temporarily allocates a specified number of bytes of data on the + * savestack. It returns an integer index into the savestack, because a + * pointer would get broken if the savestack is moved on reallocation. + * SSNEWa() works like SSNEW(), but also aligns the data to the specified + * number of bytes. MEM_ALIGNBYTES is perhaps the most useful. The + * alignment will be preserved therough savestack reallocation *only* if + * realloc returns data aligned to a size divisible by `align'! + * + * SSPTR() converts the index returned by SSNEW/SSNEWa() into a pointer. + */ + +#define SSNEW(size) save_alloc(size, 0) +#define SSNEWa(size,align) save_alloc(size, \ + (align - ((int)((caddr_t)&PL_savestack[PL_savestack_ix]) % align)) % align) + +#define SSPTR(off,type) ((type) ((char*)PL_savestack + off)) + /* A jmpenv packages the state required to perform a proper non-local jump. * Note that there is a start_env initialized when perl starts, and top_env * points to this initially, so top_env should always be non-null. diff --git a/t/io/tell.t b/t/io/tell.t index 83904e88bb..afcfcb5800 100755 --- a/t/io/tell.t +++ b/t/io/tell.t @@ -1,8 +1,8 @@ #!./perl -# $RCSfile: tell.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:33 $ +# $RCSfile: tell.t,v $$Revision$$Date$ -print "1..13\n"; +print "1..21\n"; $TST = 'tst'; @@ -42,3 +42,40 @@ if (seek(tst,0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; } if ($lastpos == tell) { print "ok 12\n"; } else { print "not ok 12\n"; } unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; } + +if ($. == 0) { print "not ok 14\n"; } else { print "ok 14\n"; } + +$curline = $.; +open(other, '../Configure') || (die "Can't open ../Configure"); +binmode other if $^O eq 'MSWin32'; + +{ + local($.); + + if ($. == 0) { print "not ok 15\n"; } else { print "ok 15\n"; } + + tell other; + if ($. == 0) { print "ok 16\n"; } else { print "not ok 16\n"; } + + $. = 5; + scalar <other>; + if ($. == 6) { print "ok 17\n"; } else { print "not ok 17\n"; } +} + +if ($. == $curline) { print "ok 18\n"; } else { print "not ok 18\n"; } + +{ + local($.); + + scalar <other>; + if ($. == 7) { print "ok 19\n"; } else { print "not ok 19\n"; } +} + +if ($. == $curline) { print "ok 20\n"; } else { print "not ok 20\n"; } + +{ + local($.); + + tell other; + if ($. == 7) { print "ok 21\n"; } else { print "not ok 21\n"; } +} |