can tail call us and return true. */
return (char *) 1;
} else {
- return SvPV(buffer, *len);
+ assert(SvPOK(buffer));
+ if (len) {
+ *len = SvCUR(buffer);
+ }
+ return SvPVX(buffer);
}
}
/*
=for apidoc sv_usepvn
-Tells an SV to use C<ptr> to find its string value. Normally the string is
-stored inside the SV but sv_usepvn allows the SV to use an outside string.
-The C<ptr> should point to memory that was allocated by C<malloc>. The
-string length, C<len>, must be supplied. This function will realloc the
-memory pointed to by C<ptr>, so that pointer should not be freed or used by
-the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
+Tells an SV to use C<ptr> to find its string value. Normally the
+string is stored inside the SV but sv_usepvn allows the SV to use an
+outside string. The C<ptr> should point to memory that was allocated
+by C<malloc>. The string length, C<len>, must be supplied. This
+function will realloc (i.e. move) 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, and neither should any pointers from "behind"
+that pointer (e.g. ptr + 1) be used. Does not handle 'set' magic.
See C<sv_usepvn_mg>.
=cut
register I32 cnt;
I32 i = 0;
I32 rspara = 0;
- I32 recsize;
if (SvTHINKFIRST(sv))
sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
}
else if (RsSNARF(PL_rs)) {
/* If it is a regular disk file use size from stat() as estimate
- of amount we are going to read - may result in malloc-ing
- more memory than we realy need if layers bellow reduce
- size we read (e.g. CRLF or a gzip layer)
+ of amount we are going to read -- may result in mallocing
+ more memory than we really need if the layers below reduce
+ the size we read (e.g. CRLF or a gzip layer).
*/
Stat_t st;
if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
else if (RsRECORD(PL_rs)) {
I32 bytesread;
char *buffer;
+ U32 recsize;
/* Grab the size of the record we're getting */
- recsize = SvIV(SvRV(PL_rs));
+ recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
/* Go yank in */
#ifdef VMS
return sv;
}
/* This will be overwhelminly the most common case. */
- return newSVpvn_share(HEK_KEY(hek),
- (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
- HEK_HASH(hek));
+ {
+ /* Inline most of newSVpvn_share(), because share_hek_hek() is far
+ more efficient than sharepvn(). */
+ SV *sv;
+
+ new_SV(sv);
+ sv_upgrade(sv, SVt_PV);
+ SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
+ SvCUR_set(sv, HEK_LEN(hek));
+ SvLEN_set(sv, 0);
+ SvREADONLY_on(sv);
+ SvFAKE_on(sv);
+ SvPOK_on(sv);
+ if (HEK_UTF8(hek))
+ SvUTF8_on(sv);
+ return sv;
+ }
}
}
dVAR;
register SV *sv;
bool is_utf8 = FALSE;
+ const char *const orig_src = src;
+
if (len < 0) {
STRLEN tmplen = -len;
is_utf8 = TRUE;
SvPOK_on(sv);
if (is_utf8)
SvUTF8_on(sv);
+ if (src != orig_src)
+ Safefree(src);
return sv;
}
#endif
+/* Certain cases in Perl_ss_dup have been merged, by relying on the fact
+ that currently av_dup and hv_dup are the same as sv_dup. If this changes,
+ please unmerge ss_dup. */
#define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
#define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t))
#define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
TOPINT(nss,ix) = i;
switch (i) {
case SAVEt_ITEM: /* normal string */
+ case SAVEt_SV: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
sv = (SV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
- case SAVEt_SV: /* scalar reference */
- sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv, param);
- gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup_inc(gv, param);
- break;
- case SAVEt_GENERIC_PVREF: /* generic char* */
- c = (char*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = pv_dup(c);
- ptr = POPPTR(ss,ix);
- TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- break;
case SAVEt_SHARED_PVREF: /* char* in shared space */
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = savesharedpv(c);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
break;
- case SAVEt_AV: /* array reference */
- av = (AV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = av_dup_inc(av, param);
- gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup(gv, param);
- break;
case SAVEt_HV: /* hash reference */
- hv = (HV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup_inc(hv, param);
+ case SAVEt_AV: /* array reference */
+ sv = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
gv = (GV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = gv_dup(gv, param);
break;
iv = POPIV(ss,ix);
TOPIV(nss,ix) = iv;
break;
+ case SAVEt_HPTR: /* HV* reference */
+ case SAVEt_APTR: /* AV* reference */
case SAVEt_SPTR: /* SV* reference */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
break;
+ case SAVEt_GENERIC_PVREF: /* generic char* */
case SAVEt_PPTR: /* char* reference */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup(c);
break;
- case SAVEt_HPTR: /* HV* reference */
- ptr = POPPTR(ss,ix);
- TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- hv = (HV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup(hv, param);
- break;
- case SAVEt_APTR: /* AV* reference */
- ptr = POPPTR(ss,ix);
- TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- av = (AV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = av_dup(av, param);
- break;
case SAVEt_NSTAB:
gv = (GV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = gv_dup(gv, param);
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
ptr = POPPTR(ss,ix);
- TOPPTR(nss,ix) = Perl_refcounted_he_dup(aTHX_ ptr, param);
+ if (ptr) {
+ HINTS_REFCNT_LOCK;
+ ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
+ HINTS_REFCNT_UNLOCK;
+ }
+ TOPPTR(nss,ix) = ptr;
if (i & HINT_LOCALIZE_HH) {
hv = (HV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = hv_dup_inc(hv, param);
sv = (SV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup(sv, param);
break;
+ case SAVEt_RE_STATE:
+ {
+ const struct re_save_state *const old_state
+ = (struct re_save_state *)
+ (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
+ struct re_save_state *const new_state
+ = (struct re_save_state *)
+ (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
+
+ Copy(old_state, new_state, 1, struct re_save_state);
+ ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
+
+ new_state->re_state_bostr
+ = pv_dup(old_state->re_state_bostr);
+ new_state->re_state_reginput
+ = pv_dup(old_state->re_state_reginput);
+ new_state->re_state_regeol
+ = pv_dup(old_state->re_state_regeol);
+ new_state->re_state_regstartp
+ = any_dup(old_state->re_state_regstartp, proto_perl);
+ new_state->re_state_regendp
+ = any_dup(old_state->re_state_regendp, proto_perl);
+ new_state->re_state_reglastparen
+ = any_dup(old_state->re_state_reglastparen, proto_perl);
+ new_state->re_state_reglastcloseparen
+ = any_dup(old_state->re_state_reglastcloseparen,
+ proto_perl);
+ /* XXX This just has to be broken. The old save_re_context
+ code did SAVEGENERICPV(PL_reg_start_tmp);
+ PL_reg_start_tmp is char **.
+ Look above to what the dup code does for
+ SAVEt_GENERIC_PVREF
+ It can never have worked.
+ So this is merely a faithful copy of the exiting bug: */
+ new_state->re_state_reg_start_tmp
+ = (char **) pv_dup((char *)
+ old_state->re_state_reg_start_tmp);
+ /* I assume that it only ever "worked" because no-one called
+ (pseudo)fork while the regexp engine had re-entered itself.
+ */
+#ifdef PERL_OLD_COPY_ON_WRITE
+ new_state->re_state_nrs
+ = sv_dup(old_state->re_state_nrs, param);
+#endif
+ new_state->re_state_reg_magic
+ = any_dup(old_state->re_state_reg_magic, proto_perl);
+ new_state->re_state_reg_oldcurpm
+ = any_dup(old_state->re_state_reg_oldcurpm, proto_perl);
+ new_state->re_state_reg_curpm
+ = any_dup(old_state->re_state_reg_curpm, proto_perl);
+ new_state->re_state_reg_oldsaved
+ = pv_dup(old_state->re_state_reg_oldsaved);
+ new_state->re_state_reg_poscache
+ = pv_dup(old_state->re_state_reg_poscache);
+#ifdef DEBUGGING
+ new_state->re_state_reg_starttry
+ = pv_dup(old_state->re_state_reg_starttry);
+#endif
+ break;
+ }
+ case SAVEt_COP_WARNINGS:
+ {
+ void *optr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = ptr = any_dup(optr, proto_perl);
+ if (ptr != optr) {
+ /* We duped something in the interpreter structure. */
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
+ } else {
+ /* I don't think that this happens, but it would mean that
+ we (didn't) dup something shared. */
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = ptr;
+ }
+ }
+ break;
default:
Perl_croak(aTHX_ "panic: ss_dup inconsistency (%"IVdf")", (IV) i);
}
ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
- if (!specialWARN(PL_compiling.cop_warnings))
- PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
if (!specialCopIO(PL_compiling.cop_io))
PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
- PL_compiling.cop_hints
- = Perl_refcounted_he_dup(aTHX_ PL_compiling.cop_hints, param);
+ if (PL_compiling.cop_hints) {
+ HINTS_REFCNT_LOCK;
+ PL_compiling.cop_hints->refcounted_he_refcnt++;
+ HINTS_REFCNT_UNLOCK;
+ }
PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
/* pseudo environmental stuff */
projects / p5sagit/p5-mst-13.2.git / blobdiff