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.
+=for apidoc Amnh||SV_GMAGIC
+
=cut
*/
*/
char *
-Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
+Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
{
- PERL_ARGS_ASSERT_SV_2PVBYTE;
+ PERL_ARGS_ASSERT_SV_2PVBYTE_FLAGS;
- SvGETMAGIC(sv);
+ if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+ mg_get(sv);
if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
|| isGV_with_GP(sv) || SvROK(sv)) {
SV *sv2 = sv_newmortal();
sv_copypv_nomg(sv2,sv);
sv = sv2;
}
- sv_utf8_downgrade(sv,0);
+ sv_utf8_downgrade_nomg(sv,0);
return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
}
*/
char *
-Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
+Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
{
- PERL_ARGS_ASSERT_SV_2PVUTF8;
+ PERL_ARGS_ASSERT_SV_2PVUTF8_FLAGS;
+ if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+ mg_get(sv);
if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
- || isGV_with_GP(sv) || SvROK(sv))
- sv = sv_mortalcopy(sv);
- else
- SvGETMAGIC(sv);
+ || isGV_with_GP(sv) || SvROK(sv)) {
+ SV *sv2 = sv_newmortal();
+ sv_copypv_nomg(sv2,sv);
+ sv = sv2;
+ }
sv_utf8_upgrade_nomg(sv);
return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
}
This is not a general purpose Unicode to byte encoding interface:
use the C<Encode> extension for that.
+This function process get magic on C<sv>.
+
+=for apidoc sv_utf8_downgrade_nomg
+
+Like C<sv_utf8_downgrade>, but does not process get magic on C<sv>.
+
+=for apidoc sv_utf8_downgrade_flags
+
+Like C<sv_utf8_downgrade>, but with additional C<flags>.
+If C<flags> has C<SV_GMAGIC> bit set, processes get magic on C<sv>.
+
=cut
*/
bool
-Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
+Perl_sv_utf8_downgrade_flags(pTHX_ SV *const sv, const bool fail_ok, const U32 flags)
{
- PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
+ PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE_FLAGS;
if (SvPOKp(sv) && SvUTF8(sv)) {
if (SvCUR(sv)) {
U8 *s;
STRLEN len;
- int mg_flags = SV_GMAGIC;
+ U32 mg_flags = flags & SV_GMAGIC;
if (SvIsCOW(sv)) {
S_sv_uncow(aTHX_ sv, 0);
MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
- SV_GMAGIC|SV_CONST_RETURN);
+ mg_flags|SV_CONST_RETURN);
mg_flags = 0; /* sv_pos_b2u does get magic */
}
if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
This is the primary function for copying scalars, and most other
copy-ish functions and macros use this underneath.
+=for apidoc Amnh||SV_NOSTEAL
+
=cut
*/
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>).
+=for apidoc Amnh||SV_SMAGIC
+=for apidoc Amnh||SV_HAS_TRAILING_NUL
+
=cut
*/
about to be written to, and any extra book-keeping needs to be taken care
of. Hence, it croaks on read-only values.
+=for apidoc Amnh||SV_COW_DROP_PV
+
=cut
*/
Note we have to deal with the char in 'i' if we are not at EOF
*/
+ bpx = bp - (STDCHAR*)SvPVX_const(sv);
+ /* signals might be called here, possibly modifying sv */
i = PerlIO_getc(fp); /* get more characters */
+ bp = (STDCHAR*)SvPVX_const(sv) + bpx;
DEBUG_Pv(PerlIO_printf(Perl_debug_log,
"Screamer: post: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf "\n",
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>>.
+=for apidoc sv_mortalcopy_flags
+
+Like C<sv_mortalcopy>, but the extra C<flags> are passed to the
+C<sv_setsv_flags>.
+
=cut
*/
#define newSVpvn_utf8(s, len, u) \
newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
+=for apidoc Amnh||SVf_UTF8
+=for apidoc Amnh||SVs_TEMP
+
=cut
*/
different from one or the reference being a readonly SV).
See C<L</SvROK_off>>.
+=for apidoc Amnh||SV_IMMEDIATE_UNREF
+
=cut
*/
{
PERL_ARGS_ASSERT_SV_SETPVIV_MG;
+ GCC_DIAG_IGNORE_STMT(-Wdeprecated-declarations);
+
sv_setpviv(sv, iv);
+
+ GCC_DIAG_RESTORE_STMT;
+
SvSETMAGIC(sv);
}
* The rest of the args have the same meaning as the local vars of the
* same name within Perl_sv_vcatpvfn_flags().
*
- * It assumes the caller has already done STORE_LC_NUMERIC_SET_TO_NEEDED();
+ * The caller's determination of IN_LC(LC_NUMERIC), passed as in_lc_numeric,
+ * is used to ensure we do the right thing when we need to access the locale's
+ * numeric radix.
*
* It requires the caller to make buf large enough.
*/
S_format_hexfp(pTHX_ char * const buf, const STRLEN bufsize, const char c,
const NV nv, const vcatpvfn_long_double_t fv,
bool has_precis, STRLEN precis, STRLEN width,
- bool alt, char plus, bool left, bool fill)
+ bool alt, char plus, bool left, bool fill, bool in_lc_numeric)
{
/* Hexadecimal floating point. */
char* p = buf;
else {
*p++ = '0';
exponent = 0;
- zerotail = precis;
+ zerotail = has_precis ? precis : 0;
}
/* The radix is always output if precis, or if alt. */
- if (precis > 0 || alt) {
+ if ((has_precis && precis > 0) || alt) {
hexradix = TRUE;
}
if (hexradix) {
#ifndef USE_LOCALE_NUMERIC
- *p++ = '.';
+ *p++ = '.';
#else
- if (IN_LC(LC_NUMERIC)) {
- STRLEN n;
+ if (in_lc_numeric) {
+ STRLEN n;
+ WITH_LC_NUMERIC_SET_TO_NEEDED_IN(TRUE, {
const char* r = SvPV(PL_numeric_radix_sv, n);
Copy(r, p, n, char);
- p += n;
- }
- else {
- *p++ = '.';
- }
+ });
+ p += n;
+ }
+ else {
+ *p++ = '.';
+ }
#endif
}
char ebuf[IV_DIG * 4 + NV_DIG + 32];
bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */
#ifdef USE_LOCALE_NUMERIC
- DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
- bool lc_numeric_set = FALSE; /* called STORE_LC_NUMERIC_SET_TO_NEEDED? */
+ bool have_in_lc_numeric = FALSE;
#endif
+ /* we never change this unless USE_LOCALE_NUMERIC */
+ bool in_lc_numeric = FALSE;
PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
PERL_UNUSED_ARG(maybe_tainted);
}
precis = S_sprintf_arg_num_val(aTHX_ args, i, sv, &neg);
has_precis = !neg;
+ /* ignore negative precision */
+ if (!has_precis)
+ precis = 0;
}
}
else {
* below, or implicitly, via an snprintf() variant.
* Note also things like ps_AF.utf8 which has
* "\N{ARABIC DECIMAL SEPARATOR} as a radix point */
- if (!lc_numeric_set) {
- /* only set once and reuse in-locale value on subsequent
- * iterations.
- * XXX what happens if we die in an eval?
- */
- STORE_LC_NUMERIC_SET_TO_NEEDED();
- lc_numeric_set = TRUE;
+ if (! have_in_lc_numeric) {
+ in_lc_numeric = IN_LC(LC_NUMERIC);
+ have_in_lc_numeric = TRUE;
}
- if (IN_LC(LC_NUMERIC)) {
- /* this can't wrap unless PL_numeric_radix_sv is a string
- * consuming virtually all the 32-bit or 64-bit address
- * space
- */
- float_need += (SvCUR(PL_numeric_radix_sv) - 1);
-
- /* floating-point formats only get utf8 if the radix point
- * is utf8. All other characters in the string are < 128
- * and so can be safely appended to both a non-utf8 and utf8
- * string as-is.
- * Note that this will convert the output to utf8 even if
- * the radix point didn't get output.
- */
- if (SvUTF8(PL_numeric_radix_sv) && !has_utf8) {
- sv_utf8_upgrade(sv);
- has_utf8 = TRUE;
- }
+ if (in_lc_numeric) {
+ WITH_LC_NUMERIC_SET_TO_NEEDED_IN(TRUE, {
+ /* this can't wrap unless PL_numeric_radix_sv is a string
+ * consuming virtually all the 32-bit or 64-bit address
+ * space
+ */
+ float_need += (SvCUR(PL_numeric_radix_sv) - 1);
+
+ /* floating-point formats only get utf8 if the radix point
+ * is utf8. All other characters in the string are < 128
+ * and so can be safely appended to both a non-utf8 and utf8
+ * string as-is.
+ * Note that this will convert the output to utf8 even if
+ * the radix point didn't get output.
+ */
+ if (SvUTF8(PL_numeric_radix_sv) && !has_utf8) {
+ sv_utf8_upgrade(sv);
+ has_utf8 = TRUE;
+ }
+ });
}
#endif
&& !fill
&& intsize != 'q'
) {
- SNPRINTF_G(fv, ebuf, sizeof(ebuf), precis);
+ WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric,
+ SNPRINTF_G(fv, ebuf, sizeof(ebuf), precis)
+ );
elen = strlen(ebuf);
eptr = ebuf;
goto float_concat;
if (float_need < width)
float_need = width;
+ if (float_need > INT_MAX) {
+ /* snprintf() returns an int, and we use that return value,
+ so die horribly if the expected size is too large for int
+ */
+ Perl_croak(aTHX_ "Numeric format result too large");
+ }
+
if (PL_efloatsize <= float_need) {
/* PL_efloatbuf should be at least 1 greater than
* float_need to allow a trailing \0 to be returned by
if (UNLIKELY(hexfp)) {
elen = S_format_hexfp(aTHX_ PL_efloatbuf, PL_efloatsize, c,
nv, fv, has_precis, precis, width,
- alt, plus, left, fill);
+ alt, plus, left, fill, in_lc_numeric);
}
else {
char *ptr = ebuf + sizeof ebuf;
const char* qfmt = quadmath_format_single(ptr);
if (!qfmt)
Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr);
- elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
- qfmt, nv);
+ WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric,
+ elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
+ qfmt, nv);
+ );
if ((IV)elen == -1) {
if (qfmt != ptr)
SAVEFREEPV(qfmt);
Safefree(qfmt);
}
#elif defined(HAS_LONG_DOUBLE)
- elen = ((intsize == 'q')
- ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv)
- : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)fv));
+ WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric,
+ elen = ((intsize == 'q')
+ ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv)
+ : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)fv))
+ );
#else
- elen = my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv);
+ WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric,
+ elen = my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv)
+ );
#endif
GCC_DIAG_RESTORE_STMT;
}
}
SvTAINT(sv);
-
-#ifdef USE_LOCALE_NUMERIC
-
- if (lc_numeric_set) {
- RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to
- save/restore each iteration. */
- }
-
-#endif
-
}
/* =========================================================================
nsi->si_stack = av_dup_inc(si->si_stack, param);
nsi->si_cxix = si->si_cxix;
+ nsi->si_cxsubix = si->si_cxsubix;
nsi->si_cxmax = si->si_cxmax;
nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
nsi->si_type = si->si_type;
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 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, an example of this
-code is in F<threads.xs> create.
+clone it again, but rather just use the value and increase the
+refcount.
+If C<KEEP_PTR_TABLE> is not set then C<perl_clone> will kill the ptr_table
+using the function S<C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>>.
+A reason to keep it around is if you want to dup some of your own
+variables which are outside the graph that perl scans.
C<CLONEf_CLONE_HOST> -
-This is a win32 thing, it is ignored on unix, it tells perls
+This is a win32 thing, it is ignored on unix, it tells perl's
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
if (agg_targ)
sv = PAD_SV(agg_targ);
- else if (agg_gv)
+ else if (agg_gv) {
sv = is_hv ? MUTABLE_SV(GvHV(agg_gv)) : MUTABLE_SV(GvAV(agg_gv));
+ if (!sv)
+ break;
+ }
else
break;
https://perl5.git.perl.org / perl5.git / blobdiff