/* sv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
SV* sva = (SV*)ptr;
register SV* sv;
register SV* svend;
- Zero(ptr, size, char);
/* The first SV in an arena isn't an SV. */
SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
sv = sva + 1;
while (sv < svend) {
SvANY(sv) = (void *)(SV*)(sv + 1);
+ SvREFCNT(sv) = 0;
SvFLAGS(sv) = SVTYPEMASK;
sv++;
}
p = "???";
else if (!HvNAME(hv))
p = "__ANON__";
- else
+ else
p = HvNAME(hv);
if (strNE(p, "main")) {
sv_catpv(name,p);
{
bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
- I32 index;
- SV *keysv;
+ I32 index = 0;
+ SV *keysv = Nullsv;
int subscript_type = FUV_SUBSCRIPT_WITHIN;
if (pad) { /* @lex, %lex */
gv = cGVOPx_gv(o);
if (match && GvSV(gv) != uninit_sv)
break;
- return S_varname(aTHX_ gv, "$", 0,
+ return S_varname(aTHX_ gv, "$", 0,
Nullsv, 0, FUV_SUBSCRIPT_NONE);
}
/* other possibilities not handled are:
Perl_report_uninit(pTHX_ SV* uninit_sv)
{
if (PL_op) {
- SV* varname;
+ SV* varname = Nullsv;
if (uninit_sv) {
varname = find_uninit_var(PL_op, uninit_sv,0);
if (varname)
bool
Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
{
+
char* pv = NULL;
U32 cur = 0;
U32 len = 0;
Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
}
+ SvFLAGS(sv) &= ~SVTYPEMASK;
+ SvFLAGS(sv) |= mt;
+
switch (mt) {
case SVt_NULL:
Perl_croak(aTHX_ "Can't upgrade to undef");
SvSTASH(sv) = stash;
AvALLOC(sv) = 0;
AvARYLEN(sv) = 0;
- AvFLAGS(sv) = 0;
+ AvFLAGS(sv) = AVf_REAL;
break;
case SVt_PVHV:
SvANY(sv) = new_XPVHV();
IoPAGE_LEN(sv) = 60;
break;
}
- SvFLAGS(sv) &= ~SVTYPEMASK;
- SvFLAGS(sv) |= mt;
return TRUE;
}
default: s = "UNKNOWN"; break;
}
tsv = NEWSV(0,0);
- if (SvOBJECT(sv))
- if (HvNAME(SvSTASH(sv)))
- Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
- else
- Perl_sv_setpvf(aTHX_ tsv, "__ANON__=%s", s);
+ if (SvOBJECT(sv)) {
+ const char *name = HvNAME(SvSTASH(sv));
+ Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
+ name ? name : "__ANON__" , s, PTR2UV(sv));
+ }
else
- sv_setpv(tsv, s);
- Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
+ Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", s, PTR2UV(sv));
goto tokensaveref;
}
*lp = strlen(s);
*lp = len;
s = SvGROW(sv, len + 1);
SvCUR_set(sv, len);
- (void)strcpy(s, t);
SvPOKp_on(sv);
- return s;
+ return strcpy(s, t);
}
}
/*
=for apidoc sv_utf8_upgrade
-Convert the PV of an SV to its UTF-8-encoded form.
+Converts the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear.
=for apidoc sv_utf8_upgrade_flags
-Convert the PV of an SV to its UTF-8-encoded form.
+Converts the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
U8 *s, *t, *e;
int hibit = 0;
- if (!sv)
+ if (sv == &PL_sv_undef)
return 0;
-
if (!SvPOK(sv)) {
STRLEN len = 0;
- (void) sv_2pv_flags(sv,&len, flags);
- if (!SvPOK(sv))
- return len;
+ if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
+ (void) sv_2pv_flags(sv,&len, flags);
+ if (SvUTF8(sv))
+ return len;
+ } else {
+ (void) SvPV_force(sv,len);
+ }
}
- if (SvUTF8(sv))
+ if (SvUTF8(sv)) {
return SvCUR(sv);
+ }
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
/*
=for apidoc sv_utf8_downgrade
-Attempt to convert the PV of an SV from UTF-8-encoded to byte encoding.
-This may not be possible if the PV contains non-byte encoding characters;
-if this is the case, either returns false or, if C<fail_ok> is not
+Attempts to convert the PV of an SV from characters to bytes.
+If the PV contains a character beyond byte, this conversion will fail;
+in this case, either returns false or, if C<fail_ok> is not
true, croaks.
This is not as a general purpose Unicode to byte encoding interface:
bool
Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
{
- if (SvPOK(sv) && SvUTF8(sv)) {
+ if (SvPOKp(sv) && SvUTF8(sv)) {
if (SvCUR(sv)) {
U8 *s;
STRLEN len;
/*
=for apidoc sv_utf8_encode
-Convert the PV of an SV to UTF-8-encoded, but then turn off the C<SvUTF8>
-flag so that it looks like octets again. Used as a building block
-for encode_utf8 in Encode.xs
+Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
+flag off so that it looks like octets again.
=cut
*/
/*
=for apidoc sv_utf8_decode
-Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
-turn off SvUTF8 if needed so that we see characters. Used as a building block
-for decode_utf8 in Encode.xs
+If the PV of the SV is an octet sequence in UTF-8
+and contains a multiple-byte character, the C<SvUTF8> flag is turned on
+so that it looks like a character. If the PV contains only single-byte
+characters, the C<SvUTF8> flag stays being off.
+Scans PV for validity and returns false if the PV is invalid UTF-8.
=cut
*/
bool
Perl_sv_utf8_decode(pTHX_ register SV *sv)
{
- if (SvPOK(sv)) {
+ if (SvPOKp(sv)) {
U8 *c;
U8 *e;
Loosely speaking, it performs a copy-by-value, obliterating any previous
content of the destination.
If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
-C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
-implemented in terms of this function.
+C<ssv> if appropriate, else not. If the C<flags> parameter has the
+C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
+and C<sv_setsv_nomg> are implemented in terms of this function.
You probably want to use one of the assortment of wrappers, such as
C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
dtype = SvTYPE(dstr);
SvAMAGIC_off(dstr);
- if ( SvVOK(dstr) )
+ if ( SvVOK(dstr) )
{
/* need to nuke the magic */
mg_free(dstr);
!(isSwipe =
(sflags & SVs_TEMP) && /* slated for free anyway? */
!(sflags & SVf_OOK) && /* and not involved in OOK hack? */
+ (!(flags & SV_NOSTEAL)) &&
+ /* and we're allowed to steal temps */
SvREFCNT(sstr) == 1 && /* and no other references to it? */
SvLEN(sstr) && /* and really is a string */
/* and won't be needed again, potentially */
SvIVX(dstr) = SvIVX(sstr);
}
if (SvVOK(sstr)) {
- MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
+ MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
sv_magic(dstr, NULL, PERL_MAGIC_vstring,
smg->mg_ptr, smg->mg_len);
SvRMAGICAL_on(dstr);
- }
+ }
}
else if (sflags & SVp_IOK) {
if (sflags & SVf_IOK)
=for apidoc sv_setpvn
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>.
+bytes to be copied. If the C<ptr> argument is NULL the SV will become
+undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
=cut
*/
if (len) { /* this SV was SvIsCOW_normal(sv) */
/* we need to find the SV pointing to us. */
SV *current = SV_COW_NEXT_SV(after);
-
+
if (current == sv) {
/* The SV we point to points back to us (there were only two of us
in the loop.)
{
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
- return SvOOK_off(sv);
+ SvOOK_off(sv);
+ return 0;
}
#endif
/*
/* Same SvOOK_on but SvOOK_on does a SvIOK_off
and we do that anyway inside the SvNIOK_off
*/
- SvFLAGS(sv) |= SVf_OOK;
+ SvFLAGS(sv) |= SVf_OOK;
}
SvNIOK_off(sv);
SvLEN(sv) -= delta;
=for apidoc sv_magicext
Adds magic to an SV, upgrading it if necessary. Applies the
-supplied vtable and returns pointer to the magic added.
+supplied vtable and returns a pointer to the magic added.
-Note that sv_magicext will allow things that sv_magic will not.
-In particular you can add magic to SvREADONLY SVs and and more than
-one instance of the same 'how'
+Note that C<sv_magicext> will allow things that C<sv_magic> will not.
+In particular, you can add magic to SvREADONLY SVs, and add more than
+one instance of the same 'how'.
-I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
-if C<namelen> is zero then C<name> is stored as-is and - as another special
-case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
-an C<SV*> and has its REFCNT incremented
+If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
+stored, if C<namlen> is zero then C<name> is stored as-is and - as another
+special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
+to contain an C<SV*> and is stored as-is with its REFCNT incremented.
-(This is now used as a subroutine by sv_magic.)
+(This is now used as a subroutine by C<sv_magic>.)
=cut
*/
mg->mg_moremagic = SvMAGIC(sv);
SvMAGIC(sv) = mg;
- /* Some magic sontains a reference loop, where the sv and object refer to
- each other. To prevent a reference loop that would prevent such
- objects being freed, we look for such loops and if we find one we
- avoid incrementing the object refcount.
+ /* Sometimes a magic contains a reference loop, where the sv and
+ object refer to each other. To prevent a reference loop that
+ would prevent such objects being freed, we look for such loops
+ and if we find one we avoid incrementing the object refcount.
Note we cannot do this to avoid self-tie loops as intervening RV must
have its REFCNT incremented to keep it in existence.
Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
then adds a new magic item of type C<how> to the head of the magic list.
+See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
+handling of the C<name> and C<namlen> arguments.
+
+You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
+to add more than one instance of the same 'how'.
+
=cut
*/
PUSHs(tmpref);
PUTBACK;
call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
-
-
+
+
POPSTACK;
SPAGAIN;
LEAVE;
case SVt_PVNV:
case SVt_PVIV:
freescalar:
- (void)SvOOK_off(sv);
+ SvOOK_off(sv);
/* FALL THROUGH */
case SVt_PV:
case SVt_RV:
* The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
* mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
* (Note that the mg_len is not the length of the mg_ptr field.)
- *
+ *
*/
STRLEN
STATIC bool
S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
{
- bool found = FALSE;
+ bool found = FALSE;
if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
if (!*mgp)
*cachep = (STRLEN *) (*mgp)->mg_ptr;
ASSERT_UTF8_CACHE(*cachep);
if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
- found = TRUE;
+ found = TRUE;
else { /* We will skip to the right spot. */
STRLEN forw = 0;
STRLEN backw = 0;
(*cachep)[2] = 0;
(*cachep)[3] = 0;
}
-
+
found = TRUE;
}
}
return found;
}
-
+
/*
=for apidoc sv_pos_u2b
/* We already know part of the way. */
len = cache[0];
s += cache[1];
- /* Let the below loop do the rest. */
+ /* Let the below loop do the rest. */
}
else { /* cache[1] > *offsetp */
/* We already know all of the way, now we may
if (!(forw < 2 * backw)) {
U8 *p = s + cache[1];
STRLEN ubackw = 0;
-
+
cache[1] -= backw;
while (backw--) {
pv1 = SvPV(svrecode, cur1);
}
/* Now both are in UTF-8. */
- if (cur1 != cur2)
+ if (cur1 != cur2) {
+ SvREFCNT_dec(svrecode);
return FALSE;
+ }
}
else {
bool is_utf8 = TRUE;
}
if (is_utf8) {
/* Downgrade not possible - cannot be eq */
+ assert (tpv == 0);
return FALSE;
}
}
rslen = 1;
}
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
+ /* 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)
*/
Stat_t st;
cnt = PerlIO_get_cnt(fp); /* get count into register */
/* make sure we have the room */
- if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
+ if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
/* Not room for all of it
- if we are looking for a separator and room for some
+ if we are looking for a separator and room for some
*/
if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
- /* just process what we have room for */
+ /* just process what we have room for */
shortbuffered = cnt - SvLEN(sv) + append + 1;
cnt -= shortbuffered;
}
SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
}
}
- else
+ else
shortbuffered = 0;
bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
ptr = (STDCHAR*)PerlIO_get_ptr(fp);
Marks an existing SV as mortal. The SV will be destroyed "soon", either
by an explicit call to FREETMPS, or by an implicit call at places such as
-statement boundaries. See also C<sv_newmortal> and C<sv_mortalcopy>.
+statement boundaries. SvTEMP() is turned on which means that the SV's
+string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
+and C<sv_mortalcopy>.
=cut
*/
Creates a new SV and copies a string into it. The reference count for the
SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
string. You are responsible for ensuring that the source string is at least
-C<len> bytes long.
+C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
=cut
*/
return Nullsv;
}
new_SV(sv);
- if (SvTEMP(old)) {
- SvTEMP_off(old);
- sv_setsv(sv,old);
- SvTEMP_on(old);
- }
- else
- sv_setsv(sv,old);
+ /* SV_GMAGIC is the default for sv_setv()
+ SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
+ with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
+ sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
return sv;
}
sv_unref(sv);
continue;
}
- (void)SvOK_off(sv);
+ SvOK_off(sv);
if (SvTYPE(sv) >= SVt_PV) {
SvCUR_set(sv, 0);
if (SvPVX(sv) != Nullch)
{
IO* io;
GV* gv;
- STRLEN n_a;
switch (SvTYPE(sv)) {
case SVt_PVIO:
Perl_croak(aTHX_ PL_no_usym, "filehandle");
if (SvROK(sv))
return sv_2io(SvRV(sv));
- gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
+ gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
if (gv)
io = GvIO(gv);
else
{
GV *gv = Nullgv;
CV *cv = Nullcv;
- STRLEN n_a;
if (!sv)
return *gvp = Nullgv, Nullcv;
else if (isGV(sv))
gv = (GV*)sv;
else
- gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
+ gv = gv_fetchsv(sv, lref, SVt_PVCV);
*gvp = gv;
if (!gv)
return Nullcv;
Perl_sv_reftype(pTHX_ SV *sv, int ob)
{
if (ob && SvOBJECT(sv)) {
- if (HvNAME(SvSTASH(sv)))
- return HvNAME(SvSTASH(sv));
- else
- return "__ANON__";
+ char *name = HvNAME(SvSTASH(sv));
+ return name ? name : "__ANON__";
}
else {
switch (SvTYPE(sv)) {
if (SvTYPE(rv) < SVt_RV)
sv_upgrade(rv, SVt_RV);
else if (SvTYPE(rv) > SVt_RV) {
- (void)SvOOK_off(rv);
+ SvOOK_off(rv);
if (SvPVX(rv) && SvLEN(rv))
Safefree(SvPVX(rv));
SvCUR_set(rv, 0);
SvLEN_set(rv, 0);
}
- (void)SvOK_off(rv);
+ SvOK_off(rv);
SvRV(rv) = sv;
SvROK_on(rv);
string must be specified with C<n>. The C<rv> argument will be upgraded to
an RV. That RV will be modified to point to 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 have a reference count
+C<Nullch> to avoid the blessing. The new SV will have a reference count
of 1, and the RV will be returned.
Note that C<sv_setref_pv> copies the pointer while this copies the string.
/*
=for apidoc sv_setpvf
-Processes its arguments like C<sprintf> and sets an SV to the formatted
-output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
+Works like C<sv_catpvf> but copies the text into the SV instead of
+appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
=cut
*/
va_end(args);
}
-/* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
+/*
+=for apidoc sv_vsetpvf
+
+Works like C<sv_vcatpvf> but copies the text into the SV instead of
+appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
+
+Usually used via its frontend C<sv_setpvf>.
+
+=cut
+*/
void
Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
va_end(args);
}
-/* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
+/*
+=for apidoc sv_vsetpvf_mg
+
+Like C<sv_vsetpvf>, but also handles 'set' magic.
+
+Usually used via its frontend C<sv_setpvf_mg>.
+
+=cut
+*/
void
Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
output to an SV. If the appended data contains "wide" characters
(including, but not limited to, SVs with a UTF-8 PV formatted with %s,
and characters >255 formatted with %c), the original SV might get
-upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
-C<SvSETMAGIC()> must typically be called after calling this function
-to handle 'set' magic.
+upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
+C<sv_catpvf_mg>.
=cut */
va_end(args);
}
-/* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
+/*
+=for apidoc sv_vcatpvf
+
+Processes its arguments like C<vsprintf> and appends the formatted output
+to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
+
+Usually used via its frontend C<sv_catpvf>.
+
+=cut
+*/
void
Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
va_end(args);
}
-/* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
+/*
+=for apidoc sv_vcatpvf_mg
+
+Like C<sv_vcatpvf>, but also handles 'set' magic.
+
+Usually used via its frontend C<sv_catpvf_mg>.
+
+=cut
+*/
void
Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
/*
=for apidoc sv_vsetpvfn
-Works like C<vcatpvfn> but copies the text into the SV instead of
+Works like C<sv_vcatpvfn> but copies the text into the SV instead of
appending it.
-Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
+Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
=cut
*/
C<maybe_tainted> if results are untrustworthy (often due to the use of
locales).
-Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
+Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
=cut
*/
}
if (!asterisk)
- if( *q == '0' )
+ if( *q == '0' )
fill = *q++;
EXPECT_NUMBER(q, width);
+#ifdef CHECK_FORMAT
+ if ((*q == 'p') && left) {
+ vectorize = (width == 1);
+ }
+#endif
if (vectorize) {
if (vectorarg) {
if (args)
vecsv = svargs[efix ? efix-1 : svix++];
vecstr = (U8*)SvPVx(vecsv,veclen);
vec_utf8 = DO_UTF8(vecsv);
+ /* if this is a version object, we need to return the
+ * stringified representation (which the SvPVX has
+ * already done for us), but not vectorize the args
+ */
+ if ( *q == 'd' && sv_derived_from(vecsv,"version") )
+ {
+ q++; /* skip past the rest of the %vd format */
+ eptr = (char *) vecstr;
+ elen = strlen(eptr);
+ vectorize=FALSE;
+ goto string;
+ }
}
else {
vecstr = (U8*)"";
goto string;
case '_':
+#ifdef CHECK_FORMAT
+ format_sv:
+#endif
/*
* The "%_" hack might have to be changed someday,
* if ISO or ANSI decide to use '_' for something.
/* INTEGERS */
case 'p':
+#ifdef CHECK_FORMAT
+ if (left) {
+ left = FALSE;
+ if (!width)
+ goto format_sv; /* %-p -> %_ */
+ if (vectorize) {
+ width = 0;
+ goto format_d; /* %-1p -> %vd */
+ }
+ precis = width;
+ has_precis = TRUE;
+ width = 0;
+ goto format_sv; /* %-Np -> %.N_ */
+ }
+#endif
if (alt || vectorize)
goto unknown;
uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
#else
intsize = 'l';
#endif
+#ifdef CHECK_FORMAT
+ format_d:
+#endif
/* FALL THROUGH */
case 'd':
case 'i':
p = SvEND(sv);
*p = '\0';
}
- /* Use memchr() instead of strchr(), as eptr is not guaranteed */
- /* to point to a null-terminated string. */
- if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) &&
- (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF))
- Perl_warner(aTHX_ packWARN(WARN_PRINTF),
- "Newline in left-justified string for %sprintf",
- (PL_op->op_type == OP_PRTF) ? "" : "s");
-
+
need = (have > width ? have : width);
gap = need - have;
case 'o':
/* Compiled op trees are readonly, and can thus be
shared without duplication. */
+ OP_REFCNT_LOCK;
d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
+ OP_REFCNT_UNLOCK;
break;
case 'n':
d->data[i] = r->data->data[i];
IoPAGE(dstr) = IoPAGE(sstr);
IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
- if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
+ if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
/* I have no idea why fake dirp (rsfps)
should be treaded differently but otherwise
we end up with leaks -- sky*/
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
CvSTART(dstr) = CvSTART(sstr);
+ OP_REFCNT_LOCK;
CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
+ OP_REFCNT_UNLOCK;
CvXSUB(dstr) = CvXSUB(sstr);
CvXSUBANY(dstr) = CvXSUBANY(sstr);
if (CvCONST(sstr)) {
else {
ncx->blk_oldsp = cx->blk_oldsp;
ncx->blk_oldcop = cx->blk_oldcop;
- ncx->blk_oldretsp = cx->blk_oldretsp;
ncx->blk_oldmarksp = cx->blk_oldmarksp;
ncx->blk_oldscopesp = cx->blk_oldscopesp;
ncx->blk_oldpm = cx->blk_oldpm;
ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
ncx->blk_sub.lval = cx->blk_sub.lval;
+ ncx->blk_sub.retop = cx->blk_sub.retop;
break;
case CXt_EVAL:
ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
+ ncx->blk_eval.retop = cx->blk_eval.retop;
break;
case CXt_LOOP:
ncx->blk_loop.label = cx->blk_loop.label;
ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
+ ncx->blk_sub.retop = cx->blk_sub.retop;
break;
case CXt_BLOCK:
case CXt_NULL:
perl_clone takes these flags as parameters:
-CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
-without it we only clone the data and zero the stacks,
-with it we copy the stacks and the new perl interpreter is
-ready to run at the exact same point as the previous one.
-The pseudo-fork code uses COPY_STACKS while the
+CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
+without it we only clone the data and zero the stacks,
+with it we copy the stacks and the new perl interpreter is
+ready to run at the exact same point as the previous one.
+The pseudo-fork code uses COPY_STACKS while the
threads->new doesn't.
CLONEf_KEEP_PTR_TABLE
-perl_clone keeps a ptr_table with the pointer of the old
-variable as a key and the new variable as a value,
-this allows it to check if something has been cloned and not
-clone it again but rather just use the value and increase the
-refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
-the ptr_table using the function
-C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
-reason to keep it around is if you want to dup some of your own
-variable who are outside the graph perl scans, example of this
+perl_clone keeps a ptr_table with the pointer of the old
+variable as a key and the new variable as a value,
+this allows it to check if something has been cloned and not
+clone it again but rather just use the value and increase the
+refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
+the ptr_table using the function
+C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
+reason to keep it around is if you want to dup some of your own
+variable who are outside the graph perl scans, example of this
code is in threads.xs create
CLONEf_CLONE_HOST
-This is a win32 thing, it is ignored on unix, it tells perls
-win32host code (which is c++) to clone itself, this is needed on
-win32 if you want to run two threads at the same time,
-if you just want to do some stuff in a separate perl interpreter
-and then throw it away and return to the original one,
+This is a win32 thing, it is ignored on unix, it tells perls
+win32host code (which is c++) to clone itself, this is needed on
+win32 if you want to run two threads at the same time,
+if you just want to do some stuff in a separate perl interpreter
+and then throw it away and return to the original one,
you don't need to do anything.
=cut
PL_savestack = 0;
PL_savestack_ix = 0;
PL_savestack_max = -1;
- PL_retstack = 0;
PL_sig_pending = 0;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# else /* !DEBUGGING */
PL_savestack = 0;
PL_savestack_ix = 0;
PL_savestack_max = -1;
- PL_retstack = 0;
PL_sig_pending = 0;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# else /* !DEBUGGING */
SvANY(&PL_sv_no) = new_XPVNV();
SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
- SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
+ SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+ |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
SvCUR(&PL_sv_no) = 0;
SvLEN(&PL_sv_no) = 1;
+ SvIVX(&PL_sv_no) = 0;
SvNVX(&PL_sv_no) = 0;
ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
SvANY(&PL_sv_yes) = new_XPVNV();
SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
- SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
+ SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
+ |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
SvCUR(&PL_sv_yes) = 1;
SvLEN(&PL_sv_yes) = 2;
+ SvIVX(&PL_sv_yes) = 1;
SvNVX(&PL_sv_yes) = 1;
ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
Newz(54, PL_scopestack, PL_scopestack_max, I32);
Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
- /* next push_return() sets PL_retstack[PL_retstack_ix]
- * NOTE: unlike the others! */
- PL_retstack_ix = proto_perl->Tretstack_ix;
- PL_retstack_max = proto_perl->Tretstack_max;
- Newz(54, PL_retstack, PL_retstack_max, OP*);
- Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
-
/* NOTE: si_dup() looks at PL_markstack */
PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
PL_dirty = proto_perl->Tdirty;
PL_localizing = proto_perl->Tlocalizing;
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- PL_protect = proto_perl->Tprotect;
-#endif
PL_errors = sv_dup_inc(proto_perl->Terrors, param);
PL_hv_fetch_ent_mh = Nullhe;
PL_modcount = proto_perl->Tmodcount;
EXTEND(SP, 3);
XPUSHs(encoding);
XPUSHs(sv);
-/*
+/*
NI-S 2002/07/09
Passing sv_yes is wrong - it needs to be or'ed set of constants
- for Encode::XS, while UTf-8 decode (currently) assumes a true value means
+ for Encode::XS, while UTf-8 decode (currently) assumes a true value means
remove converted chars from source.
Both will default the value - let them.
-
+
XPUSHs(&PL_sv_yes);
*/
PUTBACK;
FREETMPS;
LEAVE;
SvUTF8_on(sv);
+ return SvPVX(sv);
}
- return SvPVX(sv);
+ return SvPOKp(sv) ? SvPVX(sv) : NULL;
}
/*
return ret;
}
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * vim: expandtab shiftwidth=4:
+*/
https://perl5.git.perl.org / perl5.git / blobdiff