/* op.c
*
- * Copyright (c) 1991-1997, Larry Wall
+ * Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
static OP *too_many_arguments _((OP *o, char* name));
static void null _((OP* o));
static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq,
- CV* startcv, I32 cx_ix, I32 saweval));
+ CV* startcv, I32 cx_ix, I32 saweval, U32 flags));
static OP *newDEFSVOP _((void));
static OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp));
+static void simplify_sort _((OP *o));
+static bool is_handle_constructor _((OP *o, I32 argnum));
#endif
STATIC char*
gv_ename(GV *gv)
{
+ STRLEN n_a;
SV* tmpsv = sv_newmortal();
gv_efullname3(tmpsv, gv, Nullch);
- return SvPV(tmpsv,PL_na);
+ return SvPV(tmpsv,n_a);
}
STATIC OP *
name[1] == '_' && (int)strlen(name) > 2))
{
if (!isPRINT(name[1])) {
- name[3] = '\0';
+ /* 1999-02-27 mjd@plover.com */
+ char *p;
+ p = strchr(name, '\0');
+ /* The next block assumes the buffer is at least 205 chars
+ long. At present, it's always at least 256 chars. */
+ if (p-name > 200) {
+ strcpy(name+200, "...");
+ p = name+199;
+ }
+ else {
+ p[1] = '\0';
+ }
+ /* Move everything else down one character */
+ for (; p-name > 2; p--)
+ *p = *(p-1);
name[2] = toCTRL(name[1]);
name[1] = '^';
}
- croak("Can't use global %s in \"my\"",name);
+ yyerror(form("Can't use global %s in \"my\"",name));
}
if (ckWARN(WARN_UNSAFE) && AvFILLp(PL_comppad_name) >= 0) {
SV **svp = AvARRAY(PL_comppad_name);
sv_setpv(sv, name);
if (PL_in_my_stash) {
if (*name != '$')
- croak("Can't declare class for non-scalar %s in \"my\"",name);
+ yyerror(form("Can't declare class for non-scalar %s in \"my\"",
+ name));
SvOBJECT_on(sv);
(void)SvUPGRADE(sv, SVt_PVMG);
SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
return off;
}
+#define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
+
STATIC PADOFFSET
-pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval)
+pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval,
+ U32 flags)
{
dTHR;
CV *cv;
}
}
+ if (flags & FINDLEX_NOSEARCH)
+ return 0;
+
/* Nothing in current lexical context--try eval's context, if any.
* This is necessary to let the perldb get at lexically scoped variables.
* XXX This will also probably interact badly with eval tree caching.
default:
if (i == 0 && saweval) {
seq = cxstack[saweval].blk_oldcop->cop_seq;
- return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval);
+ return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
}
break;
case CXt_EVAL:
continue;
}
seq = cxstack[saweval].blk_oldcop->cop_seq;
- return pad_findlex(name, newoff, seq, cv, i-1, saweval);
+ return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
}
}
/* Check if if we're compiling an eval'', and adjust seq to be the
* eval's seq number. This depends on eval'' having a non-null
* CvOUTSIDE() while it is being compiled. The eval'' itself is
- * identified by CvUNIQUE being set and CvGV being null. */
- if (outside && CvUNIQUE(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
+ * identified by CvEVAL being true and CvGV being null. */
+ if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
cx = &cxstack[cxstack_ix];
if (CxREALEVAL(cx))
seq = cx->blk_oldcop->cop_seq;
}
/* See if it's in a nested scope */
- off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0);
+ off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
if (off) {
/* If there is a pending local definition, this new alias must die */
if (pendoff)
#ifdef USE_THREADS
/* find_threadsv is not reentrant */
PADOFFSET
-find_threadsv(char *name)
+find_threadsv(const char *name)
{
dTHR;
char *p;
if (!p)
return NOT_IN_PAD;
key = p - PL_threadsv_names;
+ MUTEX_LOCK(&thr->mutex);
svp = av_fetch(thr->threadsv, key, FALSE);
- if (!svp) {
+ if (svp)
+ MUTEX_UNLOCK(&thr->mutex);
+ else {
SV *sv = NEWSV(0, 0);
av_store(thr->threadsv, key, sv);
thr->threadsvp = AvARRAY(thr->threadsv);
+ MUTEX_UNLOCK(&thr->mutex);
/*
* Some magic variables used to be automagically initialised
* in gv_fetchpv. Those which are now per-thread magicals get
case '`':
case '\'':
PL_sawampersand = TRUE;
+ /* FALL THROUGH */
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
SvREADONLY_on(sv);
/* FALL THROUGH */
SV* sv;
/* assumes no premature commitment */
- if (!o || (o->op_flags & OPf_WANT) == OPf_WANT_LIST || PL_error_count
+ U8 want = o->op_flags & OPf_WANT;
+ if (!o || (want && want != OPf_WANT_SCALAR) || PL_error_count
|| o->op_type == OP_RETURN)
return o;
dTHR;
OP *kid;
SV *sv;
+ STRLEN n_a;
if (!o || PL_error_count)
return o;
case OP_AV2ARYLEN:
PL_hints |= HINT_BLOCK_SCOPE;
case OP_SASSIGN:
+ case OP_ANDASSIGN:
+ case OP_ORASSIGN:
case OP_AELEMFAST:
PL_modcount++;
break;
PL_modcount++;
if (!type)
croak("Can't localize lexical variable %s",
- SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), PL_na));
+ SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
break;
#ifdef USE_THREADS
case OP_READ:
case OP_SYSREAD:
case OP_RECV:
- case OP_ANDASSIGN: /* may work later */
- case OP_ORASSIGN: /* may work later */
+ case OP_ANDASSIGN:
+ case OP_ORASSIGN:
return TRUE;
default:
return FALSE;
}
}
+STATIC bool
+is_handle_constructor(OP *o, I32 argnum)
+{
+ switch (o->op_type) {
+ case OP_PIPE_OP:
+ case OP_SOCKPAIR:
+ if (argnum == 2)
+ return TRUE;
+ /* FALL THROUGH */
+ case OP_SYSOPEN:
+ case OP_OPEN:
+ case OP_SELECT: /* XXX c.f. SelectSaver.pm */
+ case OP_SOCKET:
+ case OP_OPEN_DIR:
+ case OP_ACCEPT:
+ if (argnum == 1)
+ return TRUE;
+ /* FALL THROUGH */
+ default:
+ return FALSE;
+ }
+}
+
OP *
refkids(OP *o, I32 type)
{
ref(kid, type);
break;
case OP_RV2SV:
+ if (type == OP_DEFINED)
+ o->op_flags |= OPf_SPECIAL; /* don't create GV */
ref(cUNOPo->op_first, o->op_type);
/* FALL THROUGH */
case OP_PADSV:
o->op_flags |= OPf_REF;
/* FALL THROUGH */
case OP_RV2GV:
+ if (type == OP_DEFINED)
+ o->op_flags |= OPf_SPECIAL; /* don't create GV */
ref(cUNOPo->op_first, o->op_type);
break;
char *s;
for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ;
if (*s == ';' || *s == '=')
- warner(WARN_PARENTHESIS, "Parens missing around \"%s\" list",
+ warner(WARN_PARENTHESIS, "Parentheses missing around \"%s\" list",
lex ? "my" : "local");
}
}
if (repl) {
OP *curop;
- if (pm->op_pmflags & PMf_EVAL)
+ if (pm->op_pmflags & PMf_EVAL) {
curop = 0;
+ if (PL_curcop->cop_line < PL_multi_end)
+ PL_curcop->cop_line = PL_multi_end;
+ }
#ifdef USE_THREADS
else if (repl->op_type == OP_THREADSV
&& strchr("&`'123456789+",
sv_setpv(PL_curstname,"<none>");
PL_curstash = Nullhv;
}
+ PL_hints |= HINT_BLOCK_SCOPE;
PL_copline = NOLINE;
PL_expect = XSTATE;
}
{
dTHR;
OP *o;
+ STRLEN n_a;
+
if (type != OP_GOTO || label->op_type == OP_CONST) {
/* "last()" means "last" */
if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
o = newOP(type, OPf_SPECIAL);
else {
o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
- ? SvPVx(((SVOP*)label)->op_sv, PL_na)
+ ? SvPVx(((SVOP*)label)->op_sv, n_a)
: ""));
}
op_free(label);
char *name = SvPVX(namesv); /* XXX */
if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
I32 off = pad_findlex(name, ix, SvIVX(namesv),
- CvOUTSIDE(cv), cxstack_ix, 0);
+ CvOUTSIDE(cv), cxstack_ix, 0, 0);
if (!off)
PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
else if (off != ix)
CV *
cv_clone(CV *proto)
{
- return cv_clone2(proto, CvOUTSIDE(proto));
+ CV *cv;
+ MUTEX_LOCK(&PL_cred_mutex); /* XXX create separate mutex */
+ cv = cv_clone2(proto, CvOUTSIDE(proto));
+ MUTEX_UNLOCK(&PL_cred_mutex); /* XXX create separate mutex */
+ return cv;
}
void
newSUB(I32 floor, OP *o, OP *proto, OP *block)
{
dTHR;
- char *name = o ? SvPVx(cSVOPo->op_sv, PL_na) : Nullch;
+ STRLEN n_a;
+ char *name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
GV *gv = gv_fetchpv(name ? name : "__ANON__",
GV_ADDMULTI | (block ? 0 : GV_NOINIT), SVt_PVCV);
- char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, PL_na) : Nullch;
+ char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
register CV *cv=0;
I32 ix;
else {
/* force display of errors found but not reported */
sv_catpv(ERRSV, not_safe);
- croak("%s", SvPVx(ERRSV, PL_na));
+ croak("%s", SvPVx(ERRSV, n_a));
}
}
}
return cv;
}
+/* XXX unsafe for threads if eval_owner isn't held */
void
newCONSTSUB(HV *stash, char *name, SV *sv)
{
char *name;
GV *gv;
I32 ix;
+ STRLEN n_a;
if (o)
- name = SvPVx(cSVOPo->op_sv, PL_na);
+ name = SvPVx(cSVOPo->op_sv, n_a);
else
name = "STDOUT";
gv = gv_fetchpv(name,TRUE, SVt_PVFM);
int iscv;
GV *gv;
SV *kidsv = kid->op_sv;
+ STRLEN n_a;
/* Is it a constant from cv_const_sv()? */
if (SvROK(kidsv) && SvREADONLY(kidsv)) {
croak("Constant is not %s reference", badtype);
return o;
}
- name = SvPV(kidsv, PL_na);
+ name = SvPV(kidsv, n_a);
if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
char *badthing = Nullch;
switch (o->op_type) {
SVOP *kid = (SVOP*)cUNOPo->op_first;
if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+ STRLEN n_a;
OP *newop = newGVOP(type, OPf_REF,
- gv_fetchpv(SvPVx(kid->op_sv, PL_na), TRUE, SVt_PVIO));
+ gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
op_free(o);
return newop;
}
}
if (o->op_flags & OPf_KIDS) {
+ STRLEN n_a;
tokid = &cLISTOPo->op_first;
kid = cLISTOPo->op_first;
if (kid->op_type == OP_PUSHMARK ||
sibl = kid->op_sibling;
switch (oa & 7) {
case OA_SCALAR:
+ /* list seen where single (scalar) arg expected? */
+ if (numargs == 1 && !(oa >> 4)
+ && kid->op_type == OP_LIST && type != OP_SCALAR)
+ {
+ return too_many_arguments(o,PL_op_desc[type]);
+ }
scalar(kid);
break;
case OA_LIST:
break;
case OA_AVREF:
if (kid->op_type == OP_CONST &&
- (kid->op_private & OPpCONST_BARE)) {
- char *name = SvPVx(((SVOP*)kid)->op_sv, PL_na);
+ (kid->op_private & OPpCONST_BARE))
+ {
+ char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
OP *newop = newAVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVAV) ));
if (ckWARN(WARN_SYNTAX))
*tokid = kid;
}
else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
- bad_type(numargs, "array", PL_op_desc[o->op_type], kid);
+ bad_type(numargs, "array", PL_op_desc[type], kid);
mod(kid, type);
break;
case OA_HVREF:
if (kid->op_type == OP_CONST &&
- (kid->op_private & OPpCONST_BARE)) {
- char *name = SvPVx(((SVOP*)kid)->op_sv, PL_na);
+ (kid->op_private & OPpCONST_BARE))
+ {
+ char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
OP *newop = newHVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVHV) ));
if (ckWARN(WARN_SYNTAX))
*tokid = kid;
}
else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
- bad_type(numargs, "hash", PL_op_desc[o->op_type], kid);
+ bad_type(numargs, "hash", PL_op_desc[type], kid);
mod(kid, type);
break;
case OA_CVREF:
case OA_FILEREF:
if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
if (kid->op_type == OP_CONST &&
- (kid->op_private & OPpCONST_BARE)) {
+ (kid->op_private & OPpCONST_BARE))
+ {
OP *newop = newGVOP(OP_GV, 0,
- gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, PL_na), TRUE,
+ gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
SVt_PVIO) );
op_free(kid);
kid = newop;
bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
}
else {
+ I32 flags = OPf_SPECIAL;
+ /* is this op a FH constructor? */
+ if (is_handle_constructor(o,numargs))
+ flags = 0;
kid->op_sibling = 0;
- kid = newUNOP(OP_RV2GV, 0, scalar(kid));
+ kid = newUNOP(OP_RV2GV, flags, scalar(kid));
}
kid->op_sibling = sibl;
*tokid = kid;
gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
if (gv && GvIMPORTED_CV(gv)) {
- static int glob_index;
-
append_elem(OP_GLOB, o,
- newSVOP(OP_CONST, 0, newSViv(glob_index++)));
+ newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
o->op_type = OP_LIST;
o->op_ppaddr = PL_ppaddr[OP_LIST];
cLISTOPo->op_first->op_type = OP_PUSHMARK;
o->op_private |= OPpLOCALE;
#endif
- if (o->op_flags & OPf_STACKED) {
+ if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
+ simplify_sort(o);
+ if (o->op_flags & OPf_STACKED) { /* may have been cleared */
OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
OP *k;
kid = kUNOP->op_first; /* get past rv2gv */
kid->op_next = k;
o->op_flags |= OPf_SPECIAL;
}
+ else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
+ null(cLISTOPo->op_first->op_sibling);
}
return o;
}
+STATIC void
+simplify_sort(OP *o)
+{
+ dTHR;
+ register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+ OP *k;
+ int reversed;
+ if (!(o->op_flags & OPf_STACKED))
+ return;
+ GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
+ GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
+ kid = kUNOP->op_first; /* get past rv2gv */
+ if (kid->op_type != OP_SCOPE)
+ return;
+ kid = kLISTOP->op_last; /* get past scope */
+ switch(kid->op_type) {
+ case OP_NCMP:
+ case OP_I_NCMP:
+ case OP_SCMP:
+ break;
+ default:
+ return;
+ }
+ k = kid; /* remember this node*/
+ if (kBINOP->op_first->op_type != OP_RV2SV)
+ return;
+ kid = kBINOP->op_first; /* get past cmp */
+ if (kUNOP->op_first->op_type != OP_GV)
+ return;
+ kid = kUNOP->op_first; /* get past rv2sv */
+ if (GvSTASH(kGVOP->op_gv) != PL_curstash)
+ return;
+ if (strEQ(GvNAME(kGVOP->op_gv), "a"))
+ reversed = 0;
+ else if(strEQ(GvNAME(kGVOP->op_gv), "b"))
+ reversed = 1;
+ else
+ return;
+ kid = k; /* back to cmp */
+ if (kBINOP->op_last->op_type != OP_RV2SV)
+ return;
+ kid = kBINOP->op_last; /* down to 2nd arg */
+ if (kUNOP->op_first->op_type != OP_GV)
+ return;
+ kid = kUNOP->op_first; /* get past rv2sv */
+ if (GvSTASH(kGVOP->op_gv) != PL_curstash
+ || ( reversed
+ ? strNE(GvNAME(kGVOP->op_gv), "a")
+ : strNE(GvNAME(kGVOP->op_gv), "b")))
+ return;
+ o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
+ if (reversed)
+ o->op_private |= OPpSORT_REVERSE;
+ if (k->op_type == OP_NCMP)
+ o->op_private |= OPpSORT_NUMERIC;
+ if (k->op_type == OP_I_NCMP)
+ o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
+ op_free(cLISTOPo->op_first->op_sibling); /* delete comparison block */
+ cLISTOPo->op_first->op_sibling = cLISTOPo->op_last;
+ cLISTOPo->op_children = 1;
+}
+
OP *
ck_split(OP *o)
{
GV *namegv = 0;
int optional = 0;
I32 arg = 0;
+ STRLEN n_a;
for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
if (cvop->op_type == OP_RV2CV) {
cv = GvCVu(tmpop->op_sv);
if (cv && SvPOK(cv) && !(o->op_private & OPpENTERSUB_AMPER)) {
namegv = CvANON(cv) ? (GV*)tmpop->op_sv : CvGV(cv);
- proto = SvPV((SV*)cv, PL_na);
+ proto = SvPV((SV*)cv, n_a);
}
}
}
bad_type(arg, "block", gv_ename(namegv), o2);
break;
case '*':
+ /* '*' allows any scalar type, including bareword */
proto++;
arg++;
if (o2->op_type == OP_RV2GV)
- goto wrapref;
- {
- OP* kid = o2;
- OP* sib = kid->op_sibling;
- kid->op_sibling = 0;
- o2 = newUNOP(OP_RV2GV, 0, kid);
- o2->op_sibling = sib;
- prev->op_sibling = o2;
- }
- goto wrapref;
+ goto wrapref; /* autoconvert GLOB -> GLOBref */
+ scalar(o2);
+ break;
case '\\':
proto++;
arg++;
default:
oops:
croak("Malformed prototype for %s: %s",
- gv_ename(namegv), SvPV((SV*)cv, PL_na));
+ gv_ename(namegv), SvPV((SV*)cv, n_a));
}
}
else
{
dTHR;
register OP* oldop = 0;
+ STRLEN n_a;
+
if (!o || o->op_seq)
return;
ENTER;
indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
if (!indsvp) {
croak("No such field \"%s\" in variable %s of type %s",
- key, SvPV(lexname, PL_na), HvNAME(SvSTASH(lexname)));
+ key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
}
ind = SvIV(*indsvp);
if (ind < 1)
https://perl5.git.perl.org / perl5.git / blobdiff