const MGVTBL* const vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_free)
vtbl->svt_free(aTHX_ sv, mg);
- if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
+
+ if (mg->mg_type == PERL_MAGIC_collxfrm && mg->mg_len >= 0)
+ /* collate magic uses string len not buffer len, so
+ * free even with mg_len == 0 */
+ Safefree(mg->mg_ptr);
+ else if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
}
+
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
}
/*
-=for apidoc Am|void|mg_free_type|SV *sv|int how
+=for apidoc mg_free_type
Remove any magic of type C<how> from the SV C<sv>. See L</sv_magic>.
* avoid as many possible backward compatibility issues as possible, we
* don't turn on the flag unless we have to. So the flag stays off for
* an entirely invariant string. We assume that if the string looks
- * like UTF-8, it really is UTF-8: "text in any other encoding that
- * uses bytes with the high bit set is extremely unlikely to pass a
- * UTF-8 validity test"
+ * like UTF-8 in a single script, it really is UTF-8: "text in any
+ * other encoding that uses bytes with the high bit set is extremely
+ * unlikely to pass a UTF-8 validity test"
* (http://en.wikipedia.org/wiki/Charset_detection). There is a
* potential that we will get it wrong however, especially on short
* error message text, so do an additional check. */
- if ( ! IN_BYTES /* respect 'use bytes' */
- && ! is_utf8_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
- && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv))
+ if ( ! IN_BYTES /* respect 'use bytes' */
+ && is_utf8_non_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
#ifdef USE_LOCALE_MESSAGES
- && _is_cur_LC_category_utf8(LC_MESSAGES)
+ && _is_cur_LC_category_utf8(LC_MESSAGES)
-#elif defined(USE_LOCLAE_CTYPE)
-
- /* For systems that don't have a separate message category,
- * this assumes that they follow the CTYPE one */
- && _is_cur_LC_category_utf8(LC_CTYPE)
+#else /* If can't check directly, at least can see if script is consistent,
+ under UTF-8, which gives us an extra measure of confidence. */
+ && isSCRIPT_RUN((const U8 *) SvPVX_const(sv), (U8 *) SvEND(sv),
+ TRUE) /* Means assume UTF-8 */
#endif
) {
}
/*
-=for apidoc Am|SV *|sv_string_from_errnum|int errnum|SV *tgtsv
+=for apidoc sv_string_from_errnum
Generates the message string describing an OS error and returns it as
an SV. C<errnum> must be a value that C<errno> could take, identifying
break;
case '\006': /* ^F */
- sv_setiv(sv, (IV)PL_maxsysfd);
+ if (nextchar == '\0') {
+ sv_setiv(sv, (IV)PL_maxsysfd);
+ }
+ else if (strEQ(remaining, "EATURE_BITS")) {
+ sv_setuv(sv, PL_compiling.cop_features);
+ }
break;
case '\007': /* ^GLOBAL_PHASE */
if (strEQ(remaining, "LOBAL_PHASE")) {
sv_setiv(sv, (IV)PL_perldb);
break;
case '\023': /* ^S */
- {
+ if (nextchar == '\0') {
if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
SvOK_off(sv);
else if (PL_in_eval)
else
sv_setiv(sv, 0);
}
+ else if (strEQ(remaining, "AFE_LOCALES")) {
+
+#if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE)
+
+ sv_setuv(sv, (UV) 1);
+
+#else
+ sv_setuv(sv, (UV) 0);
+
+#endif
+
+ }
break;
case '\024': /* ^T */
if (nextchar == '\0') {
goto set_undef;
}
else if (PL_compiling.cop_warnings == pWARN_ALL) {
- /* Get the bit mask for $warnings::Bits{all}, because
- * it could have been extended by warnings::register */
- HV * const bits = get_hv("warnings::Bits", 0);
- SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
- if (bits_all)
- sv_copypv(sv, *bits_all);
- else
- sv_setpvn(sv, WARN_ALLstring, WARNsize);
+ sv_setpvn(sv, WARN_ALLstring, WARNsize);
}
else {
sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
* access to a known hint bit in a known OP, we can't
* tell whether HINT_STRICT_REFS is in force or not.
*/
- if (!strchr(s,':') && !strchr(s,'\''))
+ if (!memchr(s, ':', len) && !memchr(s, '\'', len))
Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
SV_GMAGIC);
if (i)
PERL_UNUSED_CONTEXT;
/* Reset the iterator when the array is cleared */
-#if IVSIZE == I32SIZE
- *((IV *) &(mg->mg_len)) = 0;
-#else
- if (mg->mg_ptr)
- *((IV *) mg->mg_ptr) = 0;
-#endif
+ if (sizeof(IV) == sizeof(SSize_t)) {
+ *((IV *) &(mg->mg_len)) = 0;
+ } else {
+ if (mg->mg_ptr)
+ *((IV *) mg->mg_ptr) = 0;
+ }
return 0;
}
}
int
+Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_SETNONELEM;
+ PERL_UNUSED_ARG(mg);
+ sv_unmagic(sv, PERL_MAGIC_nonelem);
+ return 0;
+}
+
+int
Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
FmLINES(PL_bodytarget) = 0;
if (SvPOK(PL_bodytarget)) {
char *s = SvPVX(PL_bodytarget);
- while ( ((s = strchr(s, '\n'))) ) {
+ char *e = SvEND(PL_bodytarget);
+ while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
FmLINES(PL_bodytarget)++;
s++;
}
Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
break;
case '\006': /* ^F */
- PL_maxsysfd = SvIV(sv);
+ if (mg->mg_ptr[1] == '\0') {
+ PL_maxsysfd = SvIV(sv);
+ }
+ else if (strEQ(mg->mg_ptr + 1, "EATURE_BITS")) {
+ PL_compiling.cop_features = SvUV(sv);
+ }
break;
case '\010': /* ^H */
{
else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
if (!SvPOK(sv)) {
+ if (!specialWARN(PL_compiling.cop_warnings))
+ PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_STD;
break;
}
{
STRLEN len, i;
- int accumulate = 0 ;
- int any_fatals = 0 ;
- const char * const ptr = SvPV_const(sv, len) ;
+ int not_none = 0, not_all = 0;
+ const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
for (i = 0 ; i < len ; ++i) {
- accumulate |= ptr[i] ;
- any_fatals |= (ptr[i] & 0xAA) ;
+ not_none |= ptr[i];
+ not_all |= ptr[i] ^ 0x55;
}
- if (!accumulate) {
+ if (!not_none) {
if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_NONE;
- }
- /* Yuck. I can't see how to abstract this: */
- else if (isWARN_on(
- ((STRLEN *)SvPV_nolen_const(sv)) - 1,
- WARN_ALL)
- && !any_fatals)
- {
- if (!specialWARN(PL_compiling.cop_warnings))
+ } else if (len >= WARNsize && !not_all) {
+ if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_ALL;
PL_dowarn |= G_WARN_ONCE ;
#else
# define PERL_VMS_BANG 0
#endif
-#if defined(WIN32) && ! defined(UNDER_CE)
+#if defined(WIN32)
SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
(SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
#else
{
const char *p = SvPV_const(sv, len);
Groups_t *gary = NULL;
- const char* endptr;
+ const char* p_end = p + len;
+ const char* endptr = p_end;
UV uv;
#ifdef _SC_NGROUPS_MAX
int maxgrp = sysconf(_SC_NGROUPS_MAX);
if (endptr == NULL)
break;
p = endptr;
+ endptr = p_end;
while (isSPACE(*p))
++p;
if (!*p)
https://perl5.git.perl.org / perl5.git / blobdiff