/* Hot code. */
#ifdef USE_THREADS
-STATIC void
-S_unset_cvowner(pTHX_ void *cvarg)
-{
- register CV* cv = (CV *) cvarg;
-#ifdef DEBUGGING
- dTHR;
-#endif /* DEBUGGING */
-
- DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
- thr, cv, SvPEEK((SV*)cv))));
- MUTEX_LOCK(CvMUTEXP(cv));
- DEBUG_S(if (CvDEPTH(cv) != 0)
- PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
- CvDEPTH(cv)););
- assert(thr == CvOWNER(cv));
- CvOWNER(cv) = 0;
- MUTEX_UNLOCK(CvMUTEXP(cv));
- SvREFCNT_dec(cv);
-}
+static void unset_cvowner(pTHXo_ void *cvarg);
#endif /* USE_THREADS */
PP(pp_const)
return NORMAL;
}
+PP(pp_setstate)
+{
+ PL_curcop = (COP*)PL_op;
+ return NORMAL;
+}
+
PP(pp_pushmark)
{
PUSHMARK(PL_stack_sp);
{
djSP;
if (SvTRUEx(POPs))
- RETURNOP(cCONDOP->op_true);
+ RETURNOP(cLOGOP->op_other);
else
- RETURNOP(cCONDOP->op_false);
+ RETURNOP(cLOGOP->op_next);
}
PP(pp_unstack)
if (!(io = GvIO(gv))) {
if (ckWARN(WARN_UNOPENED)) {
SV* sv = sv_newmortal();
- gv_fullname3(sv, gv, Nullch);
- Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
+ gv_efullname3(sv, gv, Nullch);
+ Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened",
+ SvPV(sv,n_a));
}
-
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
if (ckWARN2(WARN_CLOSED, WARN_IO)) {
SV* sv = sv_newmortal();
- gv_fullname3(sv, gv, Nullch);
+ gv_efullname3(sv, gv, Nullch);
if (IoIFP(io))
- Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for input",
- SvPV(sv,n_a));
+ Perl_warner(aTHX_ WARN_IO,
+ "Filehandle %s opened only for input",
+ SvPV(sv,n_a));
else if (ckWARN(WARN_CLOSED))
- Perl_warner(aTHX_ WARN_CLOSED, "print on closed filehandle %s",
- SvPV(sv,n_a));
+ Perl_warner(aTHX_ WARN_CLOSED,
+ "print on closed filehandle %s", SvPV(sv,n_a));
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
dTARGET;
if (SvTYPE(hv) == SVt_PVAV)
hv = avhv_keys((AV*)hv);
+#ifdef IV_IS_QUAD
+ if (HvFILL(hv))
+ Perl_sv_setpvf(aTHX_ TARG, "%" PERL_PRId64 "/%" PERL_PRId64,
+ (Quad_t)HvFILL(hv), (Quad_t)HvMAX(hv) + 1);
+#else
if (HvFILL(hv))
- Perl_sv_setpvf(aTHX_ TARG, "%ld/%ld",
- (long)HvFILL(hv), (long)HvMAX(hv) + 1);
+ Perl_sv_setpvf(aTHX_ TARG, "%ld/%ld",
+ (long)HvFILL(hv), (long)HvMAX(hv) + 1);
+#endif
else
sv_setiv(TARG, 0);
}
# endif /* HAS_SETREUID */
#endif /* HAS_SETRESUID */
- PL_uid = (int)PerlProc_getuid();
- PL_euid = (int)PerlProc_geteuid();
+ PL_uid = PerlProc_getuid();
+ PL_euid = PerlProc_geteuid();
}
if (PL_delaymagic & DM_GID) {
#ifdef HAS_SETRESGID
}
# endif /* HAS_SETREGID */
#endif /* HAS_SETRESGID */
- PL_gid = (int)PerlProc_getgid();
- PL_egid = (int)PerlProc_getegid();
+ PL_gid = PerlProc_getgid();
+ PL_egid = PerlProc_getegid();
}
PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
}
}
else if (type == OP_GLOB)
SP--;
+ else if (ckWARN(WARN_IO) /* stdout/stderr or other write fh */
+ && (IoTYPE(io) == '>' || fp == PerlIO_stdout()
+ || fp == PerlIO_stderr()))
+ {
+ SV* sv = sv_newmortal();
+ gv_efullname3(sv, PL_last_in_gv, Nullch);
+ Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
+ SvPV_nolen(sv));
+ }
}
if (!fp) {
if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) {
if (type == OP_GLOB)
- Perl_warner(aTHX_ WARN_CLOSED, "glob failed (can't start child: %s)",
- Strerror(errno));
- else
- Perl_warner(aTHX_ WARN_CLOSED, "Read on closed filehandle <%s>",
- GvENAME(PL_last_in_gv));
+ Perl_warner(aTHX_ WARN_CLOSED,
+ "glob failed (can't start child: %s)",
+ Strerror(errno));
+ else {
+ SV* sv = sv_newmortal();
+ gv_efullname3(sv, PL_last_in_gv, Nullch);
+ Perl_warner(aTHX_ WARN_CLOSED,
+ "Read on closed filehandle %s",
+ SvPV_nolen(sv));
+ }
}
if (gimme == G_SCALAR) {
(void)SvOK_off(TARG);
DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
thr, sv);)
MUTEX_UNLOCK(MgMUTEXP(mg));
- save_destructor(Perl_unlock_condpair, sv);
+ SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
}
MUTEX_LOCK(CvMUTEXP(cv));
}
CvOWNER(cv) = thr;
SvREFCNT_inc(cv);
if (CvDEPTH(cv) == 0)
- SAVEDESTRUCTOR(S_unset_cvowner, (void*) cv);
+ SAVEDESTRUCTOR(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(S_unset_cvowner, (void*) cv);
+ SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
}
}
#endif /* USE_THREADS */
PP(pp_method)
{
djSP;
+ SV* sv = TOPs;
+
+ if (SvROK(sv)) {
+ SV* rsv = SvRV(sv);
+ if (SvTYPE(rsv) == SVt_PVCV) {
+ SETs(rsv);
+ RETURN;
+ }
+ }
+
+ SETs(method_common(sv, Null(U32*)));
+ RETURN;
+}
+
+PP(pp_method_named)
+{
+ djSP;
+ SV* sv = cSVOP->op_sv;
+ U32 hash = SvUVX(sv);
+
+ XPUSHs(method_common(sv, &hash));
+ RETURN;
+}
+
+STATIC SV *
+S_method_common(pTHX_ SV* meth, U32* hashp)
+{
+ djSP;
SV* sv;
SV* ob;
GV* gv;
HV* stash;
char* name;
+ STRLEN namelen;
char* packname;
STRLEN packlen;
- if (SvROK(TOPs)) {
- sv = SvRV(TOPs);
- if (SvTYPE(sv) == SVt_PVCV) {
- SETs(sv);
- RETURN;
- }
- }
-
- name = SvPV(TOPs, packlen);
+ name = SvPV(meth, namelen);
sv = *(PL_stack_base + TOPMARK + 1);
-
+
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvROK(sv))
: !isIDFIRST(*packname)
))
{
- DIE(aTHX_ "Can't call method \"%s\" %s", name,
- SvOK(sv)? "without a package or object reference"
- : "on an undefined value");
+ Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
+ SvOK(sv) ? "without a package or object reference"
+ : "on an undefined value");
}
stash = gv_stashpvn(packname, packlen, TRUE);
goto fetch;
}
if (!ob || !SvOBJECT(ob))
- DIE(aTHX_ "Can't call method \"%s\" on unblessed reference", name);
+ Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
+ name);
stash = SvSTASH(ob);
fetch:
+ /* shortcut for simple names */
+ if (hashp) {
+ HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
+ if (he) {
+ gv = (GV*)HeVAL(he);
+ if (isGV(gv) && GvCV(gv) &&
+ (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
+ return (SV*)GvCV(gv);
+ }
+ }
+
gv = gv_fetchmethod(stash, name);
if (!gv) {
char* leaf = name;
packname = name;
packlen = sep - name;
}
- DIE(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"",
- leaf, (int)packlen, packname);
+ Perl_croak(aTHX_
+ "Can't locate object method \"%s\" via package \"%s\"",
+ leaf, packname);
}
- SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv);
- RETURN;
+ return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
}
+#ifdef USE_THREADS
+static void
+unset_cvowner(pTHXo_ void *cvarg)
+{
+ register CV* cv = (CV *) cvarg;
+#ifdef DEBUGGING
+ dTHR;
+#endif /* DEBUGGING */
+
+ DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
+ thr, cv, SvPEEK((SV*)cv))));
+ MUTEX_LOCK(CvMUTEXP(cv));
+ DEBUG_S(if (CvDEPTH(cv) != 0)
+ PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
+ CvDEPTH(cv)););
+ assert(thr == CvOWNER(cv));
+ CvOWNER(cv) = 0;
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ SvREFCNT_dec(cv);
+}
+#endif /* USE_THREADS */
projects / p5sagit/p5-mst-13.2.git / blobdiff