*/
#include "EXTERN.h"
+#define PERL_IN_PP_HOT_C
#include "perl.h"
#ifdef I_UNISTD
/* Hot code. */
#ifdef USE_THREADS
-static void
-unset_cvowner(void *cvarg)
+STATIC void
+S_unset_cvowner(pTHX_ void *cvarg)
{
register CV* cv = (CV *) cvarg;
#ifdef DEBUGGING
dSP;
XPUSHs((SV*)PL_last_in_gv);
PUTBACK;
- pp_rv2gv(ARGS);
+ pp_rv2gv();
PL_last_in_gv = (GV*)(*PL_stack_sp--);
}
}
{
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_MAX)
{
*MARK = SvTIED_obj((SV*)gv, mg);
PUTBACK;
ENTER;
- perl_call_method("PRINT", G_SCALAR);
+ call_method("PRINT", G_SCALAR);
LEAVE;
SPAGAIN;
MARK = ORIGMARK + 1;
if (ckWARN(WARN_UNOPENED)) {
SV* sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
- warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
+ Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
}
SETERRNO(EBADF,RMS$_IFI);
SV* sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
- warner(WARN_IO, "Filehandle %s opened only for input",
+ Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for input",
SvPV(sv,n_a));
else if (ckWARN(WARN_CLOSED))
- warner(WARN_CLOSED, "print on closed filehandle %s",
+ Perl_warner(aTHX_ WARN_CLOSED, "print on closed filehandle %s",
SvPV(sv,n_a));
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
av = (AV*)SvRV(sv);
if (SvTYPE(av) != SVt_PVAV)
- DIE("Not an ARRAY reference");
+ DIE(aTHX_ "Not an ARRAY reference");
if (PL_op->op_flags & OPf_REF) {
SETs((SV*)av);
RETURN;
if (!SvOK(sv)) {
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(PL_no_usym, "an ARRAY");
+ DIE(aTHX_ PL_no_usym, "an ARRAY");
if (ckWARN(WARN_UNINITIALIZED))
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
if (GIMME == G_ARRAY) {
(void)POPs;
RETURN;
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(PL_no_symref, sym, "an ARRAY");
+ DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
}
}
hv = (HV*)SvRV(sv);
if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
- DIE("Not a HASH reference");
+ DIE(aTHX_ "Not a HASH reference");
if (PL_op->op_flags & OPf_REF) {
SETs((SV*)hv);
RETURN;
if (!SvOK(sv)) {
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(PL_no_usym, "a HASH");
+ DIE(aTHX_ PL_no_usym, "a HASH");
if (ckWARN(WARN_UNINITIALIZED))
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
if (GIMME == G_ARRAY) {
SP--;
RETURN;
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(PL_no_symref, sym, "a HASH");
+ DIE(aTHX_ PL_no_symref, sym, "a HASH");
gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
}
}
if (GIMME == G_ARRAY) { /* array wanted */
*PL_stack_sp = (SV*)hv;
- return do_kv(ARGS);
+ return do_kv();
}
else {
dTARGET;
if (SvTYPE(hv) == SVt_PVAV)
hv = avhv_keys((AV*)hv);
if (HvFILL(hv))
- sv_setpvf(TARG, "%ld/%ld",
+ Perl_sv_setpvf(aTHX_ TARG, "%ld/%ld",
(long)HvFILL(hv), (long)HvMAX(hv) + 1);
else
sv_setiv(TARG, 0);
SvROK(*relem) &&
( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
- warner(WARN_UNSAFE, "Reference found where even-sized list expected");
+ Perl_warner(aTHX_ WARN_UNSAFE, "Reference found where even-sized list expected");
else
- warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
+ Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
}
tmpstr = NEWSV(29,0);
didstore = hv_store_ent(hash,*relem,tmpstr,0);
# endif /* HAS_SETEUID */
if (PL_delaymagic & DM_UID) {
if (PL_uid != PL_euid)
- DIE("No setreuid available");
+ DIE(aTHX_ "No setreuid available");
(void)PerlProc_setuid(PL_uid);
}
# endif /* HAS_SETREUID */
# endif /* HAS_SETEGID */
if (PL_delaymagic & DM_GID) {
if (PL_gid != PL_egid)
- DIE("No setregid available");
+ DIE(aTHX_ "No setregid available");
(void)PerlProc_setgid(PL_gid);
}
# endif /* HAS_SETREGID */
s = SvPV(TARG, len);
strend = s + len;
if (!s)
- DIE("panic: do_match");
+ DIE(aTHX_ "panic: do_match");
rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
(PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
TAINT_NOT;
rx->float_substr = Nullsv;
}
}
- if (CALLREGEXEC(rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
+ if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
{
PL_curpm = pm;
if (pm->op_pmflags & PMf_ONCE)
}
OP *
-do_readline(void)
+Perl_do_readline(pTHX)
{
dSP; dTARGETSTACKED;
register SV *sv;
XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
PUTBACK;
ENTER;
- perl_call_method("READLINE", gimme);
+ call_method("READLINE", gimme);
LEAVE;
SPAGAIN;
if (gimme == G_SCALAR)
if (!fp) {
if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) {
if (type == OP_GLOB)
- warner(WARN_CLOSED, "glob failed (can't start child: %s)",
+ Perl_warner(aTHX_ WARN_CLOSED, "glob failed (can't start child: %s)",
Strerror(errno));
else
- warner(WARN_CLOSED, "Read on closed filehandle <%s>",
+ Perl_warner(aTHX_ WARN_CLOSED, "Read on closed filehandle <%s>",
GvENAME(PL_last_in_gv));
}
if (gimme == G_SCALAR) {
}
else if (type == OP_GLOB) {
if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) {
- warner(WARN_CLOSED,
+ Perl_warner(aTHX_ WARN_CLOSED,
"glob failed (child exited with status %d%s)",
STATUS_CURRENT >> 8,
(STATUS_CURRENT & 0x80) ? ", core dumped" : "");
}
else if (SvTYPE(hv) == SVt_PVAV) {
if (PL_op->op_private & OPpLVAL_INTRO)
- DIE("Can't localize pseudo-hash element");
+ DIE(aTHX_ "Can't localize pseudo-hash element");
svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0);
}
else {
SV* key2;
if (!defer) {
STRLEN n_a;
- DIE(PL_no_helem, SvPV(keysv, n_a));
+ DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
}
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
EXTEND(SP, 1);
cx = &cxstack[cxstack_ix];
if (CxTYPE(cx) != CXt_LOOP)
- DIE("panic: pp_iter");
+ DIE(aTHX_ "panic: pp_iter");
av = cx->blk_loop.iterary;
if (SvTYPE(av) != SVt_PVAV) {
if (SvREADONLY(TARG)
|| (SvTYPE(TARG) > SVt_PVLV
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
- croak(PL_no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
PUTBACK;
s = SvPV(TARG, len);
force_it:
if (!pm || !s)
- DIE("panic: do_subst");
+ DIE(aTHX_ "panic: do_subst");
strend = s + len;
maxiters = 2*(strend - s) + 10; /* We can match twice at each
/* can do inplace substitution? */
if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
- if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
+ if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
SPAGAIN;
PUSHs(&PL_sv_no);
LEAVE_SCOPE(oldsave);
else {
do {
if (iters++ > maxiters)
- DIE("Substitution loop");
+ DIE(aTHX_ "Substitution loop");
rxtainted |= RX_MATCH_TAINTED(rx);
m = rx->startp[0] + orig;
/*SUPPRESS 560*/
d += clen;
}
s = rx->endp[0] + orig;
- } while (CALLREGEXEC(rx, s, strend, orig, s == m,
+ } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
Nullsv, NULL, REXEC_NOT_FIRST)); /* don't match same null twice */
if (s != d) {
i = strend - s;
RETURN;
}
- if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
+ if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags)) {
if (force_on_match) {
force_on_match = 0;
s = SvPV_force(TARG, len);
r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
do {
if (iters++ > maxiters)
- DIE("Substitution loop");
+ DIE(aTHX_ "Substitution loop");
rxtainted |= RX_MATCH_TAINTED(rx);
if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
m = s;
sv_catpvn(dstr, c, clen);
if (once)
break;
- } while (CALLREGEXEC(rx, s, strend, orig, s == m, TARG, NULL, r_flags));
+ } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags));
sv_catpvn(dstr, s, strend - s);
(void)SvOOK_off(TARG);
}
STATIC CV *
-get_db_sub(SV **svp, CV *cv)
+S_get_db_sub(pTHX_ SV **svp, CV *cv)
{
dTHR;
SV *dbsv = GvSV(PL_DBsub);
bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
if (!sv)
- DIE("Not a CODE reference");
+ DIE(aTHX_ "Not a CODE reference");
switch (SvTYPE(sv)) {
default:
if (!SvROK(sv)) {
else
sym = SvPV(sv, n_a);
if (!sym)
- DIE(PL_no_usym, "a subroutine");
+ DIE(aTHX_ PL_no_usym, "a subroutine");
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(PL_no_symref, sym, "a subroutine");
- cv = perl_get_cv(sym, TRUE);
+ DIE(aTHX_ PL_no_symref, sym, "a subroutine");
+ cv = get_cv(sym, TRUE);
break;
}
{
/* FALL THROUGH */
case SVt_PVHV:
case SVt_PVAV:
- DIE("Not a CODE reference");
+ DIE(aTHX_ "Not a CODE reference");
case SVt_PVCV:
cv = (CV*)sv;
break;
/* anonymous or undef'd function leaves us no recourse */
if (CvANON(cv) || !(gv = CvGV(cv)))
- DIE("Undefined subroutine called");
+ DIE(aTHX_ "Undefined subroutine called");
/* autoloaded stub? */
if (cv != GvCV(gv)) {
else {
sub_name = sv_newmortal();
gv_efullname3(sub_name, gv, Nullch);
- DIE("Undefined subroutine &%s called", SvPVX(sub_name));
+ DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
}
}
if (!cv)
- DIE("Not a CODE reference");
+ DIE(aTHX_ "Not a CODE reference");
goto retry;
}
if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
cv = get_db_sub(&sv, cv);
if (!cv)
- DIE("No DBsub routine");
+ DIE(aTHX_ "No DBsub routine");
}
#ifdef USE_THREADS
|| !(sv = AvARRAY(av)[0]))
{
MUTEX_UNLOCK(CvMUTEXP(cv));
- croak("no argument for locked method call");
+ Perl_croak(aTHX_ "no argument for locked method call");
}
}
if (SvROK(sv))
DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
thr, sv);)
MUTEX_UNLOCK(MgMUTEXP(mg));
- save_destructor(unlock_condpair, sv);
+ save_destructor(Perl_unlock_condpair, sv);
}
MUTEX_LOCK(CvMUTEXP(cv));
}
CvOWNER(cv) = thr;
SvREFCNT_inc(cv);
if (CvDEPTH(cv) == 0)
- SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
+ SAVEDESTRUCTOR(S_unset_cvowner, (void*) cv);
}
else {
/* (2) => grab ownership of cv. (3) => make clone */
DEBUG_S(if (CvDEPTH(cv) != 0)
PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
CvDEPTH(cv)););
- SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
+ SAVEDESTRUCTOR(S_unset_cvowner, (void*) cv);
}
}
#endif /* USE_THREADS */
if (CvXSUB(cv)) {
#ifdef PERL_XSUB_OLDSTYLE
if (CvOLDSTYLE(cv)) {
- I32 (*fp3)_((int,int,int));
+ I32 (*fp3)(int,int,int);
dMARK;
register I32 items = SP - MARK;
/* We dont worry to copy from @_. */
SP--;
}
PL_stack_sp = mark + 1;
- fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
+ fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
items = (*fp3)(CvXSUBANY(cv).any_i32,
MARK - PL_stack_base + 1,
items);
PL_curcopdb = NULL;
}
/* Do we need to open block here? XXXX */
- (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
+ (void)(*CvXSUB(cv))(aTHX_ cv);
/* Enforce some sanity in scalar context. */
if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
}
void
-sub_crush_depth(CV *cv)
+Perl_sub_crush_depth(pTHX_ CV *cv)
{
if (CvANON(cv))
- warner(WARN_RECURSION, "Deep recursion on anonymous subroutine");
+ Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
else {
SV* tmpstr = sv_newmortal();
gv_efullname3(tmpstr, CvGV(cv), Nullch);
- warner(WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
+ Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
SvPVX(tmpstr));
}
}
if (!svp || *svp == &PL_sv_undef) {
SV* lv;
if (!defer)
- DIE(PL_no_aelem, elem);
+ DIE(aTHX_ PL_no_aelem, elem);
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
}
void
-vivify_ref(SV *sv, U32 to_what)
+Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
{
if (SvGMAGICAL(sv))
mg_get(sv);
if (!SvOK(sv)) {
if (SvREADONLY(sv))
- croak(PL_no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
if (SvTYPE(sv) < SVt_RV)
sv_upgrade(sv, SVt_RV);
else if (SvTYPE(sv) >= SVt_PV) {
: !isIDFIRST(*packname)
))
{
- DIE("Can't call method \"%s\" %s", name,
+ DIE(aTHX_ "Can't call method \"%s\" %s", name,
SvOK(sv)? "without a package or object reference"
: "on an undefined value");
}
}
if (!ob || !SvOBJECT(ob))
- DIE("Can't call method \"%s\" on unblessed reference", name);
+ DIE(aTHX_ "Can't call method \"%s\" on unblessed reference", name);
stash = SvSTASH(ob);
packname = name;
packlen = sep - name;
}
- DIE("Can't locate object method \"%s\" via package \"%.*s\"",
+ DIE(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"",
leaf, (int)packlen, packname);
}
SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv);
projects / p5sagit/p5-mst-13.2.git / blobdiff