static void del_xrv _((XRV* p));
static void sv_mortalgrow _((void));
static void sv_unglob _((SV* sv));
+static void sv_check_thinkfirst _((SV *sv));
typedef void (*SVFUNC) _((SV*));
#define new_SV(p) \
do { \
+ MUTEX_LOCK(&sv_mutex); \
(p) = (SV*)safemalloc(sizeof(SV)); \
reg_add(p); \
+ MUTEX_UNLOCK(&sv_mutex); \
} while (0)
#define del_SV(p) \
do { \
+ MUTEX_LOCK(&sv_mutex); \
reg_remove(p); \
free((char*)(p)); \
+ MUTEX_UNLOCK(&sv_mutex); \
} while (0)
static SV **registry;
--sv_count; \
} while (0)
-#define uproot_SV(p) \
+/* sv_mutex must be held while calling uproot_SV() */
+#define uproot_SV(p) \
do { \
(p) = sv_root; \
sv_root = (SV*)SvANY(p); \
++sv_count; \
} while (0)
-#define new_SV(p) \
- if (sv_root) \
- uproot_SV(p); \
- else \
- (p) = more_sv()
+#define new_SV(p) do { \
+ MUTEX_LOCK(&sv_mutex); \
+ if (sv_root) \
+ uproot_SV(p); \
+ else \
+ (p) = more_sv(); \
+ MUTEX_UNLOCK(&sv_mutex); \
+ } while (0)
#ifdef DEBUGGING
-#define del_SV(p) \
- if (debug & 32768) \
- del_sv(p); \
- else \
- plant_SV(p)
+#define del_SV(p) do { \
+ MUTEX_LOCK(&sv_mutex); \
+ if (debug & 32768) \
+ del_sv(p); \
+ else \
+ plant_SV(p); \
+ MUTEX_UNLOCK(&sv_mutex); \
+ } while (0)
static void
del_sv(p)
SvFLAGS(sv) = SVTYPEMASK;
}
+/* sv_mutex must be held while calling more_sv() */
static SV*
more_sv()
{
STRLEN prevlen;
int unref = 0;
+ sv_setpvn(t, "", 0);
retry:
if (!sv) {
sv_catpv(t, "VOID");
case SVt_NULL:
sv_catpv(t, "UNDEF");
- return tokenbuf;
+ goto finish;
case SVt_IV:
sv_catpv(t, "IV");
break;
register SV *sv;
IV i;
{
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
sv_upgrade(sv, SVt_IV);
case SVt_PVCV:
case SVt_PVFM:
case SVt_PVIO:
- croak("Can't coerce %s to integer in %s", sv_reftype(sv,0),
- op_name[op->op_type]);
+ {
+ dTHR;
+ croak("Can't coerce %s to integer in %s", sv_reftype(sv,0),
+ op_desc[op->op_type]);
+ }
}
(void)SvIOK_only(sv); /* validate number */
SvIVX(sv) = i;
register SV *sv;
double num;
{
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
case SVt_IV:
case SVt_PVCV:
case SVt_PVFM:
case SVt_PVIO:
- croak("Can't coerce %s to number in %s", sv_reftype(sv,0),
- op_name[op->op_type]);
+ {
+ dTHR;
+ croak("Can't coerce %s to number in %s", sv_reftype(sv,0),
+ op_name[op->op_type]);
+ }
}
SvNVX(sv) = num;
(void)SvNOK_only(sv); /* validate number */
not_a_number(sv)
SV *sv;
{
+ dTHR;
char tmpbuf[64];
char *d = tmpbuf;
char *s;
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
if (!SvROK(sv)) {
+ dTHR; /* just for localizing */
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
return 0;
SvIVX(sv) = asIV(sv);
}
else {
+ dTHR;
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
return 0;
if (SvPOKp(sv) && SvLEN(sv))
return asUV(sv);
if (!SvROK(sv)) {
+ dTHR; /* just for localizing */
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
return 0;
SvUVX(sv) = asUV(sv);
}
else {
+ dTHR; /* just for localizing */
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
return 0;
if (SvIOKp(sv))
return (double)SvIVX(sv);
if (!SvROK(sv)) {
+ dTHR; /* just for localizing */
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
return 0;
SvNVX(sv) = atof(SvPVX(sv));
}
else {
+ dTHR;
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
return 0.0;
{
I32 numtype = looks_like_number(sv);
+#ifdef HAS_STRTOUL
if (numtype == 1)
- return atol(SvPVX(sv));
+ return strtoul(SvPVX(sv), Null(char**), 10);
+#endif
if (!numtype && dowarn)
not_a_number(sv);
SET_NUMERIC_STANDARD();
register char *s;
int olderrno;
SV *tsv;
+ char tmpbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
if (!sv) {
*lp = 0;
return SvPVX(sv);
}
if (SvIOKp(sv)) {
- (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
+ (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
tsv = Nullsv;
goto tokensave;
}
if (SvNOKp(sv)) {
SET_NUMERIC_STANDARD();
- Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
+ Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
tsv = Nullsv;
goto tokensave;
}
if (!SvROK(sv)) {
+ dTHR; /* just for localizing */
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
*lp = 0;
if (SvREADONLY(sv)) {
if (SvNOKp(sv)) {
SET_NUMERIC_STANDARD();
- Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
+ Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
tsv = Nullsv;
goto tokensave;
}
if (SvIOKp(sv)) {
- (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
+ (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
tsv = Nullsv;
goto tokensave;
}
#endif
}
else if (SvIOKp(sv)) {
+ U32 oldIOK = SvIOK(sv);
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
olderrno = errno; /* some Xenix systems wipe out errno here */
- sv_setpvf(sv, "%vd", SvIVX(sv));
+ sv_setpviv(sv, SvIVX(sv));
errno = olderrno;
s = SvEND(sv);
+ if (oldIOK)
+ SvIOK_on(sv);
+ else
+ SvIOKp_on(sv);
}
else {
+ dTHR;
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
*lp = 0;
tokensaveref:
if (!tsv)
- tsv = newSVpv(tokenbuf, 0);
+ tsv = newSVpv(tmpbuf, 0);
sv_2mortal(tsv);
*lp = SvCUR(tsv);
return SvPVX(tsv);
len = SvCUR(tsv);
}
else {
- t = tokenbuf;
- len = strlen(tokenbuf);
+ t = tmpbuf;
+ len = strlen(tmpbuf);
}
#ifdef FIXNEGATIVEZERO
if (len == 2 && t[0] == '-' && t[1] == '0') {
if (SvROK(sv)) {
#ifdef OVERLOAD
{
+ dTHR;
SV* tmpsv;
if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
return SvTRUE(tmpsv);
return SvRV(sv) != 0;
}
if (SvPOKp(sv)) {
- register XPV* Xpv;
- if ((Xpv = (XPV*)SvANY(sv)) &&
- (*Xpv->xpv_pv > '0' ||
- Xpv->xpv_cur > 1 ||
- (Xpv->xpv_cur && *Xpv->xpv_pv != '0')))
+ register XPV* Xpvtmp;
+ if ((Xpvtmp = (XPV*)SvANY(sv)) &&
+ (*Xpvtmp->xpv_pv > '0' ||
+ Xpvtmp->xpv_cur > 1 ||
+ (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
return 1;
else
return 0;
SV *dstr;
register SV *sstr;
{
+ dTHR;
register U32 sflags;
register int dtype;
register int stype;
if (sstr == dstr)
return;
- if (SvTHINKFIRST(dstr)) {
- if (SvREADONLY(dstr) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(dstr))
- sv_unref(dstr);
- }
+ sv_check_thinkfirst(dstr);
if (!sstr)
sstr = &sv_undef;
stype = SvTYPE(sstr);
}
break;
case SVt_PV:
+ case SVt_PVFM:
if (dtype < SVt_PV)
sv_upgrade(dstr, SVt_PV);
break;
GvNAMELEN(dstr) = len;
SvFAKE_on(dstr); /* can coerce to non-glob */
}
+ /* ahem, death to those who redefine active sort subs */
+ else if (curstack == sortstack
+ && GvCV(dstr) && sortcop == CvSTART(GvCV(dstr)))
+ croak("Can't redefine active sort subroutine %s",
+ GvNAME(dstr));
(void)SvOK_off(dstr);
GvINTRO_off(dstr); /* one-shot flag */
gp_free((GV*)dstr);
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);
if (!GvCVGEN((GV*)dstr) &&
(CvROOT(cv) || CvXSUB(cv)))
{
+ /* ahem, death to those who redefine
+ * active sort subs */
+ if (curstack == sortstack &&
+ sortcop == CvSTART(cv))
+ croak(
+ "Can't redefine active sort subroutine %s",
+ GvENAME((GV*)dstr));
if (cv_const_sv(cv))
warn("Constant subroutine %s redefined",
GvENAME((GV*)dstr));
{
assert(len >= 0); /* STRLEN is probably unsigned, so this may
elicit a warning, but it won't hurt. */
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (!ptr) {
(void)SvOK_off(sv);
return;
{
register STRLEN len;
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (!ptr) {
(void)SvOK_off(sv);
return;
register char *ptr;
register STRLEN len;
{
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (!SvUPGRADE(sv, SVt_PV))
return;
if (!ptr) {
SvTAINT(sv);
}
+static void
+sv_check_thinkfirst(sv)
+register SV *sv;
+{
+ if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling)
+ croak(no_modify);
+ }
+ if (SvROK(sv))
+ sv_unref(sv);
+ }
+}
+
void
sv_chop(sv,ptr) /* like set but assuming ptr is in sv */
register SV *sv;
if (!ptr || !SvPOKp(sv))
return;
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv,SVt_PVIV);
{
MAGIC* mg;
- if (SvREADONLY(sv) && curcop != &compiling && !strchr("gBf", how))
- croak(no_modify);
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling && !strchr("gBf", how))
+ croak(no_modify);
+ }
if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
if (how == 't')
if (!obj || obj == sv || how == '#')
mg->mg_obj = obj;
else {
+ dTHR;
mg->mg_obj = SvREFCNT_inc(obj);
mg->mg_flags |= MGf_REFCOUNTED;
}
if (name)
if (namlen >= 0)
mg->mg_ptr = savepvn(name, namlen);
- else if (namlen == HEf_SVKEY)
+ else if (namlen == HEf_SVKEY) {
+ dTHR; /* just for SvREFCNT_inc */
mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
+ }
switch (how) {
case 0:
case 'l':
mg->mg_virtual = &vtbl_dbline;
break;
+#ifdef USE_THREADS
+ case 'm':
+ mg->mg_virtual = &vtbl_mutex;
+ break;
+#endif /* USE_THREADS */
#ifdef USE_LOCALE_COLLATE
case 'o':
mg->mg_virtual = &vtbl_collxfrm;
register SV *nsv;
{
U32 refcnt = SvREFCNT(sv);
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (SvREFCNT(nsv) != 1)
warn("Reference miscount in sv_replace()");
if (SvMAGICAL(sv)) {
assert(SvREFCNT(sv) == 0);
if (SvOBJECT(sv)) {
+ dTHR;
if (defstash) { /* Still have a symbol table? */
+ dTHR;
dSP;
GV* destructor;
--sv_objcount; /* XXX Might want something more general */
}
if (SvREFCNT(sv)) {
- SV *ret;
- if ( perldb
- && (ret = perl_get_sv("DB::ret", FALSE))
- && SvROK(ret) && SvRV(ret) == sv && SvREFCNT(sv) == 1) {
- /* Debugger is prone to dangling references. */
- SvRV(ret) = 0;
- SvROK_off(ret);
- SvREFCNT(sv) = 0;
- }
- else {
if (in_clean_objs)
croak("DESTROY created new reference to dead object");
/* DESTROY gave object new lease on life */
return;
- }
}
}
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
return;
#ifdef DEBUGGING
if (SvTEMP(sv)) {
- warn("Attempt to free temp prematurely");
+ warn("Attempt to free temp prematurely: %s", SvPEEK(sv));
return;
}
#endif
if (SvREADONLY(sv)) {
SAVEFREEPV(xf);
*nxp = xlen;
- return xf;
+ return xf + sizeof(collation_ix);
}
if (! mg) {
sv_magic(sv, 0, 'o', 0, 0);
register I32 cnt;
I32 i;
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
- if (SvROK(sv))
- sv_unref(sv);
- }
+ sv_check_thinkfirst(sv);
if (!SvUPGRADE(sv, SVt_PV))
return 0;
SvSCREAM_off(sv);
*bp = '\0';
SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: done, len=%d, string=|%.*s|\n",
- SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
+ "Screamer: done, len=%ld, string=|%.*s|\n",
+ (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
}
else
{
memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
{
append = -1;
- goto screamer2;
+ /*
+ * If we're reading from a TTY and we get a short read,
+ * indicating that the user hit his EOF character, we need
+ * to notice it now, because if we try to read from the TTY
+ * again, the EOF condition will disappear.
+ *
+ * The comparison of cnt to sizeof(buf) is an optimization
+ * that prevents unnecessary calls to feof().
+ *
+ * - jik 9/25/96
+ */
+ if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
+ goto screamer2;
}
}
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling)
+ croak(no_modify);
+ }
if (SvROK(sv)) {
#ifdef OVERLOAD
if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return;
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling)
+ croak(no_modify);
+ }
if (SvROK(sv)) {
#ifdef OVERLOAD
if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return;
static void
sv_mortalgrow()
{
+ dTHR;
tmps_max += (tmps_max < 512) ? 128 : 512;
Renew(tmps_stack, tmps_max, SV*);
}
sv_mortalcopy(oldstr)
SV *oldstr;
{
+ dTHR;
register SV *sv;
new_SV(sv);
SV *
sv_newmortal()
{
+ dTHR;
register SV *sv;
new_SV(sv);
sv_2mortal(sv)
register SV *sv;
{
+ dTHR;
if (!sv)
return sv;
if (SvREADONLY(sv) && curcop != &compiling)
#else
/*VARARGS0*/
SV *
-newSVpvf(sv, pat, va_alist)
+newSVpvf(pat, va_alist)
const char *pat;
va_dcl
#endif
#else
va_start(args);
#endif
- sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool));
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
va_end(args);
return sv;
}
newRV(ref)
SV *ref;
{
+ dTHR;
register SV *sv;
new_SV(sv);
{
char *s;
- if (SvREADONLY(sv) && curcop != &compiling)
- croak(no_modify);
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (curcop != &compiling)
+ croak(no_modify);
+ }
if (SvPOK(sv)) {
*lp = SvCUR(sv);
s = SvPVX(sv);
*lp = SvCUR(sv);
}
- else
+ else {
+ dTHR;
croak("Can't coerce %s to string in %s", sv_reftype(sv,0),
op_name[op->op_type]);
+ }
}
else
s = sv_2pv(sv, lp);
SV *rv;
char *classname;
{
+ dTHR;
SV *sv;
new_SV(sv);
SV* sv;
HV* stash;
{
+ dTHR;
SV *ref;
if (!SvROK(sv))
croak("Can't bless non-reference value");
return FALSE;
}
+void
+sv_setpviv(sv, iv)
+SV *sv;
+IV iv;
+{
+ STRLEN len;
+ char buf[TYPE_DIGITS(UV)];
+ char *ptr = buf + sizeof(buf);
+ int sign;
+ UV uv;
+ char *p;
+
+ sv_setpvn(sv, "", 0);
+ if (iv >= 0) {
+ uv = iv;
+ sign = 0;
+ } else {
+ uv = -iv;
+ sign = 1;
+ }
+ do {
+ *--ptr = '0' + (uv % 10);
+ } while (uv /= 10);
+ len = (buf + sizeof(buf)) - ptr;
+ /* taking advantage of SvCUR(sv) == 0 */
+ SvGROW(sv, sign + len + 1);
+ p = SvPVX(sv);
+ if (sign)
+ *p++ = '-';
+ memcpy(p, ptr, len);
+ p += len;
+ *p = '\0';
+ SvCUR(sv) = p - SvPVX(sv);
+}
+
#ifdef I_STDARG
void
sv_setpvf(SV *sv, const char* pat, ...)
#else
va_start(args);
#endif
- sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool));
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
va_end(args);
}
#else
va_start(args);
#endif
- sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool));
+ sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
va_end(args);
}
I32 svmax;
bool *used_locale;
{
+ dTHR;
char *p;
char *q;
char *patend;
+ STRLEN origlen;
I32 svix = 0;
+ static char nullstr[] = "(null)";
/* no matter what, this is a string now */
- (void)SvPV_force(sv, na);
+ (void)SvPV_force(sv, origlen);
- /* special-case "" and "%s" */
+ /* special-case "", "%s", and "%_" */
if (patlen == 0)
return;
- if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
- if (args)
- sv_catpv(sv, va_arg(*args, char *));
- else if (svix < svmax)
- sv_catsv(sv, *svargs);
- return;
+ if (patlen == 2 && pat[0] == '%') {
+ switch (pat[1]) {
+ case 's':
+ if (args) {
+ char *s = va_arg(*args, char*);
+ sv_catpv(sv, s ? s : nullstr);
+ }
+ else if (svix < svmax)
+ sv_catsv(sv, *svargs);
+ return;
+ case '_':
+ if (args) {
+ sv_catsv(sv, va_arg(*args, SV*));
+ return;
+ }
+ /* See comment on '_' below */
+ break;
+ }
}
patend = (char*)pat + patlen;
char plus = 0;
char intsize = 0;
STRLEN width = 0;
+ STRLEN zeros = 0;
bool has_precis = FALSE;
STRLEN precis = 0;
STRLEN esignlen = 0;
char *eptr = Nullch;
- STRLEN elen = 0;
- char ebuf[(sizeof(UV) * 3) * 2 + 16]; /* large enough for "%#.#f" */
+ STRLEN elen = 0;
+ char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
static char *efloatbuf = Nullch;
static STRLEN efloatsize = 0;
if (q++ >= patend)
break;
+ /* FLAGS */
+
while (*q) {
switch (*q) {
case ' ':
q++;
continue;
- case 'l':
-#if 0 /* when quads have better support within Perl */
- if (intsize == 'l') {
- intsize = 'q';
- q++;
- continue;
- }
-#endif
- /* FALL THROUGH */
- case 'h':
- case 'v':
- intsize = *q++;
- continue;
+ default:
+ break;
+ }
+ break;
+ }
- case '1': case '2': case '3':
- case '4': case '5': case '6':
- case '7': case '8': case '9':
- width = 0;
- while (isDIGIT(*q))
- width = width * 10 + (*q++ - '0');
- continue;
+ /* WIDTH */
+
+ switch (*q) {
+ case '1': case '2': case '3':
+ case '4': case '5': case '6':
+ case '7': case '8': case '9':
+ width = 0;
+ while (isDIGIT(*q))
+ width = width * 10 + (*q++ - '0');
+ break;
+
+ case '*':
+ if (args)
+ i = va_arg(*args, int);
+ else
+ i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+ left |= (i < 0);
+ width = (i < 0) ? -i : i;
+ q++;
+ break;
+ }
- case '*':
+ /* PRECISION */
+
+ if (*q == '.') {
+ q++;
+ if (*q == '*') {
if (args)
i = va_arg(*args, int);
else
i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
- left ^= (i < 0);
- width = (i < 0) ? -i : i;
+ precis = (i < 0) ? 0 : i;
q++;
- continue;
+ }
+ else {
+ precis = 0;
+ while (isDIGIT(*q))
+ precis = precis * 10 + (*q++ - '0');
+ }
+ has_precis = TRUE;
+ }
- case '.':
- q++;
- if (*q == '*') {
- if (args)
- precis = va_arg(*args, int);
- else
- precis = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
- q++;
- }
- else {
- precis = 0;
- while (isDIGIT(*q))
- precis = precis * 10 + (*q++ - '0');
- }
- has_precis = TRUE;
- continue;
+ /* SIZE */
- default:
+ switch (*q) {
+ case 'l':
+#if 0 /* when quads have better support within Perl */
+ if (*(q + 1) == 'l') {
+ intsize = 'q';
+ q += 2;
break;
}
-
+#endif
+ /* FALL THROUGH */
+ case 'h':
+ case 'V':
+ intsize = *q++;
break;
}
+ /* CONVERSION */
+
switch (c = *q++) {
/* STRINGS */
elen = 1;
goto string;
- case 'S':
- if (args) {
- eptr = SvPVx(va_arg(*args, SV *), elen);
- goto string;
- }
- /* FALL THROUGH */
-
case 's':
if (args) {
- eptr = va_arg(*args, char *);
- elen = strlen(eptr);
+ eptr = va_arg(*args, char*);
+ if (eptr)
+ elen = strlen(eptr);
+ else {
+ eptr = nullstr;
+ elen = sizeof nullstr - 1;
+ }
}
else if (svix < svmax)
eptr = SvPVx(svargs[svix++], elen);
goto string;
+ case '_':
+ /*
+ * The "%_" hack might have to be changed someday,
+ * if ISO or ANSI decide to use '_' for something.
+ * So we keep it hidden from users' code.
+ */
+ if (!args)
+ goto unknown;
+ eptr = SvPVx(va_arg(*args, SV*), elen);
+
string:
if (has_precis && elen > precis)
elen = precis;
/* INTEGERS */
+ case 'p':
+ if (args)
+ uv = (UV)va_arg(*args, void*);
+ else
+ uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
+ base = 16;
+ goto integer;
+
case 'D':
intsize = 'l';
/* FALL THROUGH */
case 'h': iv = (short)va_arg(*args, int); break;
default: iv = va_arg(*args, int); break;
case 'l': iv = va_arg(*args, long); break;
- case 'v': iv = va_arg(*args, IV); break;
+ case 'V': iv = va_arg(*args, IV); break;
}
}
else {
case 'h': iv = (short)iv; break;
default: iv = (int)iv; break;
case 'l': iv = (long)iv; break;
- case 'v': break;
+ case 'V': break;
}
}
if (iv >= 0) {
base = 10;
goto integer;
+ case 'U':
+ intsize = 'l';
+ /* FALL THROUGH */
+ case 'u':
+ base = 10;
+ goto uns_integer;
+
case 'O':
intsize = 'l';
/* FALL THROUGH */
goto uns_integer;
case 'X':
- intsize = 'l';
- /* FALL THROUGH */
case 'x':
base = 16;
- goto uns_integer;
-
- case 'u':
- base = 10;
uns_integer:
if (args) {
case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
default: uv = va_arg(*args, unsigned); break;
case 'l': uv = va_arg(*args, unsigned long); break;
- case 'v': uv = va_arg(*args, UV); break;
+ case 'V': uv = va_arg(*args, UV); break;
}
}
else {
case 'h': uv = (unsigned short)uv; break;
default: uv = (unsigned)uv; break;
case 'l': uv = (unsigned long)uv; break;
- case 'v': break;
+ case 'V': break;
}
}
integer:
- p = "0123456789abcdef";
eptr = ebuf + sizeof ebuf;
- do {
- unsigned dig = uv % base;
- *--eptr = p[dig];
- } while (uv /= base);
- if (alt) {
- switch (c) {
- case 'o':
- if (*eptr != 0)
- esignbuf[esignlen++] = '0';
- break;
- case 'x':
+ switch (base) {
+ unsigned dig;
+ case 16:
+ p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
+ do {
+ dig = uv & 15;
+ *--eptr = p[dig];
+ } while (uv >>= 4);
+ if (alt) {
esignbuf[esignlen++] = '0';
- esignbuf[esignlen++] = 'x';
- break;
+ esignbuf[esignlen++] = c; /* 'x' or 'X' */
}
+ break;
+ case 8:
+ do {
+ dig = uv & 7;
+ *--eptr = '0' + dig;
+ } while (uv >>= 3);
+ if (alt && *eptr != '0')
+ *--eptr = '0';
+ break;
+ default: /* it had better be ten or less */
+ do {
+ dig = uv % base;
+ *--eptr = '0' + dig;
+ } while (uv /= base);
+ break;
}
elen = (ebuf + sizeof ebuf) - eptr;
- if (has_precis) {
- left = FALSE;
- fill = '0';
- width = esignlen + precis;
- }
+ if (has_precis && precis > elen)
+ zeros = precis - elen;
break;
/* FLOATING POINT */
+ case 'F':
+ c = 'f'; /* maybe %F isn't supported here */
+ /* FALL THROUGH */
case 'e': case 'E':
- case 'f': case 'F':
+ case 'f':
case 'g': case 'G':
/* This is evil, but floating point is even more evil */
- need = width;
- if (has_precis && need < precis)
- need = precis;
+ if (args)
+ nv = va_arg(*args, double);
+ else
+ nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
+
+ need = 0;
+ if (c != 'e' && c != 'E') {
+ i = PERL_INT_MIN;
+ (void)frexp(nv, &i);
+ if (i == PERL_INT_MIN)
+ die("panic: frexp");
+ if (i > 0)
+ need = BIT_DIGITS(i);
+ }
+ need += has_precis ? precis : 6; /* known default */
+ if (need < width)
+ need = width;
+
need += 20; /* fudge factor */
if (efloatsize < need) {
Safefree(efloatbuf);
}
if (fill == '0')
*--eptr = fill;
+ if (left)
+ *--eptr = '-';
if (plus)
*--eptr = plus;
if (alt)
*--eptr = '#';
*--eptr = '%';
- if (args)
- nv = va_arg(*args, double);
- else
- nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
(void)sprintf(efloatbuf, eptr, nv);
eptr = efloatbuf;
break;
+ /* SPECIAL */
+
+ case 'n':
+ i = SvCUR(sv) - origlen;
+ if (args) {
+ switch (intsize) {
+ case 'h': *(va_arg(*args, short*)) = i; break;
+ default: *(va_arg(*args, int*)) = i; break;
+ case 'l': *(va_arg(*args, long*)) = i; break;
+ case 'V': *(va_arg(*args, IV*)) = i; break;
+ }
+ }
+ else if (svix < svmax)
+ sv_setuv(svargs[svix++], (UV)i);
+ continue; /* not "break" */
+
+ /* UNKNOWN */
+
default:
- /* output mangled stuff without comment */
+ unknown:
+ if (!args && dowarn &&
+ (op->op_type == OP_PRTF || op->op_type == OP_SPRINTF)) {
+ SV *msg = sv_newmortal();
+ sv_setpvf(msg, "Invalid conversion in %s: ",
+ (op->op_type == OP_PRTF) ? "printf" : "sprintf");
+ if (c)
+ sv_catpvf(msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
+ c & 0xFF);
+ else
+ sv_catpv(msg, "end of string");
+ warn("%_", msg); /* yes, this is reentrant */
+ }
+
+ /* output mangled stuff ... */
+ if (c == '\0')
+ --q;
eptr = p;
elen = q - p;
- break;
+
+ /* ... right here, because formatting flags should not apply */
+ SvGROW(sv, SvCUR(sv) + elen + 1);
+ p = SvEND(sv);
+ memcpy(p, eptr, elen);
+ p += elen;
+ *p = '\0';
+ SvCUR(sv) = p - SvPVX(sv);
+ continue; /* not "break" */
}
- have = esignlen + elen;
+ have = esignlen + zeros + elen;
need = (have > width ? have : width);
gap = need - have;
- SvGROW(sv, SvLEN(sv) + need);
+ SvGROW(sv, SvCUR(sv) + need + 1);
p = SvEND(sv);
if (esignlen && fill == '0') {
for (i = 0; i < esignlen; i++)
for (i = 0; i < esignlen; i++)
*p++ = esignbuf[i];
}
+ if (zeros) {
+ for (i = zeros; i; i--)
+ *p++ = '0';
+ }
if (elen) {
memcpy(p, eptr, elen);
p += elen;
PerlIO_printf(Perl_debug_log, " DEPTH = %ld\n", (long)CvDEPTH(sv));
PerlIO_printf(Perl_debug_log, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv));
PerlIO_printf(Perl_debug_log, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv));
+#ifdef USE_THREADS
+ PerlIO_printf(Perl_debug_log, " MUTEXP = 0x%lx\n", (long)CvMUTEXP(sv));
+ PerlIO_printf(Perl_debug_log, " OWNER = 0x%lx\n", (long)CvOWNER(sv));
+#endif /* USE_THREADS */
+ PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n",
+ (unsigned long)CvFLAGS(sv));
if (type == SVt_PVFM)
PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv));
break;
projects / p5sagit/p5-mst-13.2.git / blobdiff