From: Rafael Garcia-Suarez Date: Thu, 1 Sep 2005 14:45:23 +0000 (+0000) Subject: Add the "no 6" / "no v6" syntax. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=468aa647417bbcdb0729a787fa25968401364880;p=p5sagit%2Fp5-mst-13.2.git Add the "no 6" / "no v6" syntax. p4raw-id: //depot/perl@25344 --- diff --git a/embed.fnc b/embed.fnc index 690977b..9ff584a 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1315,6 +1315,7 @@ sR |I32 |sublex_push sR |I32 |sublex_start sR |char * |filter_gets |NN SV *sv|NN PerlIO *fp|STRLEN append sR |HV * |find_in_my_stash|NN const char *pkgname|I32 len +sR |char * |tokenize_use |int|NN char* s |SV* |new_constant |NULLOK const char *s|STRLEN len|NN const char *key|NN SV *sv \ |NULLOK SV *pv|NULLOK const char *type # if defined(DEBUGGING) diff --git a/embed.h b/embed.h index 5faec5a..626b213 100644 --- a/embed.h +++ b/embed.h @@ -1366,6 +1366,7 @@ #define sublex_start S_sublex_start #define filter_gets S_filter_gets #define find_in_my_stash S_find_in_my_stash +#define tokenize_use S_tokenize_use #define new_constant S_new_constant #endif # if defined(DEBUGGING) @@ -3350,6 +3351,7 @@ #define sublex_start() S_sublex_start(aTHX) #define filter_gets(a,b,c) S_filter_gets(aTHX_ a,b,c) #define find_in_my_stash(a,b) S_find_in_my_stash(aTHX_ a,b) +#define tokenize_use(a,b) S_tokenize_use(aTHX_ a,b) #define new_constant(a,b,c,d,e,f) S_new_constant(aTHX_ a,b,c,d,e,f) #endif # if defined(DEBUGGING) diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t index e72a180..f1fbbd9 100644 --- a/ext/B/t/concise-xs.t +++ b/ext/B/t/concise-xs.t @@ -90,14 +90,14 @@ use Getopt::Std; use Carp; use Test::More tests => ( 1 * !!$Config::Config{useithreads} + 2 * ($] > 5.009) - + 776); + + 777 ); require_ok("B::Concise"); my $testpkgs = { - + Digest::MD5 => [qw/ ! import /], - + B => [qw/ ! class clearsym compile_stats debug objsym parents peekop savesym timing_info walkoptree_exec walkoptree_slow walksymtable /], @@ -136,7 +136,7 @@ usage: PERL_CORE=1 ./perl ext/B/t/concise-xs.t [-av] [module-list] -a : runs all modules in CoreList -c : writes test corrections as a Data::Dumper expression -r : reads file of tests, as written by -c - : additional modules are loaded and tested + : additional modules are loaded and tested (will report failures, since no XS funcs are known aprior) EODIE @@ -153,7 +153,7 @@ my %report; if ($opts{r}) { my $refpkgs = require "$opts{r}"; $testpkgs->{$_} = $refpkgs->{$_} foreach keys %$refpkgs; -} +} unless ($opts{a}) { unless (@argpkgs) { @@ -178,10 +178,10 @@ sub test_pkg { warn "no XS/non-XS function list given, assuming empty XS list"; $xslist = ['']; } - + my $assumeXS = 0; # assume list enumerates XS funcs, not perl ones $assumeXS = 1 if $xslist->[0] and $xslist->[0] eq '!'; - + # build %stash: keys are func-names, vals: 1 if XS, 0 if not my (%stash) = map ( ($_ => $assumeXS) @@ -189,10 +189,10 @@ sub test_pkg { => grep !/__ANON__/ # but not anon subs => keys %{$pkg_name.'::'} # from symbol table )); - + # now invert according to supplied list $stash{$_} = int ! $assumeXS foreach @$xslist; - + # and cleanup cruft (easier than preventing) delete @stash{'!',''}; diff --git a/op.c b/op.c index c0cca4e..c6b85a3 100644 --- a/op.c +++ b/op.c @@ -3057,6 +3057,8 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) imop = arg; /* no import on explicit () */ else if (SvNIOKp(((SVOP*)idop)->op_sv)) { imop = Nullop; /* use 5.0; */ + if (!aver) + idop->op_private |= OPpCONST_NOVER; } else { SV *meth; diff --git a/op.h b/op.h index 5a39d1e..2c4937f 100644 --- a/op.h +++ b/op.h @@ -184,6 +184,7 @@ Deprecated. Use C instead. #define OPpITER_REVERSED 4 /* for (reverse ...) */ /* Private for OP_CONST */ +#define OPpCONST_NOVER 2 /* no 6; */ #define OPpCONST_SHORTCIRCUIT 4 /* eg the constant 5 in (5 || foo) */ #define OPpCONST_STRICT 8 /* bearword subject to strict 'subs' */ #define OPpCONST_ENTERED 16 /* Has been entered as symbol. */ diff --git a/pp_ctl.c b/pp_ctl.c index 2493fa8..0e31353 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -3102,9 +3102,16 @@ PP(pp_require) sv = new_version(sv); if (!sv_derived_from(PL_patchlevel, "version")) (void *)upg_version(PL_patchlevel); - if ( vcmp(sv,PL_patchlevel) > 0 ) - DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped", - vnormal(sv), vnormal(PL_patchlevel)); + if (cUNOP->op_first->op_private & OPpCONST_NOVER) { + if ( vcmp(sv,PL_patchlevel) < 0 ) + DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped", + vnormal(sv), vnormal(PL_patchlevel)); + } + else { + if ( vcmp(sv,PL_patchlevel) > 0 ) + DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped", + vnormal(sv), vnormal(PL_patchlevel)); + } RETPUSHYES; } diff --git a/proto.h b/proto.h index dc9fc21..437d904 100644 --- a/proto.h +++ b/proto.h @@ -3451,6 +3451,10 @@ STATIC HV * S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); +STATIC char * S_tokenize_use(pTHX_ int, char*) + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_2); + STATIC SV* S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, const char *type) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); diff --git a/t/comp/use.t b/t/comp/use.t index fb378b2..eec6fe0 100755 --- a/t/comp/use.t +++ b/t/comp/use.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; } -print "1..28\n"; +print "1..31\n"; my $i = 1; eval "use 5.000"; # implicit semicolon @@ -22,6 +22,25 @@ if ($@) { } print "ok ",$i++,"\n"; +eval "use 6.000;"; +unless ($@ =~ /Perl v6\.0\.0 required--this is only \Q$^V\E, stopped/) { + print "not "; +} +print "ok ",$i++,"\n"; + +eval "no 6.000;"; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + +eval "no 5.000;"; +unless ($@ =~ /Perls since v5\.0\.0 too modern--this is \Q$^V\E, stopped/) { + print "not "; +} +print "ok ",$i++,"\n"; + eval sprintf "use %.6f;", $]; if ($@) { print STDERR $@,"\n"; diff --git a/toke.c b/toke.c index 1b16de0..cb2c589 100644 --- a/toke.c +++ b/toke.c @@ -2293,6 +2293,30 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) return gv_stashpv(pkgname, FALSE); } +STATIC char * +S_tokenize_use(int is_use, char *s) { + if (PL_expect != XSTATE) + yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression", + is_use ? "use" : "no")); + s = skipspace(s); + if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { + s = force_version(s, TRUE); + if (*s == ';' || (s = skipspace(s), *s == ';')) { + PL_nextval[PL_nexttoke].opval = Nullop; + force_next(WORD); + } + else if (*s == 'v') { + s = force_word(s,WORD,FALSE,TRUE,FALSE); + s = force_version(s, FALSE); + } + } + else { + s = force_word(s,WORD,FALSE,TRUE,FALSE); + s = force_version(s, FALSE); + } + yylval.ival = is_use; + return s; +} #ifdef DEBUGGING static const char* const exp_name[] = { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK", @@ -4871,11 +4895,7 @@ Perl_yylex(pTHX) Eop(OP_SNE); case KEY_no: - if (PL_expect != XSTATE) - yyerror("\"no\" not allowed in expression"); - s = force_word(s,WORD,FALSE,TRUE,FALSE); - s = force_version(s, FALSE); - yylval.ival = 0; + s = tokenize_use(0, s); OPERATOR(USE); case KEY_not: @@ -5407,25 +5427,7 @@ Perl_yylex(pTHX) LOP(OP_UNSHIFT,XTERM); case KEY_use: - if (PL_expect != XSTATE) - yyerror("\"use\" not allowed in expression"); - s = skipspace(s); - if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { - s = force_version(s, TRUE); - if (*s == ';' || (s = skipspace(s), *s == ';')) { - PL_nextval[PL_nexttoke].opval = Nullop; - force_next(WORD); - } - else if (*s == 'v') { - s = force_word(s,WORD,FALSE,TRUE,FALSE); - s = force_version(s, FALSE); - } - } - else { - s = force_word(s,WORD,FALSE,TRUE,FALSE); - s = force_version(s, FALSE); - } - yylval.ival = 1; + s = tokenize_use(1, s); OPERATOR(USE); case KEY_values: