*/
#include "EXTERN.h"
+#define PERL_IN_PP_C
#include "perl.h"
/*
# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
#endif
-#ifndef PERL_OBJECT
-static void doencodes _((SV* sv, char* s, I32 len));
-static SV* refto _((SV* sv));
-static U32 seed _((void));
-#endif
-
/* variations on pp_null */
#ifdef I_UNISTD
RETURN;
gimme = GIMME_V;
if (gimme == G_ARRAY) {
- RETURNOP(do_kv(ARGS));
+ RETURNOP(do_kv());
}
else if (gimme == G_SCALAR) {
SV* sv = sv_newmortal();
if (HvFILL((HV*)TARG))
- sv_setpvf(sv, "%ld/%ld",
+ Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
(long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
else
sv_setiv(sv, 0);
PP(pp_padany)
{
- DIE("NOT IMPL LINE %d",__LINE__);
+ DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
}
/* Translations. */
sv = (SV*) gv;
}
else if (SvTYPE(sv) != SVt_PVGV)
- DIE("Not a GLOB reference");
+ DIE(aTHX_ "Not a GLOB reference");
}
else {
if (SvTYPE(sv) != SVt_PVGV) {
}
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(PL_no_usym, "a symbol");
+ DIE(aTHX_ PL_no_usym, "a symbol");
if (ckWARN(WARN_UNINITIALIZED))
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, n_a);
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(PL_no_symref, sym, "a symbol");
+ DIE(aTHX_ PL_no_symref, sym, "a symbol");
sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
}
}
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
- DIE("Not a SCALAR reference");
+ DIE(aTHX_ "Not a SCALAR reference");
}
}
else {
if (!SvOK(sv)) {
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(PL_no_usym, "a SCALAR");
+ DIE(aTHX_ PL_no_usym, "a SCALAR");
if (ckWARN(WARN_UNINITIALIZED))
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, n_a);
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(PL_no_symref, sym, "a SCALAR");
+ DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
}
}
goto set;
else { /* None such */
nonesuch:
- croak("Cannot find an opnumber for \"%s\"", s+6);
+ Perl_croak(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
}
}
}
}
STATIC SV*
-refto(SV *sv)
+S_refto(pTHX_ SV *sv)
{
SV* rv;
STRLEN len;
char *ptr = SvPV(ssv,len);
if (ckWARN(WARN_UNSAFE) && len == 0)
- warner(WARN_UNSAFE,
+ Perl_warner(aTHX_ WARN_UNSAFE,
"Explicit blessing to '' (assuming package main)");
stash = gv_stashpvn(ptr, len, TRUE);
}
snext = PL_screamnext;
if (!sfirst || !snext)
- DIE("do_study: out of memory");
+ DIE(aTHX_ "do_study: out of memory");
for (ch = 256; ch; --ch)
*sfirst++ = -1;
break;
case SVt_PVCV:
if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
- warner(WARN_UNSAFE, "Constant subroutine %s undefined",
+ Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined",
CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
/* FALL THROUGH */
case SVt_PVFM:
{
djSP;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- croak(PL_no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MIN)
{
{
djSP; dTARGET;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- croak(PL_no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MAX)
{
djSP; dTARGET;
if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- croak(PL_no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MIN)
dPOPPOPnnrl;
double value;
if (right == 0.0)
- DIE("Illegal division by zero");
+ DIE(aTHX_ "Illegal division by zero");
#ifdef SLOPPYDIVIDE
/* insure that 20./5. == 4. */
{
dleft = floor(dleft + 0.5);
if (!dright)
- DIE("Illegal modulus zero");
+ DIE(aTHX_ "Illegal modulus zero");
dans = fmod(dleft, dright);
if ((left_neg != right_neg) && dans)
do_uv:
if (!right)
- DIE("Illegal modulus zero");
+ DIE(aTHX_ "Illegal modulus zero");
ans = left % right;
if ((left_neg != right_neg) && ans)
{
dPOPiv;
if (value == 0)
- DIE("Illegal division by zero");
+ DIE(aTHX_ "Illegal division by zero");
value = POPi / value;
PUSHi( value );
RETURN;
{
dPOPTOPiirl;
if (!right)
- DIE("Illegal modulus zero");
+ DIE(aTHX_ "Illegal modulus zero");
SETi( left % right );
RETURN;
}
*/
#ifndef HAS_DRAND48_PROTO
-extern double drand48 _((void));
+extern double drand48 (void);
#endif
PP(pp_rand)
}
STATIC U32
-seed(void)
+S_seed(pTHX)
{
/*
* This is really just a quick hack which grabs various garbage
double value;
value = POPn;
if (value <= 0.0) {
- SET_NUMERIC_STANDARD();
- DIE("Can't take log of %g", value);
+ RESTORE_NUMERIC_STANDARD();
+ DIE(aTHX_ "Can't take log of %g", value);
}
value = log(value);
XPUSHn(value);
double value;
value = POPn;
if (value < 0.0) {
- SET_NUMERIC_STANDARD();
- DIE("Can't take sqrt of %g", value);
+ RESTORE_NUMERIC_STANDARD();
+ DIE(aTHX_ "Can't take sqrt of %g", value);
}
value = sqrt(value);
XPUSHn(value);
}
if (fail < 0) {
if (ckWARN(WARN_SUBSTR) || lvalue || repl)
- warner(WARN_SUBSTR, "substr outside of string");
+ Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
RETPUSHUNDEF;
}
else {
STRLEN n_a;
SvPV_force(sv,n_a);
if (ckWARN(WARN_SUBSTR))
- warner(WARN_SUBSTR,
+ Perl_warner(aTHX_ WARN_SUBSTR,
"Attempt to use reference as lvalue in substr");
}
if (SvOK(sv)) /* is it defined ? */
PP(pp_sprintf)
{
djSP; dMARK; dORIGMARK; dTARGET;
-#ifdef USE_LOCALE_NUMERIC
- if (PL_op->op_private & OPpLOCALE)
- SET_NUMERIC_LOCAL();
- else
- SET_NUMERIC_STANDARD();
-#endif
do_sprintf(TARG, SP-MARK, MARK+1);
TAINT_IF(SvTAINTED(TARG));
SP = ORIGMARK;
sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
#endif
#else
- DIE(
+ DIE(aTHX_
"The crypt() function is unimplemented due to excessive paranoia.");
#endif
SETs(TARG);
s = (U8*)SvPV_force(sv, slen);
Copy(tmpbuf, s, ulen, U8);
}
- RETURN;
- }
-
- if (!SvPADTMP(sv)) {
- dTARGET;
- sv_setsv(TARG, sv);
- sv = TARG;
- SETs(sv);
- }
- s = (U8*)SvPV_force(sv, slen);
- if (*s) {
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(sv);
- *s = toUPPER_LC(*s);
+ } else {
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = (U8*)SvPV_force(sv, slen);
+ if (*s) {
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ *s = toUPPER_LC(*s);
+ }
+ else
+ *s = toUPPER(*s);
}
- else
- *s = toUPPER(*s);
}
-
+ if (SvSMAGICAL(sv))
+ mg_set(sv);
RETURN;
}
s = (U8*)SvPV_force(sv, slen);
Copy(tmpbuf, s, ulen, U8);
}
- RETURN;
- }
-
- if (!SvPADTMP(sv)) {
- dTARGET;
- sv_setsv(TARG, sv);
- sv = TARG;
- SETs(sv);
- }
- s = (U8*)SvPV_force(sv, slen);
- if (*s) {
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(sv);
- *s = toLOWER_LC(*s);
+ } else {
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
}
- else
- *s = toLOWER(*s);
+ s = (U8*)SvPV_force(sv, slen);
+ if (*s) {
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ *s = toLOWER_LC(*s);
+ }
+ else
+ *s = toLOWER(*s);
+ }
+ SETs(sv);
}
-
- SETs(sv);
+ if (SvSMAGICAL(sv))
+ mg_set(sv);
RETURN;
}
if (!len) {
sv_setpvn(TARG, "", 0);
SETs(TARG);
- RETURN;
- }
-
- (void)SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, (len * 2) + 1);
- (void)SvPOK_only(TARG);
- d = (U8*)SvPVX(TARG);
- send = s + len;
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(TARG);
- while (s < send) {
- d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
- s += ulen;
+ } else {
+ (void)SvUPGRADE(TARG, SVt_PV);
+ SvGROW(TARG, (len * 2) + 1);
+ (void)SvPOK_only(TARG);
+ d = (U8*)SvPVX(TARG);
+ send = s + len;
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(TARG);
+ while (s < send) {
+ d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
+ s += ulen;
+ }
}
- }
- else {
- while (s < send) {
- d = uv_to_utf8(d, toUPPER_utf8( s ));
- s += UTF8SKIP(s);
+ else {
+ while (s < send) {
+ d = uv_to_utf8(d, toUPPER_utf8( s ));
+ s += UTF8SKIP(s);
+ }
}
+ *d = '\0';
+ SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
+ SETs(TARG);
}
- *d = '\0';
- SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
- SETs(TARG);
- RETURN;
- }
-
- if (!SvPADTMP(sv)) {
- dTARGET;
- sv_setsv(TARG, sv);
- sv = TARG;
- SETs(sv);
- }
-
- s = (U8*)SvPV_force(sv, len);
- if (len) {
- register U8 *send = s + len;
-
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(sv);
- for (; s < send; s++)
- *s = toUPPER_LC(*s);
+ } else {
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
}
- else {
- for (; s < send; s++)
- *s = toUPPER(*s);
+ s = (U8*)SvPV_force(sv, len);
+ if (len) {
+ register U8 *send = s + len;
+
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ for (; s < send; s++)
+ *s = toUPPER_LC(*s);
+ }
+ else {
+ for (; s < send; s++)
+ *s = toUPPER(*s);
+ }
}
}
+ if (SvSMAGICAL(sv))
+ mg_set(sv);
RETURN;
}
if (!len) {
sv_setpvn(TARG, "", 0);
SETs(TARG);
- RETURN;
- }
-
- (void)SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, (len * 2) + 1);
- (void)SvPOK_only(TARG);
- d = (U8*)SvPVX(TARG);
- send = s + len;
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(TARG);
- while (s < send) {
- d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
- s += ulen;
+ } else {
+ (void)SvUPGRADE(TARG, SVt_PV);
+ SvGROW(TARG, (len * 2) + 1);
+ (void)SvPOK_only(TARG);
+ d = (U8*)SvPVX(TARG);
+ send = s + len;
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(TARG);
+ while (s < send) {
+ d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
+ s += ulen;
+ }
}
- }
- else {
- while (s < send) {
- d = uv_to_utf8(d, toLOWER_utf8(s));
- s += UTF8SKIP(s);
+ else {
+ while (s < send) {
+ d = uv_to_utf8(d, toLOWER_utf8(s));
+ s += UTF8SKIP(s);
+ }
}
+ *d = '\0';
+ SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
+ SETs(TARG);
+ }
+ } else {
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
}
- *d = '\0';
- SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
- SETs(TARG);
- RETURN;
- }
- if (!SvPADTMP(sv)) {
- dTARGET;
- sv_setsv(TARG, sv);
- sv = TARG;
- SETs(sv);
- }
+ s = (U8*)SvPV_force(sv, len);
+ if (len) {
+ register U8 *send = s + len;
- s = (U8*)SvPV_force(sv, len);
- if (len) {
- register U8 *send = s + len;
-
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(sv);
- for (; s < send; s++)
- *s = toLOWER_LC(*s);
- }
- else {
- for (; s < send; s++)
- *s = toLOWER(*s);
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ for (; s < send; s++)
+ *s = toLOWER_LC(*s);
+ }
+ else {
+ for (; s < send; s++)
+ *s = toLOWER(*s);
+ }
}
}
+ if (SvSMAGICAL(sv))
+ mg_set(sv);
RETURN;
}
else
sv_setpvn(TARG, s, len);
SETs(TARG);
+ if (SvSMAGICAL(TARG))
+ mg_set(TARG);
RETURN;
}
svp = av_fetch(av, elem, lval);
if (lval) {
if (!svp || *svp == &PL_sv_undef)
- DIE(PL_no_aelem, elem);
+ DIE(aTHX_ PL_no_aelem, elem);
if (PL_op->op_private & OPpLVAL_INTRO)
save_aelem(av, elem, svp);
}
PP(pp_values)
{
- return do_kv(ARGS);
+ return do_kv();
}
PP(pp_keys)
{
- return do_kv(ARGS);
+ return do_kv();
}
PP(pp_delete)
if (hvtype == SVt_PVHV)
sv = hv_delete_ent(hv, *MARK, discard, 0);
else
- DIE("Not a HASH reference");
+ DIE(aTHX_ "Not a HASH reference");
*MARK = sv ? sv : &PL_sv_undef;
}
if (discard)
if (SvTYPE(hv) == SVt_PVHV)
sv = hv_delete_ent(hv, keysv, discard, 0);
else
- DIE("Not a HASH reference");
+ DIE(aTHX_ "Not a HASH reference");
if (!sv)
sv = &PL_sv_undef;
if (!discard)
RETPUSHYES;
}
else {
- DIE("Not a HASH reference");
+ DIE(aTHX_ "Not a HASH reference");
}
RETPUSHNO;
}
I32 realhv = (SvTYPE(hv) == SVt_PVHV);
if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
- DIE("Can't localize pseudo-hash element");
+ DIE(aTHX_ "Can't localize pseudo-hash element");
if (realhv || SvTYPE(hv) == SVt_PVAV) {
while (++MARK <= SP) {
if (lval) {
if (!svp || *svp == &PL_sv_undef) {
STRLEN n_a;
- DIE(PL_no_helem, SvPV(keysv, n_a));
+ DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
}
if (PL_op->op_private & OPpLVAL_INTRO)
save_helem(hv, keysv, svp);
if (MARK < SP)
sv_setsv(val, *++MARK);
else if (ckWARN(WARN_UNSAFE))
- warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
+ Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
PUSHMARK(MARK);
PUTBACK;
ENTER;
- perl_call_method("SPLICE",GIMME_V);
+ call_method("SPLICE",GIMME_V);
LEAVE;
SPAGAIN;
RETURN;
else
offset -= PL_curcop->cop_arybase;
if (offset < 0)
- DIE(PL_no_aelem, i);
+ DIE(aTHX_ PL_no_aelem, i);
if (++MARK < SP) {
length = SvIVx(*MARK++);
if (length < 0) {
PUSHMARK(MARK);
PUTBACK;
ENTER;
- perl_call_method("PUSH",G_SCALAR|G_DISCARD);
+ call_method("PUSH",G_SCALAR|G_DISCARD);
LEAVE;
SPAGAIN;
}
PUSHMARK(MARK);
PUTBACK;
ENTER;
- perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
+ call_method("UNSHIFT",G_SCALAR|G_DISCARD);
LEAVE;
SPAGAIN;
}
s += UTF8SKIP(s);
down = (char*)(s - 1);
if (s > send || !((*down & 0xc0) == 0x80)) {
- warn("Malformed UTF-8 character");
+ Perl_warn(aTHX_ "Malformed UTF-8 character");
break;
}
while (down > up) {
RETURN;
}
-STATIC SV *
-mul128(SV *sv, U8 m)
+STATIC SV *
+S_mul128(pTHX_ SV *sv, U8 m)
{
STRLEN len;
char *s = SvPV(sv, len);
pat++;
}
else
- croak("'!' allowed only after types %s", natstr);
+ Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
}
if (pat >= patend)
len = 1;
len = (datumtype != '@');
switch(datumtype) {
default:
- croak("Invalid type in unpack: '%c'", (int)datumtype);
+ Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
if (commas++ == 0 && ckWARN(WARN_UNSAFE))
- warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
+ Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
break;
case '%':
if (len == 1 && pat[-1] != '1')
break;
case '@':
if (len > strend - strbeg)
- DIE("@ outside of string");
+ DIE(aTHX_ "@ outside of string");
s = strbeg + len;
break;
case 'X':
if (len > s - strbeg)
- DIE("X outside of string");
+ DIE(aTHX_ "X outside of string");
s -= len;
break;
case 'x':
if (len > strend - s)
- DIE("x outside of string");
+ DIE(aTHX_ "x outside of string");
s += len;
break;
case 'A':
char *t;
STRLEN n_a;
- sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
+ sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
while (s < strend) {
sv = mul128(sv, *s & 0x7f);
if (!(*s++ & 0x80)) {
}
}
if ((s >= strend) && bytes)
- croak("Unterminated compressed integer");
+ Perl_croak(aTHX_ "Unterminated compressed integer");
}
break;
case 'P':
}
STATIC void
-doencodes(register SV *sv, register char *s, register I32 len)
+S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
{
char hunk[5];
}
STATIC SV *
-is_an_int(char *s, STRLEN l)
+S_is_an_int(pTHX_ char *s, STRLEN l)
{
STRLEN n_a;
SV *result = newSVpvn(s, l);
return (result);
}
+/* pnum must be '\0' terminated */
STATIC int
-div128(SV *pnum, bool *done)
- /* must be '\0' terminated */
-
+S_div128(pTHX_ SV *pnum, bool *done)
{
STRLEN len;
char *s = SvPV(pnum, len);
pat++;
}
else
- croak("'!' allowed only after types %s", natstr);
+ Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
}
if (*pat == '*') {
len = strchr("@Xxu", datumtype) ? 0 : items;
len = 1;
switch(datumtype) {
default:
- croak("Invalid type in pack: '%c'", (int)datumtype);
+ Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
if (commas++ == 0 && ckWARN(WARN_UNSAFE))
- warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
+ Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
break;
case '%':
- DIE("%% may only be used in unpack");
+ DIE(aTHX_ "%% may only be used in unpack");
case '@':
len -= SvCUR(cat);
if (len > 0)
case 'X':
shrink:
if (SvCUR(cat) < len)
- DIE("X outside of string");
+ DIE(aTHX_ "X outside of string");
SvCUR(cat) -= len;
*SvEND(cat) = '\0';
break;
adouble = floor(SvNV(fromstr));
if (adouble < 0)
- croak("Cannot compress negative numbers");
+ Perl_croak(aTHX_ "Cannot compress negative numbers");
if (
#ifdef BW_BITS
{
char buf[1 + sizeof(UV)];
char *in = buf + sizeof(buf);
- UV auv = U_V(adouble);;
+ UV auv = U_V(adouble);
do {
*--in = (auv & 0x7f) | 0x80;
/* Copy string and check for compliance */
from = SvPV(fromstr, len);
if ((norm = is_an_int(from, len)) == NULL)
- croak("can compress only unsigned integer");
+ Perl_croak(aTHX_ "can compress only unsigned integer");
New('w', result, len, char);
in = result + len;
double next = floor(adouble / 128);
*--in = (unsigned char)(adouble - (next * 128)) | 0x80;
if (--in < buf) /* this cannot happen ;-) */
- croak ("Cannot compress integer");
+ Perl_croak(aTHX_ "Cannot compress integer");
adouble = next;
} while (adouble > 0);
buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
}
else
- croak("Cannot compress non integer");
+ Perl_croak(aTHX_ "Cannot compress non integer");
}
break;
case 'i':
* gone.
*/
if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
- warner(WARN_UNSAFE,
+ Perl_warner(aTHX_ WARN_UNSAFE,
"Attempt to pack pointer to temporary value");
if (SvPOK(fromstr) || SvNIOK(fromstr))
aptr = SvPV(fromstr,n_a);
pm = (PMOP*)POPs;
#endif
if (!pm || !s)
- DIE("panic: do_split");
+ DIE(aTHX_ "panic: do_split");
rx = pm->op_pmregexp;
TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
else if (rx->check_substr && !rx->nparens
&& (rx->reganch & ROPT_CHECK_ALL)
&& !(rx->reganch & ROPT_ANCH)) {
+ int tail = SvTAIL(rx->check_substr) != 0;
+
i = SvCUR(rx->check_substr);
- if (i == 1 && !SvTAIL(rx->check_substr)) {
+ if (i == 1 && !tail) {
i = *SvPVX(rx->check_substr);
while (--limit) {
/*SUPPRESS 530*/
#ifndef lint
while (s < strend && --limit &&
(m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
- rx->check_substr, 0)) )
+ rx->check_substr, PL_multiline ? FBMrf_MULTILINE : 0)) )
#endif
{
dstr = NEWSV(31, m-s);
if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
- s = m + i;
+ s = m + i - tail; /* Fake \n at the end */
}
}
}
else {
maxiters += (strend - s) * rx->nparens;
while (s < strend && --limit &&
- CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
+ CALLREGEXEC(aTHX_ rx, s, strend, orig, 1, sv, NULL, 0))
{
TAINT_IF(RX_MATCH_TAINTED(rx));
- if (rx->subbase
- && rx->subbase != orig) {
+ if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
m = s;
s = orig;
- orig = rx->subbase;
+ orig = rx->subbeg;
s = orig + (m - s);
strend = s + (strend - m);
}
- m = rx->startp[0];
+ m = rx->startp[0] + orig;
dstr = NEWSV(32, m-s);
sv_setpvn(dstr, s, m-s);
if (make_mortal)
XPUSHs(dstr);
if (rx->nparens) {
for (i = 1; i <= rx->nparens; i++) {
- s = rx->startp[i];
- m = rx->endp[i];
+ s = rx->startp[i] + orig;
+ m = rx->endp[i] + orig;
if (m && s) {
dstr = NEWSV(33, m-s);
sv_setpvn(dstr, s, m-s);
XPUSHs(dstr);
}
}
- s = rx->endp[0];
+ s = rx->endp[0] + orig;
}
}
LEAVE_SCOPE(oldsave);
iters = (SP - PL_stack_base) - base;
if (iters > maxiters)
- DIE("Split loop");
+ DIE(aTHX_ "Split loop");
/* keep field after final delim? */
if (s < strend || (iters && origlimit)) {
else {
PUTBACK;
ENTER;
- perl_call_method("PUSH",G_SCALAR|G_DISCARD);
+ call_method("PUSH",G_SCALAR|G_DISCARD);
LEAVE;
SPAGAIN;
if (gimme == G_ARRAY) {
#ifdef USE_THREADS
void
-unlock_condpair(void *svv)
+Perl_unlock_condpair(pTHX_ void *svv)
{
dTHR;
MAGIC *mg = mg_find((SV*)svv, 'm');
if (!mg)
- croak("panic: unlock_condpair unlocking non-mutex");
+ Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
MUTEX_LOCK(MgMUTEXP(mg));
if (MgOWNER(mg) != thr)
- croak("panic: unlock_condpair unlocking mutex that we don't own");
+ Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
MgOWNER(mg) = 0;
COND_SIGNAL(MgOWNERCONDP(mg));
DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
(unsigned long)thr, (unsigned long)sv);)
MUTEX_UNLOCK(MgMUTEXP(mg));
- save_destructor(unlock_condpair, sv);
+ save_destructor(Perl_unlock_condpair, sv);
}
#endif /* USE_THREADS */
if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
PUSHs(THREADSV(PL_op->op_targ));
RETURN;
#else
- DIE("tried to access per-thread data in non-threaded perl");
+ DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
#endif /* USE_THREADS */
}
projects / p5sagit/p5-mst-13.2.git / blobdiff