#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 {
}
return 1;
}
+I32
+Perl_foldEQ_latin1(const char *s1, const char *s2, register I32 len)
+{
+ /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on
+ * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
+ * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor
+ * does it check that the strings each have at least 'len' characters */
+
+ register const U8 *a = (const U8 *)s1;
+ register const U8 *b = (const U8 *)s2;
+
+ PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
+
+ while (len--) {
+ if (*a != *b && *a != PL_fold_latin1[*b]) {
+ return 0;
+ }
+ a++, b++;
+ }
+ return 1;
+}
/*
=for apidoc foldEQ_locale
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");
}
PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
PUSHs(msv);
PUTBACK;
- call_method("PRINT", G_SCALAR);
+ call_method("PRINT", G_SCALAR | G_DISCARD);
POPSTACK;
FREETMPS;
}
void
-Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
-{
- 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)) {
- const char * const direction =
- (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
- if (name && *name)
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %s opened only for %sput",
- name, direction);
- else
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle opened only for %sput", direction);
- }
+Perl_report_wrongway_fh(pTHX_ const GV *gv, char have)
+{
+ if (ckWARN(WARN_IO)) {
+ const char * const name
+ = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+ const char * const direction = have == '>' ? "out" : "in";
+
+ if (name && *name)
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "Filehandle %s opened only for %sput",
+ name, direction);
+ else
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "Filehandle opened only for %sput", direction);
}
- else {
- const char *vile;
- I32 warn_type;
+}
+
+void
+Perl_report_evil_fh(pTHX_ const GV *gv)
+{
+ const IO *io = gv ? GvIO(gv) : NULL;
+ const PERL_BITFIELD16 op = PL_op->op_type;
+ const char *vile;
+ I32 warn_type;
- if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
- vile = "closed";
- warn_type = WARN_CLOSED;
+ if (io && IoTYPE(io) == IoTYPE_CLOSED) {
+ vile = "closed";
+ warn_type = WARN_CLOSED;
+ }
+ else {
+ vile = "unopened";
+ warn_type = WARN_UNOPENED;
+ }
+
+ if (ckWARN(warn_type)) {
+ const char * const name
+ = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+ const char * const pars =
+ (const char *)(OP_IS_FILETEST(op) ? "" : "()");
+ const char * const func =
+ (const char *)
+ (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
+ op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
+ PL_op_desc[op]);
+ const char * const type =
+ (const char *)
+ (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
+ ? "socket" : "filehandle");
+ if (name && *name) {
+ Perl_warner(aTHX_ packWARN(warn_type),
+ "%s%s on %s %s %s", func, pars, vile, type, name);
+ if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+ Perl_warner(
+ aTHX_ packWARN(warn_type),
+ "\t(Are you trying to call %s%s on dirhandle %s?)\n",
+ func, pars, name
+ );
}
else {
- vile = "unopened";
- warn_type = WARN_UNOPENED;
- }
-
- if (ckWARN(warn_type)) {
- const char * const pars =
- (const char *)(OP_IS_FILETEST(op) ? "" : "()");
- const char * const func =
- (const char *)
- (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
- op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
- op < 0 ? "" : /* handle phoney cases */
- PL_op_desc[op]);
- const char * const type =
- (const char *)
- (OP_IS_SOCKET(op) ||
- (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
- "socket" : "filehandle");
- if (name && *name) {
- Perl_warner(aTHX_ packWARN(warn_type),
- "%s%s on %s %s %s", func, pars, vile, type, name);
- if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
- Perl_warner(
- aTHX_ packWARN(warn_type),
- "\t(Are you trying to call %s%s on dirhandle %s?)\n",
- func, pars, name
- );
- }
- else {
- Perl_warner(aTHX_ packWARN(warn_type),
- "%s%s on %s %s", func, pars, vile, type);
- if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
- Perl_warner(
- aTHX_ packWARN(warn_type),
- "\t(Are you trying to call %s%s on dirhandle?)\n",
- func, pars
- );
- }
+ Perl_warner(aTHX_ packWARN(warn_type),
+ "%s%s on %s %s", func, pars, vile, type);
+ if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+ Perl_warner(
+ aTHX_ packWARN(warn_type),
+ "\t(Are you trying to call %s%s on dirhandle?)\n",
+ func, pars
+ );
}
}
}
/*
=for apidoc prescan_version
+Validate that a given string can be parsed as a version object, but doesn't
+actually perform the parsing. Can use either strict or lax validation rules.
+Can optionally set a number of hint variables to save the parsing code
+some time when tokenizing.
+
=cut
*/
const char *
#ifndef SvVOK
# if PERL_VERSION > 5
/* This will only be executed for 5.6.0 - 5.8.0 inclusive */
- if ( len >= 3 && !instr(version,".") && !instr(version,"_")
- && !(*version == 'u' && strEQ(version, "undef"))
- && (*version < '0' || *version > '9') ) {
+ if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
/* may be a v-string */
- SV * const nsv = sv_newmortal();
- const char *nver;
- const char *pos;
- int saw_decimal = 0;
- sv_setpvf(nsv,"v%vd",ver);
- pos = nver = savepv(SvPV_nolen(nsv));
-
- /* scan the resulting formatted string */
- pos++; /* skip the leading 'v' */
- while ( *pos == '.' || isDIGIT(*pos) ) {
- if ( *pos == '.' )
- saw_decimal++ ;
- pos++;
- }
+ char *testv = (char *)version;
+ STRLEN tlen = len;
+ for (tlen=0; tlen < len; tlen++, testv++) {
+ /* if one of the characters is non-text assume v-string */
+ if (testv[0] < ' ') {
+ SV * const nsv = sv_newmortal();
+ const char *nver;
+ const char *pos;
+ int saw_decimal = 0;
+ sv_setpvf(nsv,"v%vd",ver);
+ pos = nver = savepv(SvPV_nolen(nsv));
+
+ /* scan the resulting formatted string */
+ pos++; /* skip the leading 'v' */
+ while ( *pos == '.' || isDIGIT(*pos) ) {
+ if ( *pos == '.' )
+ saw_decimal++ ;
+ pos++;
+ }
- /* is definitely a v-string */
- if ( saw_decimal >= 2 ) {
- Safefree(version);
- version = nver;
+ /* is definitely a v-string */
+ if ( saw_decimal >= 2 ) {
+ Safefree(version);
+ version = nver;
+ }
+ break;
+ }
}
}
# endif
/*
=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;
}
/*
NOTE: you can pass either the object directly or the SV
contained within the RV.
+The SV returned has a refcount of 1.
+
=cut
*/
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 */
NOTE: you can pass either the object directly or the SV
contained within the RV.
+The SV returned has a refcount of 1.
+
=cut
*/
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 ) )
In order to maintain maximum compatibility with earlier versions
of Perl, this function will return either the floating point
notation or the multiple dotted notation, depending on whether
-the original version contained 1 or more dots, respectively
+the original version contained 1 or more dots, respectively.
+
+The SV returned has a refcount of 1.
=cut
*/
{
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 */
{
SV *sv;
const char *vn = NULL;
- const char *module = SvPV_nolen_const(PL_stack_base[ax]);
+ SV *const module = PL_stack_base[ax];
PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
sv = PL_stack_base[ax + 1];
else {
/* XXX GV_ADDWARN */
- sv = get_sv(Perl_form(aTHX_ "%s::%s", module, vn = "XS_VERSION"), 0);
- if (!sv || !SvOK(sv))
- sv = get_sv(Perl_form(aTHX_ "%s::%s", module, vn = "VERSION"), 0);
+ 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 *xpt = NULL;
- SV *xssv = Perl_newSVpvn(aTHX_ xs_p, xs_len);
+ SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
SV *pmsv = sv_derived_from(sv, "version")
- ? SvREFCNT_inc_simple_NN(sv)
- : new_version(sv);
+ ? sv : sv_2mortal(new_version(sv));
xssv = upg_version(xssv, 0);
if ( vcmp(pmsv,xssv) ) {
- xpt = Perl_newSVpvf(aTHX_ "%s object version %"SVf
- " does not match %s%s%s%s %"SVf,
- module,
- SVfARG(Perl_sv_2mortal(aTHX_ vstringify(xssv))),
- vn ? "$" : "", vn ? module : "",
- vn ? "::" : "",
- vn ? vn : "bootstrap parameter",
- SVfARG(Perl_sv_2mortal(aTHX_ vstringify(pmsv))));
+ 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);
- }
- SvREFCNT_dec(xssv);
- SvREFCNT_dec(pmsv);
- if (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)
https://perl5.git.perl.org / perl5.git / blobdiff