NORETURN_FUNCTION_END;
}
+#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
+# define ALWAYS_NEED_THX
+#endif
+
/* paranoid version of system's malloc() */
Malloc_t
Perl_safesysmalloc(MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
#ifdef HAS_64K_LIMIT
if (size > 0xffff) {
#endif
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
PERL_ALLOC_CHECK(ptr);
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
if (ptr != NULL) {
#ifdef PERL_TRACK_MEMPOOL
struct perl_memory_debug_header *const header
# endif
ptr = (Malloc_t)((char*)ptr+sTHX);
#endif
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
return ptr;
}
- else if (PL_nomemok)
- return NULL;
else {
- return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ else {
+ return write_no_mem();
+ }
}
/*NOTREACHED*/
}
Malloc_t
Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
Malloc_t PerlMem_realloc();
if (ptr != NULL) {
return ptr;
}
- else if (PL_nomemok)
- return NULL;
else {
- return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ else {
+ return write_no_mem();
+ }
}
/*NOTREACHED*/
}
Free_t
Perl_safesysfree(Malloc_t where)
{
-#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
+#ifdef ALWAYS_NEED_THX
dTHX;
#else
dVAR;
Malloc_t
Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
{
+#ifdef ALWAYS_NEED_THX
dTHX;
+#endif
Malloc_t ptr;
MEM_SIZE total_size = 0;
#endif
return ptr;
}
- else if (PL_nomemok)
- return NULL;
- return write_no_mem();
+ else {
+#ifndef ALWAYS_NEED_THX
+ dTHX;
+#endif
+ if (PL_nomemok)
+ return NULL;
+ return write_no_mem();
+ }
}
/* These must be defined when not using Perl's malloc for binary
return NULL;
}
+/*
+=for apidoc foldEQ
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
+match themselves and their opposite case counterparts. Non-cased and non-ASCII
+range bytes match only themselves.
+
+=cut
+*/
+
+
I32
-Perl_ibcmp(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ(const char *s1, const char *s2, register I32 len)
{
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
- PERL_ARGS_ASSERT_IBCMP;
+ PERL_ARGS_ASSERT_FOLDEQ;
while (len--) {
if (*a != *b && *a != PL_fold[*b])
- return 1;
+ return 0;
a++,b++;
}
- return 0;
+ return 1;
}
+/*
+=for apidoc foldEQ_locale
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively in the current locale; false otherwise.
+
+=cut
+*/
+
I32
-Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
{
dVAR;
register const U8 *a = (const U8 *)s1;
register const U8 *b = (const U8 *)s2;
- PERL_ARGS_ASSERT_IBCMP_LOCALE;
+ PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
while (len--) {
if (*a != *b && *a != PL_fold_locale[*b])
- return 1;
+ return 0;
a++,b++;
}
- return 0;
+ return 1;
}
/* copy a string to a safe spot */
return (char *) CopyD(pv,newaddr,len,char);
}
+/*
+=for apidoc savesharedsvpv
+
+A version of C<savesharedpv()> which allocates the duplicate string in
+memory which is shared between threads.
+
+=cut
+*/
+
+char *
+Perl_savesharedsvpv(pTHX_ SV *sv)
+{
+ STRLEN len;
+ const char * const pv = SvPV_const(sv, len);
+
+ PERL_ARGS_ASSERT_SAVESHAREDSVPV;
+
+ return savesharedpvn(pv, len);
+}
/* the SV for Perl_form() and mess() is not kept in an arena */
SV *sv;
XPVMG *any;
- if (!PL_dirty)
+ if (PL_phase != PERL_PHASE_DESTRUCT)
return newSVpvs_flags("", SVs_TEMP);
if (PL_mess_sv)
line_mode ? "line" : "chunk",
(IV)IoLINES(GvIOp(PL_last_in_gv)));
}
- if (PL_dirty)
+ if (PL_phase == PERL_PHASE_DESTRUCT)
sv_catpvs(sv, " during global destruction");
sv_catpvs(sv, ".\n");
}
dSAVED_ERRNO;
#endif
PerlIO * const serr = Perl_error_log;
- STRLEN msglen;
- const char* message = SvPVx_const(msv, msglen);
- PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
+ do_print(msv, serr);
(void)PerlIO_flush(serr);
#ifdef USE_SFIO
RESTORE_ERRNO;
}
/*
+=for apidoc Am|void|croak_no_modify
+
+Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
+terser object code than using C<Perl_croak>. Less code used on exception code
+paths reduces CPU cache pressure.
+
+=cut
+*/
+
+void
+Perl_croak_no_modify(pTHX)
+{
+ Perl_croak(aTHX_ "%s", PL_no_modify);
+}
+
+/*
=for apidoc Am|void|warn_sv|SV *baseex
This is an XS interface to Perl's C<warn> function.
void
Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
{
- const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
+ const char * const name
+ = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
if (ckWARN(WARN_IO)) {
char
Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
{
-
+
U8 result;
if (! isASCII(source)) {
Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\". If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
}
else if (output_warning) {
+ U8 clearer[3];
+ U8 i = 0;
+ if (! isALNUM(result)) {
+ clearer[i++] = '\\';
+ }
+ clearer[i++] = result;
+ clearer[i++] = '\0';
+
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "\"\\c%c\" more clearly written simply as \"%c\"",
+ "\"\\c%c\" more clearly written simply as \"%s\"",
source,
- result);
+ clearer);
}
}
return result;
}
+bool
+Perl_grok_bslash_o(pTHX_ const char *s,
+ UV *uv,
+ STRLEN *len,
+ const char** error_msg,
+ const bool output_warning)
+{
+
+/* Documentation to be supplied when interface nailed down finally
+ * This returns FALSE if there is an error which the caller need not recover
+ * from; , otherwise TRUE. In either case the caller should look at *len
+ * On input:
+ * s points to a string that begins with 'o', and the previous character
+ * was a backslash.
+ * uv points to a UV that will hold the output value, valid only if the
+ * return from the function is TRUE
+ * len on success will point to the next character in the string past the
+ * end of this construct.
+ * on failure, it will point to the failure
+ * error_msg is a pointer that will be set to an internal buffer giving an
+ * error message upon failure (the return is FALSE). Untouched if
+ * function succeeds
+ * output_warning says whether to output any warning messages, or suppress
+ * them
+ */
+ const char* e;
+ STRLEN numbers_len;
+ I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
+ | PERL_SCAN_DISALLOW_PREFIX
+ /* XXX Until the message is improved in grok_oct, handle errors
+ * ourselves */
+ | PERL_SCAN_SILENT_ILLDIGIT;
+
+ PERL_ARGS_ASSERT_GROK_BSLASH_O;
+
+
+ assert(*s == 'o');
+ s++;
+
+ if (*s != '{') {
+ *len = 1; /* Move past the o */
+ *error_msg = "Missing braces on \\o{}";
+ return FALSE;
+ }
+
+ e = strchr(s, '}');
+ if (!e) {
+ *len = 2; /* Move past the o{ */
+ *error_msg = "Missing right brace on \\o{";
+ return FALSE;
+ }
+
+ /* Return past the '}' no matter what is inside the braces */
+ *len = e - s + 2; /* 2 = 1 for the o + 1 for the '}' */
+
+ s++; /* Point to first digit */
+
+ numbers_len = e - s;
+ if (numbers_len == 0) {
+ *error_msg = "Number with no digits";
+ return FALSE;
+ }
+
+ *uv = NATIVE_TO_UNI(grok_oct(s, &numbers_len, &flags, NULL));
+ /* Note that if has non-octal, will ignore everything starting with that up
+ * to the '}' */
+
+ if (output_warning && numbers_len != (STRLEN) (e - s)) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
+ /* diag_listed_as: Non-octal character '%c'. Resolved as "%s" */
+ "Non-octal character '%c'. Resolved as \"\\o{%.*s}\"",
+ *(s + numbers_len),
+ (int) numbers_len,
+ s);
+ }
+
+ return TRUE;
+}
+
/* To workaround core dumps from the uninitialised tm_zone we get the
* system to give us a reasonable struct to copy. This fix means that
* strftime uses the tm_zone and tm_gmtoff values returned by
const int fmtlen = strlen(fmt);
int bufsize = fmtlen + buflen;
- Newx(buf, bufsize, char);
+ Renew(buf, bufsize, char);
while (buf) {
buflen = strftime(buf, bufsize, fmt, &mytm);
if (buflen > 0 && buflen < bufsize)
saw_decimal++;
d++;
}
- else if (!*d || *d == ';' || isSPACE(*d) || *d == '}') {
+ else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
if ( d == s ) {
/* found nothing */
BADVERSION(s,errstr,"Invalid version format (version required)");
/* scan the fractional part after the decimal point*/
- if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '}') )) {
+ if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
/* strict or lax-but-not-the-end */
BADVERSION(s,errstr,"Invalid version format (fractional part required)");
}
while (isSPACE(*d))
d++;
- if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '}') )) {
+ if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
/* trailing non-numeric data */
BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
}
/*
=for apidoc vverify
-Validates that the SV contains a valid version object.
+Validates that the SV contains valid internal structure for a version object.
+It may be passed either the version object (RV) or the hash itself (HV). If
+the structure is valid, it returns the HV. If the structure is invalid,
+it returns NULL.
- bool vverify(SV *vobj);
+ SV *hv = vverify(sv);
Note that it only confirms the bare minimum structure (so as not to get
confused by derived classes which may contain additional hash entries):
=over 4
-=item * The SV contains a [reference to a] hash
+=item * The SV is an HV or a reference to an HV
=item * The hash contains a "version" key
-=item * The "version" key has [a reference to] an AV as its value
+=item * The "version" key has a reference to an AV as its value
=back
=cut
*/
-bool
+SV *
Perl_vverify(pTHX_ SV *vs)
{
SV *sv;
&& hv_exists(MUTABLE_HV(vs), "version", 7)
&& (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
&& SvTYPE(sv) == SVt_PVAV )
- return TRUE;
+ return vs;
else
- return FALSE;
+ return NULL;
}
/*
PERL_ARGS_ASSERT_VNUMIFY;
- if ( SvROK(vs) )
- vs = SvRV(vs);
-
- if ( !vverify(vs) )
+ /* extract the HV from the object */
+ vs = vverify(vs);
+ if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
/* see if various flags exist */
PERL_ARGS_ASSERT_VNORMAL;
- if ( SvROK(vs) )
- vs = SvRV(vs);
-
- if ( !vverify(vs) )
+ /* extract the HV from the object */
+ vs = vverify(vs);
+ if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
{
PERL_ARGS_ASSERT_VSTRINGIFY;
- if ( SvROK(vs) )
- vs = SvRV(vs);
-
- if ( !vverify(vs) )
+ /* extract the HV from the object */
+ vs = vverify(vs);
+ if ( ! vs )
Perl_croak(aTHX_ "Invalid version object");
if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
PERL_ARGS_ASSERT_VCMP;
- if ( SvROK(lhv) )
- lhv = SvRV(lhv);
- if ( SvROK(rhv) )
- rhv = SvRV(rhv);
-
- if ( !vverify(lhv) )
- Perl_croak(aTHX_ "Invalid version object");
-
- if ( !vverify(rhv) )
+ /* extract the HVs from the objects */
+ lhv = vverify(lhv);
+ rhv = vverify(rhv);
+ if ( ! ( lhv && rhv ) )
Perl_croak(aTHX_ "Invalid version object");
/* get the left hand term */
opt = (U32) atoi(p);
while (isDIGIT(*p))
p++;
- if (*p && *p != '\n' && *p != '\r')
+ if (*p && *p != '\n' && *p != '\r') {
+ if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+ else
Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
+ }
}
else {
for (; *p; p++) {
case PERL_UNICODE_UTF8CACHEASSERT:
opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
default:
- if (*p != '\n' && *p != '\r')
+ if (*p != '\n' && *p != '\r') {
+ if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+ else
Perl_croak(aTHX_
"Unknown Unicode option letter '%c'", *p);
+ }
}
}
}
else
opt = PERL_UNICODE_DEFAULT_FLAGS;
+ the_end_of_the_opts_parser:
+
if (opt & ~PERL_UNICODE_ALL_FLAGS)
Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
(UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
#endif /* PERL_IMPLICIT_CONTEXT */
+void
+Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
+ STRLEN xs_len)
+{
+ SV *sv;
+ const char *vn = NULL;
+ SV *const module = PL_stack_base[ax];
+
+ PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
+
+ if (items >= 2) /* version supplied as bootstrap arg */
+ sv = PL_stack_base[ax + 1];
+ else {
+ /* XXX GV_ADDWARN */
+ vn = "XS_VERSION";
+ sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+ if (!sv || !SvOK(sv)) {
+ vn = "VERSION";
+ sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+ }
+ }
+ if (sv) {
+ SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
+ SV *pmsv = sv_derived_from(sv, "version")
+ ? sv : sv_2mortal(new_version(sv));
+ xssv = upg_version(xssv, 0);
+ if ( vcmp(pmsv,xssv) ) {
+ SV *string = vstringify(xssv);
+ SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
+ " does not match ", module, string);
+
+ SvREFCNT_dec(string);
+ string = vstringify(pmsv);
+
+ if (vn) {
+ Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
+ string);
+ } else {
+ Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
+ }
+ SvREFCNT_dec(string);
+
+ Perl_sv_2mortal(aTHX_ xpt);
+ Perl_croak_sv(aTHX_ xpt);
+ }
+ }
+}
+
+void
+Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
+ STRLEN api_len)
+{
+ SV *xpt = NULL;
+ SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
+ SV *runver;
+
+ PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
+
+ /* This might croak */
+ compver = upg_version(compver, 0);
+ /* This should never croak */
+ runver = new_version(PL_apiversion);
+ if (vcmp(compver, runver)) {
+ SV *compver_string = vstringify(compver);
+ SV *runver_string = vstringify(runver);
+ xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
+ " of %"SVf" does not match %"SVf,
+ compver_string, module, runver_string);
+ Perl_sv_2mortal(aTHX_ xpt);
+
+ SvREFCNT_dec(compver_string);
+ SvREFCNT_dec(runver_string);
+ }
+ SvREFCNT_dec(runver);
+ if (xpt)
+ Perl_croak_sv(aTHX_ xpt);
+}
+
#ifndef HAS_STRLCAT
Size_t
Perl_my_strlcat(char *dst, const char *src, Size_t size)
{
dVAR;
SV * const dbsv = GvSVn(PL_DBsub);
+ const bool save_taint = PL_tainted;
+
/* We do not care about using sv to call CV;
* it's for informational purposes only.
*/
PERL_ARGS_ASSERT_GET_DB_SUB;
+ PL_tainted = FALSE;
save_item(dbsv);
if (!PERLDB_SUB_NN) {
- GV * const gv = CvGV(cv);
+ GV *gv = CvGV(cv);
if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
|| strEQ(GvNAME(gv), "END")
|| ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
!( (SvTYPE(*svp) == SVt_PVGV)
- && (GvCV((const GV *)*svp) == cv) )))) {
+ && (GvCV((const GV *)*svp) == cv)
+ && (gv = (GV *)*svp)
+ )
+ )
+ )) {
/* Use GV from the stack as a fallback. */
/* GV is potentially non-unique, or contain different CV. */
SV * const tmp = newRV(MUTABLE_SV(cv));
(void)SvIOK_on(dbsv);
SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
}
+ TAINT_IF(save_taint);
}
int
https://perl5.git.perl.org / perl5.git / blobdiff