From: Gurusamy Sarathy Date: Mon, 24 May 1999 01:49:20 +0000 (+0000) Subject: redo change#2061 and parts of change#1169 with code in the X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7a52d87a7fbc7848e6b3e9e96db52d4070212cca;p=p5sagit%2Fp5-mst-13.2.git redo change#2061 and parts of change#1169 with code in the parser; PL_last_proto hackery gone, strict 'subs' in now implemented in the optimizer where specifying the exceptional cases is much more robust; '*' (bareword) prototype now works reliably when used in second and subsequent arguments p4raw-link: @2061 on //depot/perl: bf8481137c02593eb36f8d0e234a2ec41a1c92e4 p4raw-link: @1169 on //depot/perl: 2a841d1398ee9bbf30a942905192cc2591b3e92a p4raw-id: //depot/perl@3447 --- diff --git a/dump.c b/dump.c index cb3a643..cc6682a 100644 --- a/dump.c +++ b/dump.c @@ -481,6 +481,8 @@ do_op_dump(I32 level, PerlIO *file, OP *o) else if (o->op_type == OP_CONST) { if (o->op_private & OPpCONST_BARE) sv_catpv(tmpsv, ",BARE"); + if (o->op_private & OPpCONST_STRICT) + sv_catpv(tmpsv, ",STRICT"); } else if (o->op_type == OP_FLIP) { if (o->op_private & OPpFLIP_LINENUM) diff --git a/embed.h b/embed.h index 8c2474a..e413efc 100644 --- a/embed.h +++ b/embed.h @@ -1452,6 +1452,7 @@ #define nextargv CPerlObj::Perl_nextargv #define nextchar CPerlObj::Perl_nextchar #define ninstr CPerlObj::Perl_ninstr +#define no_bareword_allowed CPerlObj::Perl_no_bareword_allowed #define no_fh_allowed CPerlObj::Perl_no_fh_allowed #define no_op CPerlObj::Perl_no_op #define not_a_number CPerlObj::Perl_not_a_number diff --git a/embed.pl b/embed.pl index 2fde0dd..028e217 100755 --- a/embed.pl +++ b/embed.pl @@ -313,6 +313,7 @@ my @staticfuncs = qw( bad_type modkids no_fh_allowed + no_bareword_allowed scalarboolean too_few_arguments too_many_arguments diff --git a/objXSUB.h b/objXSUB.h index f037d3a..a74e8ee 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -1765,6 +1765,8 @@ #define nextchar pPerl->Perl_nextchar #undef ninstr #define ninstr pPerl->Perl_ninstr +#undef no_bareword_allowed +#define no_bareword_allowed pPerl->Perl_no_bareword_allowed #undef no_fh_allowed #define no_fh_allowed pPerl->Perl_no_fh_allowed #undef no_op diff --git a/op.c b/op.c index 94c0b39..0697764 100644 --- a/op.c +++ b/op.c @@ -66,6 +66,7 @@ static I32 list_assignment _((OP *o)); static void bad_type _((I32 n, char *t, char *name, OP *kid)); static OP *modkids _((OP *o, I32 type)); static OP *no_fh_allowed _((OP *o)); +static void no_bareword_allowed _((OP *o)); static OP *scalarboolean _((OP *o)); static OP *too_few_arguments _((OP *o, char* name)); static OP *too_many_arguments _((OP *o, char* name)); @@ -116,6 +117,14 @@ bad_type(I32 n, char *t, char *name, OP *kid) (int)n, name, t, PL_op_desc[kid->op_type])); } +STATIC void +no_bareword_allowed(OP *o) +{ + warn("Bareword \"%s\" not allowed while \"strict subs\" in use", + SvPV_nolen(cSVOPo->op_sv)); + ++PL_error_count; +} + void assertref(OP *o) { @@ -987,7 +996,9 @@ scalarvoid(OP *o) case OP_CONST: sv = cSVOPo->op_sv; - { + if (cSVOPo->op_private & OPpCONST_STRICT) + no_bareword_allowed(o); + else { dTHR; if (ckWARN(WARN_VOID)) { useless = "a constant"; @@ -1841,6 +1852,10 @@ fold_constants(register OP *o) goto nope; switch (type) { + case OP_NEGATE: + /* XXX might want a ck_negate() for this */ + cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; + break; case OP_SPRINTF: case OP_UCFIRST: case OP_LCFIRST: @@ -1861,10 +1876,11 @@ fold_constants(register OP *o) for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { if (curop->op_type != OP_CONST && - curop->op_type != OP_LIST && - curop->op_type != OP_SCALAR && - curop->op_type != OP_NULL && - curop->op_type != OP_PUSHMARK) { + curop->op_type != OP_LIST && + curop->op_type != OP_SCALAR && + curop->op_type != OP_NULL && + curop->op_type != OP_PUSHMARK) + { goto nope; } } @@ -5356,6 +5372,10 @@ ck_subr(OP *o) } } } + else if (cvop->op_type == OP_METHOD) { + if (o2->op_type == OP_CONST) + o2->op_private &= ~OPpCONST_STRICT; + } o->op_private |= (PL_hints & HINT_STRICT_REFS); if (PERLDB_SUB && PL_curstash != PL_debstash) o->op_private |= OPpENTERSUB_DB; @@ -5390,6 +5410,8 @@ ck_subr(OP *o) arg++; if (o2->op_type == OP_RV2GV) goto wrapref; /* autoconvert GLOB -> GLOBref */ + else if (o2->op_type == OP_CONST) + o2->op_private &= ~OPpCONST_STRICT; scalar(o2); break; case '\\': @@ -5502,8 +5524,11 @@ peep(register OP *o) o->op_seq = PL_op_seqmax++; break; - case OP_CONCAT: case OP_CONST: + if (cSVOPo->op_private & OPpCONST_STRICT) + no_bareword_allowed(o); + /* FALL THROUGH */ + case OP_CONCAT: case OP_JOIN: case OP_UC: case OP_UCFIRST: diff --git a/op.h b/op.h index 67e636f..03ea2af 100644 --- a/op.h +++ b/op.h @@ -123,12 +123,14 @@ typedef U32 PADOFFSET; #define OPpDEREF_SV (32|64) /* Want ref to SV. */ /* OP_ENTERSUB only */ #define OPpENTERSUB_DB 16 /* Debug subroutine. */ + /* OP_RV2CV only */ #define OPpENTERSUB_AMPER 8 /* Used & form to call. */ /* OP_?ELEM only */ #define OPpLVAL_DEFER 16 /* Defer creation of array/hash elem */ /* for OP_RV2?V, lower bits carry hints */ /* Private for OP_CONST */ +#define OPpCONST_STRICT 8 /* bearword subject to strict 'subs' */ #define OPpCONST_ENTERED 16 /* Has been entered as symbol. */ #define OPpCONST_ARYBASE 32 /* Was a $[ translated to constant. */ #define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */ diff --git a/proto.h b/proto.h index ea364f1..6ec5b37 100644 --- a/proto.h +++ b/proto.h @@ -821,6 +821,7 @@ CV *get_db_sub _((SV **svp, CV *cv)); I32 list_assignment _((OP *o)); void bad_type _((I32 n, char *t, char *name, OP *kid)); OP *modkids _((OP *o, I32 type)); +void no_bareword_allowed _((OP *o)); OP *no_fh_allowed _((OP *o)); OP *scalarboolean _((OP *o)); OP *too_few_arguments _((OP *o, char* name)); diff --git a/toke.c b/toke.c index 739c666..df45a56 100644 --- a/toke.c +++ b/toke.c @@ -3186,13 +3186,9 @@ int yylex(PERL_YYLEX_PARAM_DECL) s = skipspace(s); if (*s == '(') { CLINE; - PL_last_proto = Nullch; if (gv && GvCVu(gv)) { - CV *cv; - if ((cv = GvCV(gv)) && SvPOK(cv)) - PL_last_proto = SvPV((SV*)cv, n_a); for (d = s + 1; *d == ' ' || *d == '\t'; d++) ; - if (*d == ')' && (sv = cv_const_sv(cv))) { + if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) { s = d + 1; goto its_constant; } @@ -3201,7 +3197,6 @@ int yylex(PERL_YYLEX_PARAM_DECL) PL_expect = XOPERATOR; force_next(WORD); yylval.ival = 0; - PL_last_lop_op = OP_ENTERSUB; TOKEN('&'); } @@ -3225,9 +3220,6 @@ int yylex(PERL_YYLEX_PARAM_DECL) if (lastchar == '-') warn("Ambiguous use of -%s resolved as -&%s()", PL_tokenbuf, PL_tokenbuf); - PL_last_lop = PL_oldbufptr; - PL_last_lop_op = OP_ENTERSUB; - PL_last_proto = Nullch; /* Check for a constant sub */ cv = GvCV(gv); if ((sv = cv_const_sv(cv))) { @@ -3241,16 +3233,17 @@ int yylex(PERL_YYLEX_PARAM_DECL) /* Resolve to GV now. */ op_free(yylval.opval); yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); + PL_last_lop = PL_oldbufptr; PL_last_lop_op = OP_ENTERSUB; /* Is there a prototype? */ if (SvPOK(cv)) { STRLEN len; - PL_last_proto = SvPV((SV*)cv, len); + char *proto = SvPV((SV*)cv, len); if (!len) TERM(FUNC0SUB); - if (strEQ(PL_last_proto, "$")) + if (strEQ(proto, "$")) OPERATOR(UNIOPSUB); - if (*PL_last_proto == '&' && *s == '{') { + if (*proto == '&' && *s == '{') { sv_setpv(PL_subname,"__ANON__"); PREBLOCK(LSTOPSUB); } @@ -3261,27 +3254,8 @@ int yylex(PERL_YYLEX_PARAM_DECL) TOKEN(NOAMP); } - /* It could be a prototypical bearword. */ - if (PL_last_lop_op == OP_ENTERSUB && PL_last_proto && - PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*') - { - PL_last_proto = Nullch; - TOKEN(WORD); - } - - if (PL_hints & HINT_STRICT_SUBS && - lastchar != '-' && - strnNE(s,"->",2) && - PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */ - PL_last_lop_op != OP_ACCEPT && - PL_last_lop_op != OP_PIPE_OP && - PL_last_lop_op != OP_SOCKPAIR) - { - warn( - "Bareword \"%s\" not allowed while \"strict subs\" in use", - PL_tokenbuf); - ++PL_error_count; - } + if (PL_hints & HINT_STRICT_SUBS) + yylval.opval->op_private |= OPpCONST_STRICT; /* Call it a bare word */