static IV asIV _((SV* sv));
static UV asUV _((SV* sv));
static SV *more_sv _((void));
-static XPVIV *more_xiv _((void));
-static XPVNV *more_xnv _((void));
-static XPV *more_xpv _((void));
-static XRV *more_xrv _((void));
+static void more_xiv _((void));
+static void more_xnv _((void));
+static void more_xpv _((void));
+static void more_xrv _((void));
static XPVIV *new_xiv _((void));
static XPVNV *new_xnv _((void));
static XPV *new_xpv _((void));
new_xiv(void)
{
IV* xiv;
- if (PL_xiv_root) {
- xiv = PL_xiv_root;
- /*
- * See comment in more_xiv() -- RAM.
- */
- PL_xiv_root = *(IV**)xiv;
- return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
- }
- return more_xiv();
+ LOCK_SV_MUTEX;
+ if (!PL_xiv_root)
+ more_xiv();
+ xiv = PL_xiv_root;
+ /*
+ * See comment in more_xiv() -- RAM.
+ */
+ PL_xiv_root = *(IV**)xiv;
+ UNLOCK_SV_MUTEX;
+ return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
}
STATIC void
del_xiv(XPVIV *p)
{
IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
+ LOCK_SV_MUTEX;
*(IV**)xiv = PL_xiv_root;
PL_xiv_root = xiv;
+ UNLOCK_SV_MUTEX;
}
-STATIC XPVIV*
+STATIC void
more_xiv(void)
{
register IV* xiv;
xiv++;
}
*(IV**)xiv = 0;
- return new_xiv();
}
STATIC XPVNV*
new_xnv(void)
{
double* xnv;
- if (PL_xnv_root) {
- xnv = PL_xnv_root;
- PL_xnv_root = *(double**)xnv;
- return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
- }
- return more_xnv();
+ LOCK_SV_MUTEX;
+ if (!PL_xnv_root)
+ more_xnv();
+ xnv = PL_xnv_root;
+ PL_xnv_root = *(double**)xnv;
+ UNLOCK_SV_MUTEX;
+ return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
}
STATIC void
del_xnv(XPVNV *p)
{
double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
+ LOCK_SV_MUTEX;
*(double**)xnv = PL_xnv_root;
PL_xnv_root = xnv;
+ UNLOCK_SV_MUTEX;
}
-STATIC XPVNV*
+STATIC void
more_xnv(void)
{
register double* xnv;
xnv++;
}
*(double**)xnv = 0;
- return new_xnv();
}
STATIC XRV*
new_xrv(void)
{
XRV* xrv;
- if (PL_xrv_root) {
- xrv = PL_xrv_root;
- PL_xrv_root = (XRV*)xrv->xrv_rv;
- return xrv;
- }
- return more_xrv();
+ LOCK_SV_MUTEX;
+ if (!PL_xrv_root)
+ more_xrv();
+ xrv = PL_xrv_root;
+ PL_xrv_root = (XRV*)xrv->xrv_rv;
+ UNLOCK_SV_MUTEX;
+ return xrv;
}
STATIC void
del_xrv(XRV *p)
{
+ LOCK_SV_MUTEX;
p->xrv_rv = (SV*)PL_xrv_root;
PL_xrv_root = p;
+ UNLOCK_SV_MUTEX;
}
-STATIC XRV*
+STATIC void
more_xrv(void)
{
register XRV* xrv;
xrv++;
}
xrv->xrv_rv = 0;
- return new_xrv();
}
STATIC XPV*
new_xpv(void)
{
XPV* xpv;
- if (PL_xpv_root) {
- xpv = PL_xpv_root;
- PL_xpv_root = (XPV*)xpv->xpv_pv;
- return xpv;
- }
- return more_xpv();
+ LOCK_SV_MUTEX;
+ if (!PL_xpv_root)
+ more_xpv();
+ xpv = PL_xpv_root;
+ PL_xpv_root = (XPV*)xpv->xpv_pv;
+ UNLOCK_SV_MUTEX;
+ return xpv;
}
STATIC void
del_xpv(XPV *p)
{
+ LOCK_SV_MUTEX;
p->xpv_pv = (char*)PL_xpv_root;
PL_xpv_root = p;
+ UNLOCK_SV_MUTEX;
}
-STATIC XPV*
+STATIC void
more_xpv(void)
{
register XPV* xpv;
xpv++;
}
xpv->xpv_pv = 0;
- return new_xpv();
}
#ifdef PURIFY
cur = 0;
len = 0;
nv = SvNVX(sv);
- iv = I_32(nv);
+ iv = (IV)nv;
magic = 0;
stash = 0;
del_XNV(SvANY(sv));
*d = '\0';
if (PL_op)
- warn("Argument \"%s\" isn't numeric in %s", tmpbuf,
+ warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
op_name[PL_op->op_type]);
else
- warn("Argument \"%s\" isn't numeric", tmpbuf);
+ warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
}
IV
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
if (!SvROK(sv)) {
- if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ if (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
- if (!PL_localizing)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+ warner(WARN_UNINITIALIZED, warn_uninit);
}
return 0;
}
}
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
- if (PL_dowarn)
- warn(warn_uninit);
+ {
+ dTHR;
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, warn_uninit);
+ }
return 0;
}
}
}
else {
dTHR;
- if (PL_dowarn && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ warner(WARN_UNINITIALIZED, warn_uninit);
return 0;
}
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
if (SvPOKp(sv) && SvLEN(sv))
return asUV(sv);
if (!SvROK(sv)) {
- if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ if (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
- if (!PL_localizing)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+ warner(WARN_UNINITIALIZED, warn_uninit);
}
return 0;
}
}
if (SvPOKp(sv) && SvLEN(sv))
return asUV(sv);
- if (PL_dowarn)
- warn(warn_uninit);
+ {
+ dTHR;
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, warn_uninit);
+ }
return 0;
}
}
SvUVX(sv) = asUV(sv);
}
else {
- if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ if (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
- if (!PL_localizing)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+ warner(WARN_UNINITIALIZED, warn_uninit);
}
return 0;
}
if (SvNOKp(sv))
return SvNVX(sv);
if (SvPOKp(sv) && SvLEN(sv)) {
- if (PL_dowarn && !SvIOKp(sv) && !looks_like_number(sv))
+ dTHR;
+ if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
if (SvIOKp(sv))
return (double)SvIVX(sv);
if (!SvROK(sv)) {
- if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ if (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
- if (!PL_localizing)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+ warner(WARN_UNINITIALIZED, warn_uninit);
}
return 0;
}
return (double)(unsigned long)SvRV(sv);
}
if (SvREADONLY(sv)) {
+ dTHR;
if (SvPOKp(sv) && SvLEN(sv)) {
- if (PL_dowarn && !SvIOKp(sv) && !looks_like_number(sv))
+ if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
}
if (SvIOKp(sv))
return (double)SvIVX(sv);
- if (PL_dowarn)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, warn_uninit);
return 0.0;
}
}
SvNVX(sv) = (double)SvIVX(sv);
}
else if (SvPOKp(sv) && SvLEN(sv)) {
- if (PL_dowarn && !SvIOKp(sv) && !looks_like_number(sv))
+ dTHR;
+ if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SET_NUMERIC_STANDARD();
SvNVX(sv) = atof(SvPVX(sv));
}
else {
dTHR;
- if (PL_dowarn && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ warner(WARN_UNINITIALIZED, warn_uninit);
return 0.0;
}
SvNOK_on(sv);
if (numtype == 1)
return atol(SvPVX(sv));
- if (!numtype && PL_dowarn)
- not_a_number(sv);
+ if (!numtype) {
+ dTHR;
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+ }
SET_NUMERIC_STANDARD();
d = atof(SvPVX(sv));
if (d < 0.0)
if (numtype == 1)
return strtoul(SvPVX(sv), Null(char**), 10);
#endif
- if (!numtype && PL_dowarn)
- not_a_number(sv);
+ if (!numtype) {
+ dTHR;
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+ }
SET_NUMERIC_STANDARD();
return U_V(atof(SvPVX(sv)));
}
goto tokensave;
}
if (!SvROK(sv)) {
- if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ if (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
- if (!PL_localizing)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+ warner(WARN_UNINITIALIZED, warn_uninit);
}
*lp = 0;
return "";
tsv = Nullsv;
goto tokensave;
}
- if (PL_dowarn)
- warn(warn_uninit);
+ {
+ dTHR;
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, warn_uninit);
+ }
*lp = 0;
return "";
}
}
else {
dTHR;
- if (PL_dowarn && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ warner(WARN_UNINITIALIZED, warn_uninit);
*lp = 0;
return "";
}
if (sflags & SVf_ROK) {
if (dtype >= SVt_PV) {
if (dtype == SVt_PVGV) {
- dTHR;
SV *sref = SvREFCNT_inc(SvRV(sstr));
SV *dref = 0;
int intro = GvINTRO(dstr);
croak(
"Can't redefine active sort subroutine %s",
GvENAME((GV*)dstr));
- if (PL_dowarn || (const_changed && const_sv)) {
+ if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
if (!(CvGV(cv) && GvSTASH(CvGV(cv))
&& HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))),
"autouse")))
- warn(const_sv ?
+ warner(WARN_REDEFINE, const_sv ?
"Constant subroutine %s redefined"
: "Subroutine %s redefined",
GvENAME((GV*)dstr));
}
else {
if (dtype == SVt_PVGV) {
- if (PL_dowarn)
- warn("Undefined value assigned to typeglob");
+ if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Undefined value assigned to typeglob");
}
else
(void)SvOK_off(dstr);
(void)SvOK_off(sv);
return;
}
+ (void)SvOOK_off(sv);
if (SvPVX(sv))
Safefree(SvPVX(sv));
Renew(ptr, len+1, char);
case 'B':
mg->mg_virtual = &vtbl_bm;
break;
+ case 'D':
+ mg->mg_virtual = &vtbl_regdata;
+ break;
+ case 'd':
+ mg->mg_virtual = &vtbl_regdatum;
+ break;
case 'E':
mg->mg_virtual = &vtbl_env;
break;
stash = NULL;
switch (SvTYPE(sv)) {
case SVt_PVIO:
- if (IoIFP(sv) != PerlIO_stdin() &&
+ if (IoIFP(sv) &&
+ IoIFP(sv) != PerlIO_stdin() &&
IoIFP(sv) != PerlIO_stdout() &&
IoIFP(sv) != PerlIO_stderr())
io_close((IO*)sv);
return len;
}
+STRLEN
+sv_len_utf8(register SV *sv)
+{
+ U8 *s;
+ U8 *send;
+ STRLEN len;
+
+ if (!sv)
+ return 0;
+
+#ifdef NOTYET
+ if (SvGMAGICAL(sv))
+ len = mg_length(sv);
+ else
+#endif
+ s = (U8*)SvPV(sv, len);
+ send = s + len;
+ len = 0;
+ while (s < send) {
+ s += UTF8SKIP(s);
+ len++;
+ }
+ return len;
+}
+
+void
+sv_pos_u2b(register SV *sv, I32* offsetp, I32* lenp)
+{
+ U8 *start;
+ U8 *s;
+ U8 *send;
+ I32 uoffset = *offsetp;
+ STRLEN len;
+
+ if (!sv)
+ return;
+
+ start = s = (U8*)SvPV(sv, len);
+ send = s + len;
+ while (s < send && uoffset--)
+ s += UTF8SKIP(s);
+ if (s >= send)
+ s = send;
+ *offsetp = s - start;
+ if (lenp) {
+ I32 ulen = *lenp;
+ start = s;
+ while (s < send && ulen--)
+ s += UTF8SKIP(s);
+ if (s >= send)
+ s = send;
+ *lenp = s - start;
+ }
+ return;
+}
+
+void
+sv_pos_b2u(register SV *sv, I32* offsetp)
+{
+ U8 *s;
+ U8 *send;
+ STRLEN len;
+
+ if (!sv)
+ return;
+
+ s = (U8*)SvPV(sv, len);
+ if (len < *offsetp)
+ croak("panic: bad byte offset");
+ send = s + *offsetp;
+ len = 0;
+ while (s < send) {
+ s += UTF8SKIP(s);
+ ++len;
+ }
+ if (s != send) {
+ warn("Malformed UTF-8 character");
+ --len;
+ }
+ *offsetp = len;
+ return;
+}
+
I32
sv_eq(register SV *str1, register SV *str2)
{
*(d--) = '0';
}
else {
+#ifdef EBCDIC
+ /* MKS: The original code here died if letters weren't consecutive.
+ * at least it didn't have to worry about non-C locales. The
+ * new code assumes that ('z'-'a')==('Z'-'A'), letters are
+ * arranged in order (although not consecutively) and that only
+ * [A-Za-z] are accepted by isALPHA in the C locale.
+ */
+ if (*d != 'z' && *d != 'Z') {
+ do { ++*d; } while (!isALPHA(*d));
+ return;
+ }
+ *(d--) -= 'z' - 'a';
+#else
++*d;
if (isALPHA(*d))
return;
*(d--) -= 'z' - 'a' + 1;
+#endif
}
}
/* oh,oh, the number grew */
}
for (i = 0; i <= (I32) HvMAX(stash); i++) {
for (entry = HvARRAY(stash)[i];
- entry;
- entry = HeNEXT(entry)) {
+ entry;
+ entry = HeNEXT(entry))
+ {
if (!todo[(U8)*HeKEY(entry)])
continue;
gv = (GV*)HeVAL(entry);
sv = GvSV(gv);
+ if (SvTHINKFIRST(sv)) {
+ if (!SvREADONLY(sv) && SvROK(sv))
+ sv_unref(sv);
+ continue;
+ }
(void)SvOK_off(sv);
if (SvTYPE(sv) >= SVt_PV) {
SvCUR_set(sv, 0);
STRLEN precis = 0;
char esignbuf[4];
+ U8 utf8buf[10];
STRLEN esignlen = 0;
char *eptr = Nullch;
goto string;
case 'c':
+ if (IN_UTF8) {
+ if (args)
+ uv = va_arg(*args, int);
+ else
+ uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+
+ eptr = (char*)utf8buf;
+ elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
+ goto string;
+ }
if (args)
c = va_arg(*args, int);
else
elen = sizeof nullstr - 1;
}
}
- else if (svix < svmax)
+ else if (svix < svmax) {
eptr = SvPVx(svargs[svix++], elen);
+ if (IN_UTF8) {
+ if (has_precis && precis < elen) {
+ I32 p = precis;
+ sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
+ precis = p;
+ }
+ if (width) { /* fudge width (can't fudge elen) */
+ width += elen - sv_len_utf8(svargs[svix - 1]);
+ }
+ }
+ }
goto string;
case '_':
default:
unknown:
- if (!args && PL_dowarn &&
+ if (!args && ckWARN(WARN_PRINTF) &&
(PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
SV *msg = sv_newmortal();
sv_setpvf(msg, "Invalid conversion in %s: ",
c & 0xFF);
else
sv_catpv(msg, "end of string");
- warn("%_", msg); /* yes, this is reentrant */
+ warner(WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
}
/* output mangled stuff ... */
https://perl5.git.perl.org / perl5.git / blobdiff