}
}
-/* Common code used by vcroak, vdie and vwarner */
+/* Common code used by vcroak, vdie, vwarn and vwarner */
-STATIC void
-S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
+STATIC bool
+S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
{
dVAR;
HV *stash;
GV *gv;
CV *cv;
- /* sv_2cv might call Perl_croak() */
- SV * const olddiehook = PL_diehook;
+ SV **const hook = warn ? &PL_warnhook : &PL_diehook;
+ /* sv_2cv might call Perl_croak() or Perl_warner() */
+ SV * const oldhook = *hook;
+
+ assert(oldhook);
- assert(PL_diehook);
ENTER;
- SAVESPTR(PL_diehook);
- PL_diehook = Nullsv;
- cv = sv_2cv(olddiehook, &stash, &gv, 0);
+ SAVESPTR(*hook);
+ *hook = NULL;
+ cv = sv_2cv(oldhook, &stash, &gv, 0);
LEAVE;
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
dSP;
ENTER;
save_re_context();
- if (message) {
+ if (warn) {
+ SAVESPTR(*hook);
+ *hook = NULL;
+ }
+ if (warn || message) {
msg = newSVpvn(message, msglen);
SvFLAGS(msg) |= utf8;
SvREADONLY_on(msg);
msg = ERRSV;
}
- PUSHSTACKi(PERLSI_DIEHOOK);
+ PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
call_sv((SV*)cv, G_DISCARD);
POPSTACK;
LEAVE;
+ return TRUE;
}
+ return FALSE;
}
STATIC const char *
"%p: die/croak: message = %s\ndiehook = %p\n",
thr, message, PL_diehook));
if (PL_diehook) {
- S_vdie_common(aTHX_ message, *msglen, *utf8);
+ S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
}
return message;
}
const char * const message = SvPV_const(msv, msglen);
if (PL_warnhook) {
- /* sv_2cv might call Perl_warn() */
- SV * const oldwarnhook = PL_warnhook;
- CV * cv;
- HV * stash;
- GV * gv;
-
- ENTER;
- SAVESPTR(PL_warnhook);
- PL_warnhook = Nullsv;
- cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
- LEAVE;
- if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
- dSP;
- SV *msg;
-
- ENTER;
- SAVESPTR(PL_warnhook);
- PL_warnhook = Nullsv;
- save_re_context();
- msg = newSVpvn(message, msglen);
- SvFLAGS(msg) |= utf8;
- SvREADONLY_on(msg);
- SAVEFREESV(msg);
-
- PUSHSTACKi(PERLSI_WARNHOOK);
- PUSHMARK(SP);
- XPUSHs(msg);
- PUTBACK;
- call_sv((SV*)cv, G_DISCARD);
- POPSTACK;
- LEAVE;
+ if (vdie_common(message, msglen, utf8, TRUE))
return;
- }
}
write_to_stderr(message, msglen);
if (PL_diehook) {
assert(message);
- S_vdie_common(aTHX_ message, msglen, utf8);
+ S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
}
if (PL_in_eval) {
PL_restartop = die_where(message, msglen);
PerlProc__exit(1);
}
#endif /* defined OS2 */
- if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
+ if ((tmpgv = gv_fetchpvs("$",TRUE, SVt_PV))) {
SvREADONLY_off(GvSV(tmpgv));
sv_setiv(GvSV(tmpgv), PerlProc_getpid());
SvREADONLY_on(GvSV(tmpgv));
if ( hv_exists((HV*)ver, "width", 5 ) )
{
- const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE));
+ const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
hv_store((HV *)hv, "width", 5, newSViv(width), 0);
}
- sav = (AV *)SvRV(*hv_fetch((HV*)ver, "version", 7, FALSE));
+ sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
/* This will get reblessed later if a derived class*/
for ( key = 0; key <= av_len(sav); key++ )
{
return rv;
}
#ifdef SvVOK
- if ( SvVOK(ver) ) { /* already a v-string */
- const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
- const STRLEN len = mg->mg_len;
- char * const version = savepvn( (const char*)mg->mg_ptr, len);
- sv_setpvn(rv,version,len);
- Safefree(version);
- }
- else {
+ {
+ const MAGIC* const mg = SvVOK(ver);
+ if ( mg ) { /* already a v-string */
+ const STRLEN len = mg->mg_len;
+ char * const version = savepvn( (const char*)mg->mg_ptr, len);
+ sv_setpvn(rv,version,len);
+ Safefree(version);
+ }
+ else {
#endif
- sv_setsv(rv,ver); /* make a duplicate */
+ sv_setsv(rv,ver); /* make a duplicate */
#ifdef SvVOK
+ }
}
#endif
- upg_version(rv);
- return rv;
+ return upg_version(rv);
}
/*
{
const char *version, *s;
bool qv = 0;
+#ifdef SvVOK
+ const MAGIC *mg;
+#endif
if ( SvNOK(ver) ) /* may get too much accuracy */
{
version = savepvn(tbuf, len);
}
#ifdef SvVOK
- else if ( SvVOK(ver) ) { /* already a v-string */
- const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring);
+ else if ( (mg = SvVOK(ver)) ) { /* already a v-string */
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
qv = 1;
}
version = savepv(SvPV_nolen(ver));
}
s = scan_version(version, ver, qv);
- if ( *s != '\0' )
- Perl_warn(aTHX_ "Version string '%s' contains invalid data; "
- "ignoring: '%s'", version, s);
+ if ( *s != '\0' )
+ if(ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Version string '%s' contains invalid data; "
+ "ignoring: '%s'", version, s);
Safefree(version);
return ver;
}
/* see if the appropriate elements exist */
if ( SvTYPE(vs) == SVt_PVHV
&& hv_exists((HV*)vs, "version", 7)
- && (sv = SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)))
+ && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
&& SvTYPE(sv) == SVt_PVAV )
return TRUE;
else
if ( hv_exists((HV*)vs, "alpha", 5 ) )
alpha = TRUE;
if ( hv_exists((HV*)vs, "width", 5 ) )
- width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE));
+ width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
else
width = 3;
/* attempt to retrieve the version array */
- if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) {
+ if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
sv_catpvs(sv,"0");
return sv;
}
if ( hv_exists((HV*)vs, "alpha", 5 ) )
alpha = TRUE;
- av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE));
+ av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
len = av_len(av);
if ( len == -1 )
Perl_croak(aTHX_ "Invalid version object");
/* get the left hand term */
- lav = (AV *)SvRV(*hv_fetch((HV*)lhv, "version", 7, FALSE));
+ lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
if ( hv_exists((HV*)lhv, "alpha", 5 ) )
lalpha = TRUE;
/* and the right hand term */
- rav = (AV *)SvRV(*hv_fetch((HV*)rhv, "version", 7, FALSE));
+ rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
if ( hv_exists((HV*)rhv, "alpha", 5 ) )
ralpha = TRUE;