# define ASSERT_UTF8_CACHE(cache) NOOP
#endif
-#ifdef PERL_OLD_COPY_ON_WRITE
-#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
-#define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
-#endif
-
/* ============================================================================
=head1 Allocation and deallocation of SVs.
It croaks if the SV is already in a more complex form than requested. You
generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
before calling C<sv_upgrade>, and hence does not croak. See also
-C<svtype>.
+C<L</svtype>>.
=cut
*/
no route from NV to PVIV, NOK can never be true */
assert(!SvNOKp(sv));
assert(!SvNOK(sv));
+ /* FALLTHROUGH */
case SVt_PVIO:
case SVt_PVFM:
case SVt_PVGV:
=cut
*/
-int
+/* prior to 5.000 stable, this function returned the new OOK-less SvFLAGS
+ prior to 5.23.4 this function always returned 0
+*/
+
+void
Perl_sv_backoff(SV *const sv)
{
STRLEN delta;
SvLEN_set(sv, SvLEN(sv) + delta);
SvPV_set(sv, SvPVX(sv) - delta);
- Move(s, SvPVX(sv), SvCUR(sv)+1, char);
SvFLAGS(sv) &= ~SVf_OOK;
- return 0;
+ Move(s, SvPVX(sv), SvCUR(sv)+1, char);
+ return;
}
/*
s = SvPVX_mutable(sv);
}
-#ifdef PERL_NEW_COPY_ON_WRITE
+#ifdef PERL_COPY_ON_WRITE
/* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
* to store the COW count. So in general, allocate one more byte than
* asked for, to make it likely this byte is always spare: and thus
=for apidoc sv_setiv
Copies an integer into the given SV, upgrading first if necessary.
-Does not handle 'set' magic. See also C<sv_setiv_mg>.
+Does not handle 'set' magic. See also C<L</sv_setiv_mg>>.
=cut
*/
/* diag_listed_as: Can't coerce %s to %s in %s */
Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
OP_DESC(PL_op));
+ break;
default: NOOP;
}
(void)SvIOK_only(sv); /* validate number */
=for apidoc sv_setuv
Copies an unsigned integer into the given SV, upgrading first if necessary.
-Does not handle 'set' magic. See also C<sv_setuv_mg>.
+Does not handle 'set' magic. See also C<L</sv_setuv_mg>>.
=cut
*/
=for apidoc sv_setnv
Copies a double into the given SV, upgrading first if necessary.
-Does not handle 'set' magic. See also C<sv_setnv_mg>.
+Does not handle 'set' magic. See also C<L</sv_setnv_mg>>.
=cut
*/
/* diag_listed_as: Can't coerce %s to %s in %s */
Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
OP_DESC(PL_op));
+ break;
default: NOOP;
}
SvNV_set(sv, num);
if (DO_UTF8(sv)) {
SV *dsv = newSVpvs_flags("", SVs_TEMP);
- pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
+ pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT);
} else {
char *d = tmpbuf;
const char * const limit = tmpbuf + tmpbuf_size - 8;
Test if the content of an SV looks like a number (or is a number).
C<Inf> and C<Infinity> are treated as numbers (so will not issue a
-non-numeric warning), even if your atof() doesn't grok them. Get-magic is
+non-numeric warning), even if your C<atof()> doesn't grok them. Get-magic is
ignored.
=cut
=for apidoc sv_2iv_flags
Return the integer value of an SV, doing any necessary string
-conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
=cut
}
if (SvTHINKFIRST(sv)) {
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
-#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
=for apidoc sv_2uv_flags
Return the unsigned integer value of an SV, doing any necessary string
-conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
=cut
}
if (SvTHINKFIRST(sv)) {
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
-#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
=for apidoc sv_2nv_flags
Return the num value of an SV, doing any necessary string or integer
-conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
=cut
}
return PTR2NV(SvRV(sv));
}
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
-#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
/* Helper for sv_2pv_flags and sv_vcatpvfn_flags. If the NV is an
* infinity or a not-a-number, writes the appropriate strings to the
* buffer, including a zero byte. On success returns the written length,
- * excluding the zero byte, on failure (not an infinity, not a nan, or the
- * maxlen too small) returns zero.
+ * excluding the zero byte, on failure (not an infinity, not a nan)
+ * returns zero, assert-fails on maxlen being too short.
*
* XXX for "Inf", "-Inf", and "NaN", we could have three read-only
* shared string constants we point to, instead of generating a new
* string for each instance. */
STATIC size_t
S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
+ char* s = buffer;
assert(maxlen >= 4);
- if (maxlen < 4) /* "Inf\0", "NaN\0" */
- return 0;
- else {
- char* s = buffer;
- if (Perl_isinf(nv)) {
- if (nv < 0) {
- if (maxlen < 5) /* "-Inf\0" */
- return 0;
- *s++ = '-';
- } else if (plus) {
- *s++ = '+';
- }
- *s++ = 'I';
- *s++ = 'n';
- *s++ = 'f';
- } else if (Perl_isnan(nv)) {
- *s++ = 'N';
- *s++ = 'a';
- *s++ = 'N';
- /* XXX optionally output the payload mantissa bits as
- * "(unsigned)" (to match the nan("...") C99 function,
- * or maybe as "(0xhhh...)" would make more sense...
- * provide a format string so that the user can decide?
- * NOTE: would affect the maxlen and assert() logic.*/
+ if (Perl_isinf(nv)) {
+ if (nv < 0) {
+ if (maxlen < 5) /* "-Inf\0" */
+ return 0;
+ *s++ = '-';
+ } else if (plus) {
+ *s++ = '+';
}
-
- else
- return 0;
- assert((s == buffer + 3) || (s == buffer + 4));
- *s++ = 0;
- return s - buffer - 1; /* -1: excluding the zero byte */
+ *s++ = 'I';
+ *s++ = 'n';
+ *s++ = 'f';
+ }
+ else if (Perl_isnan(nv)) {
+ *s++ = 'N';
+ *s++ = 'a';
+ *s++ = 'N';
+ /* XXX optionally output the payload mantissa bits as
+ * "(unsigned)" (to match the nan("...") C99 function,
+ * or maybe as "(0xhhh...)" would make more sense...
+ * provide a format string so that the user can decide?
+ * NOTE: would affect the maxlen and assert() logic.*/
+ }
+ else {
+ return 0;
}
+ assert((s == buffer + 3) || (s == buffer + 4));
+ *s++ = 0;
+ return s - buffer - 1; /* -1: excluding the zero byte */
}
/*
=for apidoc sv_2pv_flags
-Returns a pointer to the string value of an SV, and sets *lp to its length.
-If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a
+Returns a pointer to the string value of an SV, and sets C<*lp> to its length.
+If flags has the C<SV_GMAGIC> bit set, does an C<mg_get()> first. Coerces C<sv> to a
string if necessary. Normally invoked via the C<SvPV_flags> macro.
C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
#else
{
bool local_radix;
- DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
local_radix =
PL_numeric_local &&
=for apidoc sv_copypv
Copies a stringified representation of the source SV into the
-destination SV. Automatically performs any necessary mg_get and
+destination SV. Automatically performs any necessary C<mg_get> and
coercion of numeric values into strings. Guaranteed to preserve
-UTF8 flag even from overloaded objects. Similar in nature to
-sv_2pv[_flags] but operates directly on an SV instead of just the
-string. Mostly uses sv_2pv_flags to do its work, except when that
+C<UTF8> flag even from overloaded objects. Similar in nature to
+C<sv_2pv[_flags]> but operates directly on an SV instead of just the
+string. Mostly uses C<sv_2pv_flags> to do its work, except when that
would lose the UTF-8'ness of the PV.
=for apidoc sv_copypv_nomg
-Like sv_copypv, but doesn't invoke get magic first.
+Like C<sv_copypv>, but doesn't invoke get magic first.
=for apidoc sv_copypv_flags
-Implementation of sv_copypv and sv_copypv_nomg. Calls get magic iff flags
-include SV_GMAGIC.
+Implementation of C<sv_copypv> and C<sv_copypv_nomg>. Calls get magic iff flags
+has the C<SV_GMAGIC> bit set.
=cut
*/
/*
=for apidoc sv_2pvbyte
-Return a pointer to the byte-encoded representation of the SV, and set *lp
+Return a pointer to the byte-encoded representation of the SV, and set C<*lp>
to its length. May cause the SV to be downgraded from UTF-8 as a
side-effect.
/*
=for apidoc sv_2pvutf8
-Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
+Return a pointer to the UTF-8-encoded representation of the SV, and set C<*lp>
to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
Usually accessed via the C<SvPVutf8> macro.
/*
=for apidoc sv_2bool
-This macro is only used by sv_true() or its macro equivalent, and only if
-the latter's argument is neither SvPOK, SvIOK nor SvNOK.
-It calls sv_2bool_flags with the SV_GMAGIC flag.
+This macro is only used by C<sv_true()> or its macro equivalent, and only if
+the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.
+It calls C<sv_2bool_flags> with the C<SV_GMAGIC> flag.
=for apidoc sv_2bool_flags
-This function is only used by sv_true() and friends, and only if
-the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
-contain SV_GMAGIC, then it does an mg_get() first.
+This function is only used by C<sv_true()> and friends, and only if
+the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>. If the flags
+contain C<SV_GMAGIC>, then it does an C<mg_get()> first.
=cut
Converts the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Will C<mg_get> on C<sv> if appropriate.
-Always sets the SvUTF8 flag to avoid future validity checks even
+Always sets the C<SvUTF8> flag to avoid future validity checks even
if the whole string is the same in UTF-8 as not.
Returns the number of bytes in the converted string
=for apidoc sv_utf8_upgrade_nomg
-Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
+Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>.
=for apidoc sv_utf8_upgrade_flags
If C<flags> has C<SV_GMAGIC> bit set,
will C<mg_get> on C<sv> if appropriate, else not.
-If C<flags> has SV_FORCE_UTF8_UPGRADE set, this function assumes that the PV
+If C<flags> has C<SV_FORCE_UTF8_UPGRADE> set, this function assumes that the PV
will expand when converted to UTF-8, and skips the extra work of checking for
that. Typically this flag is used by a routine that has already parsed the
string and found such characters, and passes this information on so that the
=for apidoc sv_utf8_upgrade_flags_grow
-Like sv_utf8_upgrade_flags, but has an additional parameter C<extra>, which is
-the number of unused bytes the string of 'sv' is guaranteed to have free after
+Like C<sv_utf8_upgrade_flags>, but has an additional parameter C<extra>, which is
+the number of unused bytes the string of C<sv> is guaranteed to have free after
it upon return. This allows the caller to reserve extra space that it intends
to fill, to avoid extra grows.
true, croaks.
This is not a general purpose Unicode to byte encoding interface:
-use the Encode extension for that.
+use the C<Encode> extension for that.
=cut
*/
If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
C<ssv> if appropriate, else not. If the C<flags>
parameter has the C<SV_NOSTEAL> bit set then the
-buffers of temps will not be stolen. <sv_setsv>
+buffers of temps will not be stolen. C<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
SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
}
+ /* freeing dstr's GP might free sstr (e.g. *x = $x),
+ * so temporarily protect it */
+ ENTER;
+ SAVEFREESV(SvREFCNT_inc_simple_NN(sstr));
gp_free(MUTABLE_GV(dstr));
GvINTRO_off(dstr); /* one-shot flag */
GvGP_set(dstr, gp_ref(GvGP(sstr)));
+ LEAVE;
+
if (SvTAINTED(sstr))
SvTAINT(dstr);
if (GvIMPORTED(dstr) != GVf_IMPORTED
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
GvFLAGS(dstr) |= import_flag;
}
- if (import_flag == GVf_IMPORTED_SV) {
- if (intro) {
- save_aliased_sv((GV *)dstr);
- }
- /* Turn off the flag if sref is not referenced elsewhere,
- even by weak refs. (SvRMAGICAL is a pessimistic check for
- back refs.) */
- if (SvREFCNT(sref) <= 2 && !SvRMAGICAL(sref))
- GvALIASED_SV_off(dstr);
- else
- GvALIASED_SV_on(dstr);
- }
+
if (stype == SVt_PVHV) {
const char * const name = GvNAME((GV*)dstr);
const STRLEN len = GvNAMELEN(dstr);
}
else if (flags & SV_COW_SHARED_HASH_KEYS
&&
-#ifdef PERL_OLD_COPY_ON_WRITE
- ( sflags & SVf_IsCOW
- || ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
- && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
- && SvTYPE(sstr) >= SVt_PVIV && len
- )
- )
-#elif defined(PERL_NEW_COPY_ON_WRITE)
+#ifdef PERL_COPY_ON_WRITE
(sflags & SVf_IsCOW
? (!len ||
( (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
#ifdef PERL_ANY_COW
if (!(sflags & SVf_IsCOW)) {
SvIsCOW_on(sstr);
-# ifdef PERL_OLD_COPY_ON_WRITE
- /* Make the source SV into a loop of 1.
- (about to become 2) */
- SV_COW_NEXT_SV_SET(sstr, sstr);
-# else
CowREFCNT(sstr) = 0;
-# endif
}
#endif
if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
#ifdef PERL_ANY_COW
if (len) {
-# ifdef PERL_OLD_COPY_ON_WRITE
- assert (SvTYPE(dstr) >= SVt_PVIV);
- /* SvIsCOW_normal */
- /* splice us in between source and next-after-source. */
- SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
- SV_COW_NEXT_SV_SET(sstr, dstr);
-# else
if (sflags & SVf_IsCOW) {
sv_buf_to_rw(sstr);
}
CowREFCNT(sstr)++;
-# endif
SvPV_set(dstr, SvPVX_mutable(sstr));
sv_buf_to_ro(sstr);
} else
}
#ifdef PERL_ANY_COW
-# ifdef PERL_OLD_COPY_ON_WRITE
-# define SVt_COW SVt_PVIV
-# else
# define SVt_COW SVt_PV
-# endif
SV *
Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
{
STRLEN cur = SvCUR(sstr);
STRLEN len = SvLEN(sstr);
char *new_pv;
-#if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE)
+#if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_COPY_ON_WRITE)
const bool already = cBOOL(SvIsCOW(sstr));
#endif
assert (SvPOK(sstr));
assert (SvPOKp(sstr));
-# ifdef PERL_OLD_COPY_ON_WRITE
- assert (!SvIOK(sstr));
- assert (!SvIOKp(sstr));
- assert (!SvNOK(sstr));
- assert (!SvNOKp(sstr));
-# endif
if (SvIsCOW(sstr)) {
new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
goto common_exit;
}
-# ifdef PERL_OLD_COPY_ON_WRITE
- SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
-# else
assert(SvCUR(sstr)+1 < SvLEN(sstr));
assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
-# endif
} else {
assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
SvUPGRADE(sstr, SVt_COW);
SvIsCOW_on(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
"Fast copy on write: Converting sstr to COW\n"));
-# ifdef PERL_OLD_COPY_ON_WRITE
- SV_COW_NEXT_SV_SET(dstr, sstr);
-# else
CowREFCNT(sstr) = 0;
-# endif
}
-# ifdef PERL_OLD_COPY_ON_WRITE
- SV_COW_NEXT_SV_SET(sstr, dstr);
-# else
# ifdef PERL_DEBUG_READONLY_COW
if (already) sv_buf_to_rw(sstr);
# endif
CowREFCNT(sstr)++;
-# endif
new_pv = SvPVX_mutable(sstr);
sv_buf_to_ro(sstr);
Copies a string (possibly containing embedded C<NUL> characters) into an SV.
The C<len> parameter indicates the number of
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>.
+undefined. Does not handle 'set' magic. See C<L</sv_setpvn_mg>>.
=cut
*/
Copies a string into an SV. The string must be terminated with a C<NUL>
character.
-Does not handle 'set' magic. See C<sv_setpv_mg>.
+Does not handle 'set' magic. See C<L</sv_setpv_mg>>.
=cut
*/
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 L<Newx|perlclib/Memory Management and String Handling>. It must be
-the start of a Newx-ed block of memory, and not a pointer to the
-middle of it (beware of L<OOK|perlguts/Offsets> and copy-on-write),
-and not be from a non-Newx memory allocator like C<malloc>. The
+outside string. C<ptr> should point to memory that was allocated
+by L<C<Newx>|perlclib/Memory Management and String Handling>. It must be
+the start of a C<Newx>-ed block of memory, and not a pointer to the
+middle of it (beware of L<C<OOK>|perlguts/Offsets> and copy-on-write),
+and not be from a non-C<Newx> memory allocator like C<malloc>. The
string length, C<len>, must be supplied. By default this function
will C<Renew> (i.e. realloc, 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"
+giving it to C<sv_usepvn>, and neither should any pointers from "behind"
that pointer (e.g. ptr + 1) be used.
-If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
-SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be C<NUL>, and the realloc
+If S<C<flags & SV_SMAGIC>> is true, will call C<SvSETMAGIC>. If
+S<C<flags> & SV_HAS_TRAILING_NUL>> is true, then C<ptr[len]> must be C<NUL>,
+and the realloc
will be skipped (i.e. the buffer is actually at least 1 byte longer than
C<len>, and already meets the requirements for storing in C<SvPVX>).
SvSETMAGIC(sv);
}
-#ifdef PERL_OLD_COPY_ON_WRITE
-/* Need to do this *after* making the SV normal, as we need the buffer
- pointer to remain valid until after we've copied it. If we let go too early,
- another thread could invalidate it by unsharing last of the same hash key
- (which it can do by means other than releasing copy-on-write Svs)
- or by changing the other copy-on-write SVs in the loop. */
-STATIC void
-S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
-{
- PERL_ARGS_ASSERT_SV_RELEASE_COW;
-
- { /* 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.)
- Hence other SV is no longer copy on write either. */
- SvIsCOW_off(after);
- sv_buf_to_rw(after);
- } else {
- /* We need to follow the pointers around the loop. */
- SV *next;
- while ((next = SV_COW_NEXT_SV(current)) != sv) {
- assert (next);
- current = next;
- /* don't loop forever if the structure is bust, and we have
- a pointer into a closed loop. */
- assert (current != after);
- assert (SvPVX_const(current) == pvx);
- }
- /* Make the SV before us point to the SV after us. */
- SV_COW_NEXT_SV_SET(current, after);
- }
- }
-}
-#endif
/*
=for apidoc sv_force_normal_flags
Undo various types of fakery on an SV, where fakery means
"more than" a string: if the PV is a shared string, make
a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
-an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
+an C<xpvmg>; if we're a copy-on-write scalar, this is the on-write time when
we do the copy, and is also used locally; if this is a
vstring, drop the vstring magic. If C<SV_COW_DROP_PV> is set
then a copy-on-write scalar drops its PV buffer (if any) and becomes
-SvPOK_off rather than making a copy. (Used where this
+C<SvPOK_off> rather than making a copy. (Used where this
scalar is about to be set to some other value.) In addition,
the C<flags> parameter gets passed to C<sv_unref_flags()>
when unreffing. C<sv_force_normal> calls this function
const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvLEN(sv);
const STRLEN cur = SvCUR(sv);
-# ifdef PERL_OLD_COPY_ON_WRITE
- /* next COW sv in the loop. If len is 0 then this is a shared-hash
- key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
- we'll fail an assertion. */
- SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
-# endif
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log,
sv_dump(sv);
}
SvIsCOW_off(sv);
-# ifdef PERL_NEW_COPY_ON_WRITE
+# ifdef PERL_COPY_ON_WRITE
if (len) {
/* Must do this first, since the CowREFCNT uses SvPVX and
we need to write to CowREFCNT, or de-RO the whole buffer if we are
*SvEND(sv) = '\0';
}
if (len) {
-# ifdef PERL_OLD_COPY_ON_WRITE
- sv_release_COW(sv, pvx, next);
-# endif
} else {
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
=for apidoc sv_chop
Efficient removal of characters from the beginning of the string buffer.
-
SvPOK(sv), or at least SvPOKp(sv), must be true and the C<ptr> must be a
-pointer to somewhere inside the string buffer.
The C<ptr> becomes the first
-character of the adjusted string. Uses the "OOK hack". On return, only
-SvPOK(sv) and SvPOKp(sv) among the OK flags will be true.
+
C<SvPOK(sv)>, or at least C<SvPOKp(sv)>, must be true and C<ptr> must be a
+pointer to somewhere inside the string buffer. C<ptr> becomes the first
+character of the adjusted string. Uses the C<OOK> hack. On return, only
+C<SvPOK(sv)> and C<SvPOKp(sv)> among the C<OK> flags will be true.
Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
refer to the same chunk of data.
/*
=for apidoc sv_catpvn
-Concatenates the string onto the end of the string which is in the SV. The
+Concatenates the string onto the end of the string which is in the SV.
C<len> indicates number of bytes to copy. If the SV has the UTF-8
status set, then the bytes appended should be valid UTF-8.
-Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
+Handles 'get' magic, but not 'set' magic. See C<L</sv_catpvn_mg>>.
=for apidoc sv_catpvn_flags
Concatenates the string from SV C<ssv> onto the end of the string in SV
C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
-Handles 'get' magic on both SVs, but no 'set' magic. See C<sv_catsv_mg> and
-C<sv_catsv_nomg>.
+Handles 'get' magic on both SVs, but no 'set' magic. See C<L</sv_catsv_mg>>
+and C<L</sv_catsv_nomg>>.
=for apidoc sv_catsv_flags
Concatenates the string from SV C<ssv> onto the end of the string in SV
C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
-If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
-appropriate. If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on
+If C<flags> has the C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
+appropriate. If C<flags> has the C<SV_SMAGIC> bit set, C<mg_set> will be called on
the modified SV afterward, if appropriate. C<sv_catsv>, C<sv_catsv_nomg>,
and C<sv_catsv_mg> are implemented in terms of this function.
Concatenates the C<NUL>-terminated string onto the end of the string which is
in the SV.
If the SV has the UTF-8 status set, then the bytes appended should be
-valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
+valid UTF-8. Handles 'get' magic, but not 'set' magic. See
+C<L</sv_catpv_mg>>.
=cut */
Creates a new SV. A non-zero C<len> parameter indicates the number of
bytes of preallocated string space the SV should have. An extra byte for a
-trailing C<NUL> is also reserved. (SvPOK is not set for the SV even if string
+trailing C<NUL> is also reserved. (C<SvPOK> is not set for the SV even if string
space is allocated.) The reference count for the new SV is set to 1.
-In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
+In 5.9.3, C<newSV()> replaces the older C<NEWSV()> API, and drops the first
parameter, I<x>, a debug aid which allowed callers to identify themselves.
-This aid has been superseded by a new build option, PERL_MEM_LOG (see
+This aid has been superseded by a new build option, C<PERL_MEM_LOG> (see
L<perlhacktips/PERL_MEM_LOG>). The older API is still there for use in XS
modules supporting older perls.
=for apidoc sv_magicext
Adds magic to an SV, upgrading it if necessary. Applies the
-supplied vtable and returns a pointer to the magic added.
+supplied C<vtable> and returns a pointer to the magic added.
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'.
+In particular, you can add magic to C<SvREADONLY> SVs, and add more than
+one instance of the same C<how>.
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.
+to contain an SV* and is stored as-is with its C<REFCNT> incremented.
(This is now used as a subroutine by C<sv_magic>.)
vivify_defelem(sv);
sv = LvTARG(sv);
}
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
-#endif
return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
&PL_vtbl_mglob, 0, 0);
}
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
+See C<L</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'.
+You need to use C<sv_magicext> to add magic to C<SvREADONLY> SVs and also
+to add more than one instance of the same C<how>.
=cut
*/
vtable = (vtable_index == magic_vtable_max)
? NULL : PL_magic_vtables + vtable_index;
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
-#endif
if (SvREADONLY(sv)) {
if (
!PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
mg_magical(sv); /* else fix the flags now */
}
- else {
+ else
SvMAGICAL_off(sv);
- SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
- }
+
return 0;
}
/*
=for apidoc sv_get_backrefs
-If the sv is the target of a weakrefence then return
-the backrefs structure associated with the sv, otherwise
-return NULL.
+If C<sv> is the target of a weak reference then it returns the back
+references structure associated with the sv; otherwise return C<NULL>.
-When returning a non-null result the type of the return
-is relevant. If it is an AV then the contents of the AV
-are the weakrefs which point at this item. If it is any
-other type then the item itself is the weakref.
+When returning a non-null result the type of the return is relevant. If it
+is an AV then the elements of the AV are the weak reference RVs which
+point at this item. If it is any other type then the item itself is the
+weak reference.
-See also Perl_sv_add_backref(), Perl_sv_del_backref(),
-Perl_sv_kill_backrefs()
+See also C<Perl_sv_add_backref()>, C<Perl_sv_del_backref()>,
+C<Perl_sv_kill_backrefs()>
=cut
*/
=for apidoc sv_insert
Inserts a string at the specified offset/length within the SV. Similar to
-the Perl substr() function. Handles get magic.
+the Perl C<substr()> function. Handles get magic.
=for apidoc sv_insert_flags
PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
- if (!bigstr)
- Perl_croak(aTHX_ "Can't modify nonexistent substring");
SvPV_force_flags(bigstr, curlen, flags);
(void)SvPOK_only_UTF8(bigstr);
if (offset + len > curlen) {
}
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW_normal(nsv)) {
- /* We need to follow the pointers around the loop to make the
- previous SV point to sv, rather than nsv. */
- SV *next;
- SV *current = nsv;
- while ((next = SV_COW_NEXT_SV(current)) != nsv) {
- assert(next);
- current = next;
- assert(SvPVX_const(current) == SvPVX_const(nsv));
- }
- /* Make the SV before us point to the SV after us. */
- if (DEBUG_C_TEST) {
- PerlIO_printf(Perl_debug_log, "previous is\n");
- sv_dump(current);
- PerlIO_printf(Perl_debug_log,
- "move it from 0x%"UVxf" to 0x%"UVxf"\n",
- (UV) SV_COW_NEXT_SV(current), (UV) sv);
- }
- SV_COW_NEXT_SV_SET(current, sv);
- }
-#endif
SvREFCNT(sv) = refcnt;
SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
SvREFCNT(nsv) = 0;
and free the body itself. The SV's head is I<not> freed, although
its type is set to all 1's so that it won't inadvertently be assumed
to be live during global destruction etc.
-This function should only be called when REFCNT is zero. Most of the time
+This function should only be called when C<REFCNT> is zero. Most of the time
you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
instead.
SV* iter_sv = NULL;
SV* next_sv = NULL;
SV *sv = orig_sv;
- STRLEN hash_index;
+ STRLEN hash_index = 0; /* initialise to make Coverity et al happy.
+ Not strictly necessary */
PERL_ARGS_ASSERT_SV_CLEAR;
PL_last_swash_hv = NULL;
}
if (HvTOTALKEYS((HV*)sv) > 0) {
- const char *name;
+ const HEK *hek;
/* this statement should match the one at the beginning of
* hv_undef_flags() */
if ( PL_phase != PERL_PHASE_DESTRUCT
- && (name = HvNAME((HV*)sv)))
+ && (hek = HvNAME_HEK((HV*)sv)))
{
if (PL_stashcache) {
- DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
- SVfARG(sv)));
+ DEBUG_o(Perl_deb(aTHX_
+ "sv_clear clearing PL_stashcache for '%"HEKf
+ "'\n",
+ HEKfARG(hek)));
(void)hv_deletehek(PL_stashcache,
- HvNAME_HEK((HV*)sv), G_DISCARD);
+ hek, G_DISCARD);
}
hv_name_set((HV*)sv, NULL, 0, 0);
}
else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
SvREFCNT_dec(LvTARG(sv));
if (isREGEXP(sv)) goto freeregexp;
+ /* FALLTHROUGH */
case SVt_PVGV:
if (isGV_with_GP(sv)) {
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
PL_statgv = NULL;
else if ((const GV *)sv == PL_stderrgv)
PL_stderrgv = NULL;
+ /* FALLTHROUGH */
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
sv_dump(sv);
}
if (SvLEN(sv)) {
-# ifdef PERL_OLD_COPY_ON_WRITE
- sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
-# else
if (CowREFCNT(sv)) {
sv_buf_to_rw(sv);
CowREFCNT(sv)--;
sv_buf_to_ro(sv);
SvLEN_set(sv, 0);
}
-# endif
} else {
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
}
}
-# ifdef PERL_OLD_COPY_ON_WRITE
- else
-# endif
if (SvLEN(sv)) {
Safefree(SvPVX_mutable(sv));
}
Decrement an SV's reference count, and if it drops to zero, call
C<sv_clear> to invoke destructors and free up any memory used by
-the body; finally, deallocate the SV's head itself.
+the body; finally, deallocating the SV's head itself.
Normally called via a wrapper macro C<SvREFCNT_dec>.
=cut
=for apidoc sv_len
Returns the length of the string in the SV. Handles magic and type
-coercion and sets the UTF8 flag appropriately. See also C<SvCUR>, which
-gives raw access to the xpv_cur slot.
+coercion and sets the UTF8 flag appropriately. See also C<L</SvCUR>>, which
+gives raw access to the C<xpv_cur> slot.
=cut
*/
Converts the offset from a count of UTF-8 chars from
the start of the string, to a count of the equivalent number of bytes; if
-lenp is non-zero, it does the same to lenp, but this time starting from
-the offset, rather than from the start
+C<lenp> is non-zero, it does the same to C<lenp>, but this time starting from
+C<offset>, rather than from the start
of the string. Handles type coercion.
-I<flags> is passed to C<SvPV_flags>, and usually should be
+C<flags> is passed to C<SvPV_flags>, and usually should be
C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
=cut
/*
=for apidoc sv_pos_u2b
-Converts the value pointed to by offsetp from a count of UTF-8 chars from
+Converts the value pointed to by C<offsetp> from a count of UTF-8 chars from
the start of the string, to a count of the equivalent number of bytes; if
-lenp is non-zero, it does the same to lenp, but this time starting from
+C<lenp> is non-zero, it does the same to C<lenp>, but this time starting from
the offset, rather than from the start of the string. Handles magic and
type coercion.
/*
=for apidoc sv_pos_b2u_flags
-Converts the offset from a count of bytes from the start of the string, to
+Converts C<offset> from a count of bytes from the start of the string, to
a count of the equivalent number of UTF-8 chars. Handles type coercion.
-I<flags> is passed to C<SvPV_flags>, and usually should be
+C<flags> is passed to C<SvPV_flags>, and usually should be
C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
=cut
/*
=for apidoc sv_pos_b2u
-Converts the value pointed to by offsetp from a count of bytes from the
+Converts the value pointed to by C<offsetp> from a count of bytes from the
start of the string, to a count of the equivalent number of UTF-8 chars.
Handles magic and type coercion.
=for apidoc sv_eq
Returns a boolean indicating whether the strings in the two SVs are
-identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
+identical. Is UTF-8 and S<C<'use bytes'>> aware, handles get magic, and will
coerce its args to strings if necessary.
=for apidoc sv_eq_flags
Returns a boolean indicating whether the strings in the two SVs are
-identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
-if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
+identical. Is UTF-8 and S<C<'use bytes'>> aware and coerces its args to strings
+if necessary. If the flags has the C<SV_GMAGIC> bit set, it handles get-magic, too.
=cut
*/
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>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
-coerce its args to strings if necessary. See also C<sv_cmp_locale>.
+C<sv2>. Is UTF-8 and S<C<'use bytes'>> aware, handles get magic, and will
+coerce its args to strings if necessary. See also C<L</sv_cmp_locale>>.
=for apidoc sv_cmp_flags
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>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
-if necessary. If the flags include SV_GMAGIC, it handles get magic. See
-also C<sv_cmp_locale_flags>.
+C<sv2>. Is UTF-8 and S<C<'use bytes'>> aware and will coerce its args to strings
+if necessary. If the flags has the C<SV_GMAGIC> bit set, it handles get magic. See
+also C<L</sv_cmp_locale_flags>>.
=cut
*/
}
}
+ /* Here, if both are non-NULL, then they have the same UTF8ness. */
+
if (!cur1) {
cmp = cur2 ? -1 : 0;
} else if (!cur2) {
cmp = 1;
} else {
- const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
+ STRLEN shortest_len = cur1 < cur2 ? cur1 : cur2;
- if (retval) {
- cmp = retval < 0 ? -1 : 1;
- } else if (cur1 == cur2) {
- cmp = 0;
- } else {
- cmp = cur1 < cur2 ? -1 : 1;
- }
+#ifdef EBCDIC
+ if (! DO_UTF8(sv1)) {
+#endif
+ const I32 retval = memcmp((const void*)pv1,
+ (const void*)pv2,
+ shortest_len);
+ if (retval) {
+ cmp = retval < 0 ? -1 : 1;
+ } else if (cur1 == cur2) {
+ cmp = 0;
+ } else {
+ cmp = cur1 < cur2 ? -1 : 1;
+ }
+#ifdef EBCDIC
+ }
+ else { /* Both are to be treated as UTF-EBCDIC */
+
+ /* EBCDIC UTF-8 is complicated by the fact that it is based on I8
+ * which remaps code points 0-255. We therefore generally have to
+ * unmap back to the original values to get an accurate comparison.
+ * But we don't have to do that for UTF-8 invariants, as by
+ * definition, they aren't remapped, nor do we have to do it for
+ * above-latin1 code points, as they also aren't remapped. (This
+ * code also works on ASCII platforms, but the memcmp() above is
+ * much faster). */
+
+ const char *e = pv1 + shortest_len;
+
+ /* Find the first bytes that differ between the two strings */
+ while (pv1 < e && *pv1 == *pv2) {
+ pv1++;
+ pv2++;
+ }
+
+
+ if (pv1 == e) { /* Are the same all the way to the end */
+ if (cur1 == cur2) {
+ cmp = 0;
+ } else {
+ cmp = cur1 < cur2 ? -1 : 1;
+ }
+ }
+ else /* Here *pv1 and *pv2 are not equal, but all bytes earlier
+ * in the strings were. The current bytes may or may not be
+ * at the beginning of a character. But neither or both are
+ * (or else earlier bytes would have been different). And
+ * if we are in the middle of a character, the two
+ * characters are comprised of the same number of bytes
+ * (because in this case the start bytes are the same, and
+ * the start bytes encode the character's length). */
+ if (UTF8_IS_INVARIANT(*pv1))
+ {
+ /* If both are invariants; can just compare directly */
+ if (UTF8_IS_INVARIANT(*pv2)) {
+ cmp = ((U8) *pv1 < (U8) *pv2) ? -1 : 1;
+ }
+ else /* Since *pv1 is invariant, it is the whole character,
+ which means it is at the beginning of a character.
+ That means pv2 is also at the beginning of a
+ character (see earlier comment). Since it isn't
+ invariant, it must be a start byte. If it starts a
+ character whose code point is above 255, that
+ character is greater than any single-byte char, which
+ *pv1 is */
+ if (UTF8_IS_ABOVE_LATIN1_START(*pv2))
+ {
+ cmp = -1;
+ }
+ else {
+ /* Here, pv2 points to a character composed of 2 bytes
+ * whose code point is < 256. Get its code point and
+ * compare with *pv1 */
+ cmp = ((U8) *pv1 < EIGHT_BIT_UTF8_TO_NATIVE(*pv2, *(pv2 + 1)))
+ ? -1
+ : 1;
+ }
+ }
+ else /* The code point starting at pv1 isn't a single byte */
+ if (UTF8_IS_INVARIANT(*pv2))
+ {
+ /* But here, the code point starting at *pv2 is a single byte,
+ * and so *pv1 must begin a character, hence is a start byte.
+ * If that character is above 255, it is larger than any
+ * single-byte char, which *pv2 is */
+ if (UTF8_IS_ABOVE_LATIN1_START(*pv1)) {
+ cmp = 1;
+ }
+ else {
+ /* Here, pv1 points to a character composed of 2 bytes
+ * whose code point is < 256. Get its code point and
+ * compare with the single byte character *pv2 */
+ cmp = (EIGHT_BIT_UTF8_TO_NATIVE(*pv1, *(pv1 + 1)) < (U8) *pv2)
+ ? -1
+ : 1;
+ }
+ }
+ else /* Here, we've ruled out either *pv1 and *pv2 being
+ invariant. That means both are part of variants, but not
+ necessarily at the start of a character */
+ if ( UTF8_IS_ABOVE_LATIN1_START(*pv1)
+ || UTF8_IS_ABOVE_LATIN1_START(*pv2))
+ {
+ /* Here, at least one is the start of a character, which means
+ * the other is also a start byte. And the code point of at
+ * least one of the characters is above 255. It is a
+ * characteristic of UTF-EBCDIC that all start bytes for
+ * above-latin1 code points are well behaved as far as code
+ * point comparisons go, and all are larger than all other
+ * start bytes, so the comparison with those is also well
+ * behaved */
+ cmp = ((U8) *pv1 < (U8) *pv2) ? -1 : 1;
+ }
+ else {
+ /* Here both *pv1 and *pv2 are part of variant characters.
+ * They could be both continuations, or both start characters.
+ * (One or both could even be an illegal start character (for
+ * an overlong) which for the purposes of sorting we treat as
+ * legal. */
+ if (UTF8_IS_CONTINUATION(*pv1)) {
+
+ /* If they are continuations for code points above 255,
+ * then comparing the current byte is sufficient, as there
+ * is no remapping of these and so the comparison is
+ * well-behaved. We determine if they are such
+ * continuations by looking at the preceding byte. It
+ * could be a start byte, from which we can tell if it is
+ * for an above 255 code point. Or it could be a
+ * continuation, which means the character occupies at
+ * least 3 bytes, so must be above 255. */
+ if ( UTF8_IS_CONTINUATION(*(pv2 - 1))
+ || UTF8_IS_ABOVE_LATIN1_START(*(pv2 -1)))
+ {
+ cmp = ((U8) *pv1 < (U8) *pv2) ? -1 : 1;
+ goto cmp_done;
+ }
+
+ /* Here, the continuations are for code points below 256;
+ * back up one to get to the start byte */
+ pv1--;
+ pv2--;
+ }
+
+ /* We need to get the actual native code point of each of these
+ * variants in order to compare them */
+ cmp = ( EIGHT_BIT_UTF8_TO_NATIVE(*pv1, *(pv1 + 1))
+ < EIGHT_BIT_UTF8_TO_NATIVE(*pv2, *(pv2 + 1)))
+ ? -1
+ : 1;
+ }
+ }
+ cmp_done: ;
+#endif
}
SvREFCNT_dec(svrecode);
=for apidoc sv_cmp_locale
Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
-'use bytes' aware, handles get magic, and will coerce its args to strings
-if necessary. See also C<sv_cmp>.
+S<C<'use bytes'>> aware, handles get magic, and will coerce its args to strings
+if necessary. See also C<L</sv_cmp>>.
=for apidoc sv_cmp_locale_flags
Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
-'use bytes' aware and will coerce its args to strings if necessary. If the
-flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
+S<C<'use bytes'>> aware and will coerce its args to strings if necessary. If
+the flags contain C<SV_GMAGIC>, it handles get magic. See also
+C<L</sv_cmp_flags>>.
=cut
*/
=for apidoc sv_collxfrm
This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
-C<sv_collxfrm_flags>.
+C<L</sv_collxfrm_flags>>.
=for apidoc sv_collxfrm_flags
Add Collate Transform magic to an SV if it doesn't already have it. If the
-flags contain SV_GMAGIC, it handles get-magic.
+flags contain C<SV_GMAGIC>, it handles get-magic.
-Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
+Any scalar variable may carry C<PERL_MAGIC_collxfrm> magic that contains the
scalar data of the variable, but transformed to such a format that a normal
memory comparison can be used to compare the data according to the locale
settings.
s = SvPV_flags_const(sv, len, flags);
if ((xf = mem_collxfrm(s, len, &xlen))) {
if (! mg) {
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
-#endif
mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
0, 0);
assert(mg);
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)) {
+ int fd = PerlIO_fileno(fp);
+ if (fd >= 0 && (PerlLIO_fstat(fd, &st) == 0) && S_ISREG(st.st_mode)) {
const Off_t offset = PerlIO_tell(fp);
if (offset != (Off_t) -1 && st.st_size + append > offset) {
-#ifdef PERL_NEW_COPY_ON_WRITE
+#ifdef PERL_COPY_ON_WRITE
/* Add an extra byte for the sake of copy-on-write's
* buffer reference count. */
(void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 2));
amount left, otherwise this is the amount it
can hold. */
-#if defined(__VMS) && defined(PERLIO_IS_STDIO)
- /* An ungetc()d char is handled separately from the regular
- * buffer, so we getc() it back out and stuff it in the buffer.
- */
- i = PerlIO_getc(fp);
- if (i == EOF) return 0;
- *(--((*fp)->_ptr)) = (unsigned char) i;
- (*fp)->_cnt++;
-#endif
-
/* Here is some breathtakingly efficient cheating */
/* When you read the following logic resist the urge to think
return;
}
+ /* treat AV/HV/CV/FM/IO and non-fake GVs as immutable */
+ if (SvTYPE(sv) >= SVt_PVAV || (isGV_with_GP(sv) && !SvFAKE(sv)))
+ Perl_croak_no_modify();
+
if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
if ((flags & SVTYPEMASK) < SVt_PVIV)
sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
return;
}
}
+
+ /* treat AV/HV/CV/FM/IO and non-fake GVs as immutable */
+ if (SvTYPE(sv) >= SVt_PVAV || (isGV_with_GP(sv) && !SvFAKE(sv)))
+ Perl_croak_no_modify();
+
if (!(flags & SVp_POK)) {
if ((flags & SVTYPEMASK) < SVt_PVIV)
sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
The new SV is marked as mortal. It 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_2mortal>.
+explicit call to C<FREETMPS>, or by an implicit call at places such as
+statement boundaries. See also C<L</sv_newmortal>> and C<L</sv_2mortal>>.
=cut
*/
Creates a new null SV which is mortal. The reference count of the SV is
set to 1. It 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_mortalcopy> and C<sv_2mortal>.
+C<FREETMPS>, or by an implicit call at places such as statement boundaries.
+See also C<L</sv_mortalcopy>> and C<L</sv_2mortal>>.
=cut
*/
=for apidoc sv_2mortal
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. 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>.
+by an explicit call to C<FREETMPS>, or by an implicit call at places such as
+statement boundaries. C<SvTEMP()> is turned on which means that the SV's
+string buffer can be "stolen" if this SV is copied. See also
+C<L</sv_newmortal>> and C<L</sv_mortalcopy>>.
=cut
*/
Creates a new SV and copies a string (which may contain C<NUL> (C<\0>)
characters) into it. The reference count for the
SV is set to 1. If C<len> is zero, Perl will compute the length using
-strlen(), (which means if you use this option, that C<s> can't have embedded
+C<strlen()>, (which means if you use this option, that C<s> can't have embedded
C<NUL> characters and has to have a terminating C<NUL> byte).
For efficiency, consider using C<newSVpvn> instead.
Creates a new SV from the hash key structure. It will generate scalars that
point to the shared string table where possible. Returns a new (undefined)
-SV if the hek is NULL.
+SV if C<hek> is NULL.
=cut
*/
/*
=for apidoc newSVpvn_share
-Creates a new SV with its SvPVX_const pointing to a shared string in the string
+Creates a new SV with its C<SvPVX_const> pointing to a shared string in the string
table. If the string does not already exist in the table, it is
-created first. Turns on the SvIsCOW flag (or READONLY
-and FAKE in 5.16 and earlier). If the C<hash> parameter
+created first. Turns on the C<SvIsCOW> flag (or C<READONLY>
+and C<FAKE> in 5.16 and earlier). If the C<hash> parameter
is non-zero, that value is used; otherwise the hash is computed.
The string's hash can later be retrieved from the SV
with the C<SvSHARED_HASH()> macro. The idea here is
that as the string table is used for shared hash keys these strings will have
-SvPVX_const == HeKEY and hash lookup will avoid string compare.
+C<SvPVX_const == HeKEY> and hash lookup will avoid string compare.
=cut
*/
=for apidoc newSVpvf
Creates a new SV and initializes it with the string formatted like
-C<sprintf>.
+C<sv_catpvf>.
=cut
*/
GV; or the recursive result if we're an RV; or the IO slot of the symbol
named after the PV if we're a string.
-'Get' magic is ignored on the sv passed in, but will be called on
-C<SvRV(sv)> if sv is an RV.
+'Get' magic is ignored on the C<sv> passed in, but will be called on
+C<SvRV(sv)> if C<sv> is an RV.
=cut
*/
Using various gambits, try to get a CV from an SV; in addition, try if
possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
-The flags in C<lref> are passed to gv_fetchsv.
+The flags in C<lref> are passed to C<gv_fetchsv>.
=cut
*/
=for apidoc sv_pvn_force_flags
Get a sensible string out of the SV somehow.
-If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
+If C<flags> has the C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
implemented in terms of this function.
You normally want to use the various wrapper macros instead: see
-C<SvPV_force> and C<SvPV_force_nomg>
+C<L</SvPV_force>> and C<L</SvPV_force_nomg>>.
=cut
*/
Returns a string describing what the SV is a reference to.
+If ob is true and the SV is blessed, the string is the class name,
+otherwise it is the type of the SV, "SCALAR", "ARRAY" etc.
+
=cut
*/
Returns a SV describing what the SV passed in is a reference to.
+dst can be a SV to be set to the description or NULL, in which case a
+mortal SV is returned.
+
+If ob is true and the SV is blessed, the description is the class
+name, otherwise it is the type of the SV, "SCALAR", "ARRAY" etc.
+
=cut
*/
Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
argument will be upgraded to an RV. That RV will be modified to point to
-the new SV. If the C<pv> argument is
NULL then C<PL_sv_undef> will be placed
+the new SV. If the C<pv> argument is
C<NULL>, then C<PL_sv_undef> will be placed
into the SV. The C<classname> argument indicates the package for the
blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
will have a reference count of 1, and the RV will be returned.
=for apidoc sv_bless
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
+must be designated by its stash (see C<L</gv_stashpv>>). The reference count
of the SV is unaffected.
=cut
C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
(otherwise the decrementing is conditional on the reference count being
different from one or the reference being a readonly SV).
-See C<SvROK_off>.
+See C<L</SvROK_off>>.
=cut
*/
=for apidoc sv_setpviv
Copies an integer into the given SV, also updating its string value.
-Does not handle 'set' magic. See C<sv_setpviv_mg>.
+Does not handle 'set' magic. See C<L</sv_setpviv_mg>>.
=cut
*/
=for apidoc sv_setpvf
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>.
+appending it. Does not handle 'set' magic. See C<L</sv_setpvf_mg>>.
=cut
*/
=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>.
+appending it. Does not handle 'set' magic. See C<L</sv_vsetpvf_mg>>.
Usually used via its frontend C<sv_setpvf>.
/*
=for apidoc sv_catpvf
-Processes its arguments like C<sprintf> and appends the formatted
-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
+Processes its arguments like C<sv_catpvfn>, and appends the formatted
+output to an SV. As with C<sv_catpvfn> called with a non-null C-style
+variable argument list, argument reordering is not supported.
+If the appended data contains "wide" characters
+(including, but not limited to, SVs with a UTF-8 PV formatted with C<%s>,
+and characters >255 formatted with C<%c>), the original SV might get
upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
-C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
+C<L</sv_catpvf_mg>>. If the original SV was UTF-8, the pattern should be
valid UTF-8; if the original SV was bytes, the pattern should be too.
=cut */
/*
=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>.
+Processes its arguments like C<sv_catpvfn> called with a non-null C-style
+variable argument list, and appends the formatted
+to an SV. Does not handle 'set' magic. See C<L</sv_vcatpvf_mg>>.
Usually used via its frontend C<sv_catpvf>.
/*
- * Warn of missing argument to sprintf, and then return a defined value
- * to avoid inappropriate "use of uninit" warnings [perl #71000].
+ * Warn of missing argument to sprintf. The value used in place of such
+ * arguments should be &PL_sv_no; an undefined value would yield
+ * inappropriate "use of uninit" warnings [perl #71000].
*/
-STATIC SV*
-S_vcatpvfn_missing_argument(pTHX) {
+STATIC void
+S_warn_vcatpvfn_missing_argument(pTHX) {
if (ckWARN(WARN_MISSING)) {
Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
}
- return &PL_sv_no;
}
=for apidoc sv_vcatpvfn_flags
Processes its arguments like C<vsprintf> and appends the formatted output
-to an SV. Uses an array of SVs if the C style variable argument list is
-missing (NULL). When running with taint checks enabled, indicates via
+to an SV. Uses an array of SVs if the C-style variable argument list is
+missing (C<NULL>). Argument reordering (using format specifiers like C<%2$d>
+or C<%*2$d>) is supported only when using an array of SVs; using a C-style
+C<va_list> argument list with a format string that uses argument reordering
+will yield an exception.
+
+When running with taint checks enabled, indicates via
C<maybe_tainted> if results are untrustworthy (often due to the use of
locales).
-If called as C<sv_vcatpvfn> or flags include C<SV_GMAGIC>, calls get magic.
+If called as C<sv_vcatpvfn> or flags has the C<SV_GMAGIC> bit set, calls get magic.
Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
* The non-double-double-long-double overshoots since all bits of NV
* are not mantissa bits, there are also exponent bits. */
#ifdef LONGDOUBLE_DOUBLEDOUBLE
-# define VHEX_SIZE (1+DOUBLEDOUBLE_MAXBITS/4)
+# define VHEX_SIZE (3+DOUBLEDOUBLE_MAXBITS/4)
#else
# define VHEX_SIZE (1+(NVSIZE * 8)/4)
#endif
/* HEXTRACTSIZE is the maximum number of xdigits. */
#if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE)
-# define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/4)
+# define HEXTRACTSIZE (2+DOUBLEDOUBLE_MAXBITS/4)
#else
# define HEXTRACTSIZE 2 * NVSIZE
#endif
const U8* vmaxend = vhex + HEXTRACTSIZE;
PERL_UNUSED_VAR(ix); /* might happen */
(void)Perl_frexp(PERL_ABS(nv), exponent);
- if (vend && (vend <= vhex || vend > vmaxend))
- Perl_croak(aTHX_ "Hexadecimal float: internal error");
+ if (vend && (vend <= vhex || vend > vmaxend)) {
+ /* diag_listed_as: Hexadecimal float: internal error (%s) */
+ Perl_croak(aTHX_ "Hexadecimal float: internal error (entry)");
+ }
{
/* First check if using long doubles. */
#if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE)
* which is convenient since the HEXTRACTSIZE is tricky
* for double-double. */
ixmin < 0 || ixmax >= NVSIZE ||
- (vend && v != vend))
- Perl_croak(aTHX_ "Hexadecimal float: internal error");
+ (vend && v != vend)) {
+ /* diag_listed_as: Hexadecimal float: internal error (%s) */
+ Perl_croak(aTHX_ "Hexadecimal float: internal error (overflow)");
+ }
return v;
}
+/* Helper for sv_vcatpvfn_flags(). */
+#define FETCH_VCATPVFN_ARGUMENT(var, in_range, expr) \
+ STMT_START { \
+ if (in_range) \
+ (var) = (expr); \
+ else { \
+ (var) = &PL_sv_no; /* [perl #71000] */ \
+ arg_missing = TRUE; \
+ } \
+ } STMT_END
+
void
Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted,
bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */
bool hexfp = FALSE; /* hexadecimal floating point? */
- DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED;
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
PERL_UNUSED_ARG(maybe_tainted);
sv_catsv_nomg(sv, *svargs);
}
else
- S_vcatpvfn_missing_argument(aTHX);
+ S_warn_vcatpvfn_missing_argument(aTHX);
return;
}
if (args && patlen == 3 && pat[0] == '%' &&
STRLEN precis = 0;
const I32 osvix = svix;
bool is_utf8 = FALSE; /* is this item utf8? */
+ bool used_explicit_ix = FALSE;
+ bool arg_missing = FALSE;
#ifdef HAS_LDBL_SPRINTF_BUG
/* This is to try to fix a bug with irix/nonstop-ux/powerux and
with sfio - Allen <allens@cpan.org> */
is safe. */
is_utf8 = (bool)va_arg(*args, int);
elen = va_arg(*args, UV);
- if ((IV)elen < 0) {
- /* check if utf8 length is larger than 0 when cast to IV */
- assert( (IV)elen >= 0 ); /* in DEBUGGING build we want to crash */
+ /* if utf8 length is larger than 0x7ffff..., then it might
+ * have been a signed value that wrapped */
+ if (elen > ((~(STRLEN)0) >> 1)) {
+ assert(0); /* in DEBUGGING build we want to crash */
elen= 0; /* otherwise we want to treat this as an empty string */
}
eptr = va_arg(*args, char *);
if ( (width = expect_number(&q)) ) {
if (*q == '$') {
+ if (args)
+ Perl_croak_nocontext(
+ "Cannot yet reorder sv_catpvfn() arguments from va_list");
++q;
efix = width;
- if (!no_redundant_warning)
- /* I've forgotten if it's a better
- micro-optimization to always set this or to
- only set it if it's unset */
- no_redundant_warning = TRUE;
+ used_explicit_ix = TRUE;
} else {
goto gotwidth;
}
tryasterisk:
if (*q == '*') {
q++;
- if ( (ewix = expect_number(&q)) )
- if (*q++ != '$')
+ if ( (ewix = expect_number(&q)) ) {
+ if (*q++ == '$') {
+ if (args)
+ Perl_croak_nocontext(
+ "Cannot yet reorder sv_catpvfn() arguments from va_list");
+ used_explicit_ix = TRUE;
+ } else
goto unknown;
+ }
asterisk = TRUE;
}
if (*q == 'v') {
if (args)
vecsv = va_arg(*args, SV*);
else if (evix) {
- vecsv = (evix > 0 && evix <= svmax)
- ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
+ FETCH_VCATPVFN_ARGUMENT(
+ vecsv, evix > 0 && evix <= svmax, svargs[evix-1]);
} else {
- vecsv = svix < svmax
- ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
+ FETCH_VCATPVFN_ARGUMENT(
+ vecsv, svix < svmax, svargs[svix++]);
}
dotstr = SvPV_const(vecsv, dotstrlen);
/* Keep the DO_UTF8 test *after* the SvPV call, else things go
q++;
if (*q == '*') {
q++;
- if ( ((epix = expect_number(&q))) && (*q++ != '$') )
- goto unknown;
- /* XXX: todo, support specified precision parameter */
- if (epix)
- goto unknown;
+ if ( (epix = expect_number(&q)) ) {
+ if (*q++ == '$') {
+ if (args)
+ Perl_croak_nocontext(
+ "Cannot yet reorder sv_catpvfn() arguments from va_list");
+ used_explicit_ix = TRUE;
+ } else
+ goto unknown;
+ }
if (args)
- i = va_arg(*args, int);
- else
- i = (ewix ? ewix <= svmax : svix < svmax)
- ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
+ i = va_arg(*args, int);
+ else {
+ SV *precsv;
+ if (epix)
+ FETCH_VCATPVFN_ARGUMENT(
+ precsv, epix > 0 && epix <= svmax, svargs[epix-1]);
+ else
+ FETCH_VCATPVFN_ARGUMENT(
+ precsv, svix < svmax, svargs[svix++]);
+ i = precsv == &PL_sv_no ? 0 : SvIVx(precsv);
+ }
precis = i;
has_precis = !(i < 0);
}
if (!vectorize && !args) {
if (efix) {
const I32 i = efix-1;
- argsv = (i >= 0 && i < svmax)
- ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
+ FETCH_VCATPVFN_ARGUMENT(argsv, i >= 0 && i < svmax, svargs[i]);
} else {
- argsv = (svix >= 0 && svix < svmax)
- ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
+ FETCH_VCATPVFN_ARGUMENT(argsv, svix >= 0 && svix < svmax,
+ svargs[svix++]);
}
}
if (vectorize) {
STRLEN ulen;
if (!veclen)
- continue;
+ goto donevalidconversion;
if (vec_utf8)
uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
UTF8_ALLOW_ANYUV);
STRLEN ulen;
vector:
if (!veclen)
- continue;
+ goto donevalidconversion;
if (vec_utf8)
uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
UTF8_ALLOW_ANYUV);
U8* v = vhex; /* working pointer to vhex */
U8* vend; /* pointer to one beyond last digit of vhex */
U8* vfnz = NULL; /* first non-zero */
+ U8* vlnz = NULL; /* last non-zero */
const bool lower = (c == 'a');
/* At output the values of vhex (up to vend) will
* be mapped through the xdig to get the actual
const char* xdig = PL_hexdigit;
int zerotail = 0; /* how many extra zeros to append */
int exponent = 0; /* exponent of the floating point input */
+ bool hexradix = FALSE; /* should we output the radix */
/* XXX: denormals, NaN, Inf.
*
# endif
#endif
- if (fv < 0)
+ if (fv < 0
+ || Perl_signbit(nv)
+ )
*p++ = '-';
else if (plus)
*p++ = plus;
}
if (vfnz) {
- U8* vlnz = NULL; /* The last non-zero. */
-
/* Find the last non-zero xdigit. */
for (v = vend - 1; v >= vhex; v--) {
if (*v) {
v = vhex;
*p++ = xdig[*v++];
- /* The radix is always output after the first
- * non-zero xdigit, or if alt. */
- if (vfnz < vlnz || alt) {
+ /* If there are non-zero xdigits, the radix
+ * is output after the first one. */
+ if (vfnz < vlnz) {
+ hexradix = TRUE;
+ }
+ }
+ else {
+ *p++ = '0';
+ exponent = 0;
+ zerotail = precis;
+ }
+
+ /* The radix is always output if precis, or if alt. */
+ if (precis > 0 || alt) {
+ hexradix = TRUE;
+ }
+
+ if (hexradix) {
#ifndef USE_LOCALE_NUMERIC
*p++ = '.';
#else
}
RESTORE_LC_NUMERIC();
#endif
- }
+ }
+ if (vlnz) {
while (v <= vlnz)
*p++ = xdig[*v++];
-
- while (zerotail--)
- *p++ = '0';
}
- else {
+
+ if (zerotail > 0) {
+ while (zerotail--) {
*p++ = '0';
- exponent = 0;
+ }
}
elen = p - PL_efloatbuf;
elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
qfmt, nv);
if ((IV)elen == -1)
- Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s|'", qfmt);
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
if (qfmt != ptr)
Safefree(qfmt);
}
}
else
sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i);
- continue; /* not "break" */
+ goto donevalidconversion;
/* UNKNOWN */
}
}
- assert((IV)elen >= 0); /* here zero elen is fine */
+ /* signed value that's wrapped? */
+ assert(elen <= ((~(STRLEN)0) >> 1));
have = esignlen + zeros + elen;
if (have < zeros)
croak_memory_wrap();
esignlen = 0;
goto vector;
}
+
+ donevalidconversion:
+ if (used_explicit_ix)
+ no_redundant_warning = TRUE;
+ if (arg_missing)
+ S_warn_vcatpvfn_missing_argument(aTHX);
}
/* Now that we've consumed all our printf format arguments (svix)
return ret;
/* create anew and remember what it is */
+#ifdef __amigaos4__
+ ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE|PERLIO_DUP_FD);
+#else
ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
+#endif
ptr_table_store(PL_ptr_table, fp, ret);
return ret;
}
if (tbl && tbl->tbl_items) {
struct ptr_tbl_arena *arena = tbl->tbl_arena;
- Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
+ Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent *);
while (arena) {
struct ptr_tbl_arena *next = arena->next;
}
items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
while (items-- > 0) {
- *dst_ary++ = &PL_sv_undef;
+ *dst_ary++ = NULL;
}
}
else {
case CXt_LOOP_LAZYSV:
ncx->blk_loop.state_u.lazysv.end
= sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
- /* We are taking advantage of av_dup_inc and sv_dup_inc
- actually being the same function, and order equivalence of
- the two unions.
+ /* Fallthrough: duplicate lazysv.cur by using the ary.ary
+ duplication code instead.
+ We are taking advantage of (1) av_dup_inc and sv_dup_inc
+ actually being the same function, and (2) order
+ equivalence of the two unions.
We can assert the later [but only at run time :-(] */
assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
(void *) &ncx->blk_loop.state_u.lazysv.cur);
+ /* FALLTHROUGH */
case CXt_LOOP_FOR:
ncx->blk_loop.state_u.ary.ary
= av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
+ /* FALLTHROUGH */
case CXt_LOOP_LAZYIV:
case CXt_LOOP_PLAIN:
+ /* code common to all CXt_LOOP_* types */
if (CxPADLOOP(ncx)) {
ncx->blk_loop.itervar_u.oldcomppad
= (PAD*)ptr_table_fetch(PL_ptr_table,
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
break;
- case SAVEt_GP_ALIASED_SV: {
- GP * gp_ptr = (GP *)POPPTR(ss,ix);
- GP * new_gp_ptr = gp_dup(gp_ptr, param);
- TOPPTR(nss,ix) = new_gp_ptr;
- new_gp_ptr->gp_refcnt++;
- break;
- }
default:
Perl_croak(aTHX_
"panic: ss_dup inconsistency (%"IVdf")", (IV) type);
Create and return a new interpreter by cloning the current one.
-perl_clone takes these flags as parameters:
+C<perl_clone> takes these flags as parameters:
-CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
+C<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
+The pseudo-fork code uses C<COPY_STACKS> while the
threads->create doesn't.
-CLONEf_KEEP_PTR_TABLE -
-perl_clone keeps a ptr_table with the pointer of the old
+C<CLONEf_KEEP_PTR_TABLE> -
+C<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
+refcount. If C<KEEP_PTR_TABLE> is not set then C<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.
+variable who are outside the graph perl scans, an example of this
+code is in F<threads.xs> create.
-CLONEf_CLONE_HOST -
+C<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,
/* perlhost.h so we need to call into it
to clone the host, CPerlHost should have a c interface, sky */
+#ifndef __amigaos4__
if (flags & CLONEf_CLONE_HOST) {
return perl_clone_host(proto_perl,flags);
}
+#endif
return perl_clone_using(proto_perl, flags,
proto_perl->IMem,
proto_perl->IMemShared,
# ifdef DEBUG_LEAKING_SCALARS
PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
# endif
+# ifdef PERL_TRACE_OPS
+ Zero(PL_op_exec_cnt, OP_max+2, UV);
+# endif
#else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
#endif /* DEBUGGING */
PL_minus_F = proto_perl->Iminus_F;
PL_doswitches = proto_perl->Idoswitches;
PL_dowarn = proto_perl->Idowarn;
- PL_sawalias = proto_perl->Isawalias;
#ifdef PERL_SAWAMPERSAND
PL_sawampersand = proto_perl->Isawampersand;
#endif
PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
}
PL_GCB_invlist = sv_dup_inc(proto_perl->IGCB_invlist, param);
+ PL_SB_invlist = sv_dup_inc(proto_perl->ISB_invlist, param);
+ PL_WB_invlist = sv_dup_inc(proto_perl->IWB_invlist, param);
PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
=for apidoc sv_recode_to_utf8
-The encoding is assumed to be an Encode object, on entry the PV
-of the sv is assumed to be octets in that encoding, and the sv
+C<encoding> is assumed to be an C<Encode> object, on entry the PV
+of C<sv> is assumed to be octets in that encoding, and C<sv>
will be converted into Unicode (and UTF-8).
-If the sv already is UTF-8 (or if it is not POK), or if the encoding
-is not a reference, nothing is done to the sv. If the encoding is not
+If C<sv> already is UTF-8 (or if it is not C<POK>), or if C<encoding>
+is not a reference, nothing is done to C<sv>. If C<encoding> is not
an C<Encode::XS> Encoding object, bad things will happen.
-(See F<lib/encoding.pm> and L<Encode>.)
+(See F<cpan/Encode/encoding.pm> and L<Encode>.)
-The PV of the sv is returned.
+The PV of C<sv> is returned.
=cut */
nsv = sv_newmortal();
SvSetSV_nosteal(nsv, sv);
}
+ save_re_context();
PUSHMARK(sp);
EXTEND(SP, 3);
PUSHs(encoding);
/*
=for apidoc sv_cat_decode
-The encoding is assumed to be an Encode object, the PV of the ssv is
+C<encoding> is assumed to be an C<Encode> object, the PV of C<ssv> is
assumed to be octets in that encoding and decoding the input starts
-from the position which (PV + *offset) pointed to. The dsv will be
-concatenated the decoded UTF-8 string from ssv. Decoding will terminate
-when the string tstr appears in decoding output or the input ends on
-the PV of the ssv. The value which the offset points will be modified
-to the last input position on the ssv.
+from the position which S<C<(PV + *offset)>> pointed to. C<dsv> will be
+concatenated with the decoded UTF-8 string from C<ssv>. Decoding will terminate
+when the string C<tstr> appears in decoding output or the input ends on
+the PV of C<ssv>. The value which C<offset> points will be modified
+to the last input position on C<ssv>.
Returns TRUE if the terminator was found, else returns FALSE.
PERL_ARGS_ASSERT_SV_CAT_DECODE;
- if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
+ if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding)) {
SV *offsv;
dSP;
ENTER;
SAVETMPS;
+ save_re_context();
PUSHMARK(sp);
EXTEND(SP, 6);
PUSHs(encoding);
Find the name of the undefined variable (if any) that caused the operator
to issue a "Use of uninitialized value" warning.
-If match is true, only return a name if its value matches uninit_sv.
-So roughly speaking, if a unary operator (such as OP_COS) generates a
+If match is true, only return a name if its value matches C<uninit_sv>.
+So roughly speaking, if a unary operator (such as C<OP_COS>) generates a
warning, then following the direct child of the op may yield an
-OP_PADSV or OP_GV that gives the name of the undefined variable. On the
-other hand, with OP_ADD there are two branches to follow, so we only print
+C<OP_PADSV> or C<OP_GV> that gives the name of the undefined variable. On the
+other hand, with C<OP_ADD> there are two branches to follow, so we only print
the variable name if we get an exact match.
-desc_p points to a string pointer holding the description of the op.
+C<desc_p> points to a string pointer holding the description of the op.
This may be updated if needed.
The name is returned as a mortal SV.
-Assumes that PL_op is the op that originally triggered the error, and that
-PL_comppad/PL_curpad points to the currently executing pad.
+Assumes that C<PL_op> is the OP that originally triggered the error, and that
+C<PL_comppad>/C<PL_curpad> points to the currently executing pad.
=cut
*/
void
Perl_report_uninit(pTHX_ const SV *uninit_sv)
{
- if (PL_op) {
- SV* varname = NULL;
- const char *desc;
+ const char *desc = NULL;
+ SV* varname = NULL;
+ if (PL_op) {
desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded
? "join or string"
: OP_DESC(PL_op);
if (varname)
sv_insert(varname, 0, 0, " ", 1);
}
- /* PL_warn_uninit_sv is constant */
- GCC_DIAG_IGNORE(-Wformat-nonliteral);
- /* diag_listed_as: Use of uninitialized value%s */
- Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
- SVfARG(varname ? varname : &PL_sv_no),
- " in ", desc);
- GCC_DIAG_RESTORE;
- }
- else {
- /* PL_warn_uninit is constant */
- GCC_DIAG_IGNORE(-Wformat-nonliteral);
- Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
- "", "", "");
- GCC_DIAG_RESTORE;
}
+ else if (PL_curstackinfo->si_type == PERLSI_SORT
+ && CxMULTICALL(&cxstack[cxstack_ix]))
+ {
+ /* we've reached the end of a sort block or sub,
+ * and the uninit value is probably what that code returned */
+ desc = "sort";
+ }
+
+ /* PL_warn_uninit_sv is constant */
+ GCC_DIAG_IGNORE(-Wformat-nonliteral);
+ if (desc)
+ /* diag_listed_as: Use of uninitialized value%s */
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
+ SVfARG(varname ? varname : &PL_sv_no),
+ " in ", desc);
+ else
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
+ "", "", "");
+ GCC_DIAG_RESTORE;
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff