t/op/lop.t See if logical operators work
t/op/magic.t See if magic variables work
t/op/method.t See if method calls work
+t/op/method2entersub.t See if methods-to-entersubs works
t/op/misc.t See if miscellaneous bugs have been fixed
t/op/mkdir.t See if mkdir works
t/op/my.t See if lexical scoping works
s |void |cv_dump |CV *cv
s |CV* |cv_clone2 |CV *proto|CV *outside
s |bool |scalar_mod_type|OP *o|I32 type
+s |OP * |method_2entersub|OP *o|OP *o2|OP *svop
s |OP * |my_kid |OP *o|OP *attrs
s |OP * |dup_attrlist |OP *o
s |void |apply_attrs |HV *stash|SV *target|OP *attrs
my(%hash) = %$hash;
my(%pack, $dir, $warn_permissions);
- my($packlist) = ExtUtils::Packlist->new();
+ my($packlist) = ExtUtils::Packlist->new(undef);
# -w doesn't work reliably on FAT dirs
$warn_permissions++ if $^O eq 'MSWin32';
local(*DIR);
=cut
-sub rel2abs($;$;) {
+sub rel2abs($$;$;) {
my ($self,$path,$base ) = @_;
if ( ! $self->file_name_is_absolute( $path ) ) {
=cut
-sub rel2abs($;$;) {
+sub rel2abs($$;$;) {
my ($self,$path,$base ) = @_;
# Clean up $path
=cut
-sub rel2abs($;$;) {
+sub rel2abs($$;$;) {
my $self = shift ;
return vmspath(File::Spec::Unix::rel2abs( $self, @_ ))
if ( join( '', @_ ) =~ m{/} ) ;
=cut
-sub rel2abs($;$;) {
+sub rel2abs($$;$;) {
my ($self,$path,$base ) = @_;
if ( ! $self->file_name_is_absolute( $path ) ) {
my $fields_base;
my $pkg = caller(0);
+ my @attrs;
+ my $isa = \@{"$pkg\::ISA"};
+
foreach my $base (@_) {
+ if ($base =~ /^[-+]/) { #attribute
+ push @attrs, $base;
+ next;
+ }
next if $pkg->isa($base);
- push @{"$pkg\::ISA"}, $base;
+ push @$isa, $base;
unless (exists ${"$base\::"}{VERSION}) {
eval "require $base";
# Only ignore "Can't locate" errors from our eval require.
# Other fatal errors (syntax etc) must be reported.
- die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
+ die if $@ && $@ !~ /^Can\'t locate .*? at \(eval /;
unless (%{"$base\::"}) {
require Carp;
Carp::croak("Base class package \"$base\" is empty.\n",
require fields;
fields::inherit($pkg, $fields_base);
}
+ if (@attrs) {
+ require attributes;
+ attributes::->import($pkg, $isa, @attrs);
+ }
}
1;
return ck_fun(o);
}
+STATIC OP *
+S_method_2entersub(pTHX_ OP *o, OP *o2, OP *svop)
+{
+ GV *gv;
+ SV *method = ((SVOP*)svop)->op_sv;
+ char *methname;
+ STRLEN methlen;
+ HV *stash;
+ OP *mop;
+
+ if (svop->op_type == OP_METHOD_NAMED) {
+ methname = SvPV(method, methlen);
+ }
+ else {
+ return Nullop;
+ }
+
+ if (o2->op_type == OP_CONST) {
+ STRLEN len;
+ char *package = SvPV(((SVOP*)o2)->op_sv, len);
+ stash = gv_stashpvn(package, len, FALSE);
+ }
+ else if (o2->op_type == OP_PADSV) {
+ /* my Dog $spot = shift; $spot->bark */
+ SV *sv = *av_fetch(PL_comppad_name, o2->op_targ, FALSE);
+ if (sv && SvOBJECT(sv)) {
+ stash = SvSTASH(sv);
+ }
+ else {
+ return Nullop;
+ }
+ }
+ else {
+ return Nullop;
+ }
+
+ /* -1 so cache globs are not created */
+ /* XXX: support SUPER:: and UNIVERSAL, but not AUTOLOAD */
+ if (!(stash && (gv = gv_fetchmeth(stash, methname, methlen, -1)) &&
+ isGV(gv))) {
+ return Nullop;
+ }
+
+ /* XXX: check entire @ISA tree for readonly-ness ? */
+ if (GvSTASH(CvGV(GvCV(gv))) != stash) {
+ GV **gvp, *isagv;
+ AV *av;
+ gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
+ av = (gvp && (isagv = *gvp) && isagv != (GV*)&PL_sv_undef) ?
+ GvAV(isagv) : Nullav;
+
+ if (isagv && av && !SvREADONLY((SV*)av)) {
+ return Nullop; /* @ISA is not frozen */
+ }
+
+ gv = CvGV(GvCV(gv)); /* point to the real gv */
+ }
+
+ if (o2->op_type == OP_CONST) {
+ /* remove bareword-ness of class name */
+ o2->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
+ }
+
+ for (mop = o2; mop->op_sibling->op_sibling; mop = mop->op_sibling) ;
+
+ op_free(mop->op_sibling); /* loose OP_METHOD_NAMED */
+ mop->op_sibling = scalar(newUNOP(OP_RV2CV, 0,
+ newGVOP(OP_GV, 0, gv)));
+
+ ((cUNOPo->op_first->op_sibling)
+ ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first->op_sibling = o2;
+
+ return ck_subr(o);
+}
+
OP *
Perl_ck_subr(pTHX_ OP *o)
{
}
}
else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
- if (o2->op_type == OP_CONST)
+ if ((PL_hints & HINT_CT_MRESOLVE) && /* use base qw(... +readonly) */
+ (o2->op_type == OP_CONST || o2->op_type == OP_PADSV)) {
+ OP *nop;
+ if ((nop = method_2entersub(o, o2, cvop))) {
+ return nop;
+ }
+ }
+ if (o2->op_type == OP_CONST) {
o2->op_private &= ~OPpCONST_STRICT;
+ }
else if (o2->op_type == OP_LIST) {
OP *o = ((UNOP*)o2)->op_first->op_sibling;
if (o && o->op_type == OP_CONST)
#define HINT_NEW_STRING 0x00008000
#define HINT_NEW_RE 0x00010000
#define HINT_LOCALIZE_HH 0x00020000 /* %^H needs to be copied */
+#define HINT_CT_MRESOLVE 0x00040000 /* resolve methods at compile time */
#define HINT_RE_TAINT 0x00100000
#define HINT_RE_EVAL 0x00200000
--- /dev/null
+#!./perl
+
+BEGIN {
+ package BaseClass; #forward package declaration for base.pm
+
+ chdir 't' if -d 't';
+ unshift @INC, '../lib' if -d '../lib';
+}
+
+{
+ package BaseClass;
+
+ sub method {
+ }
+}
+
+{
+ package Class;
+ use base qw(BaseClass +readonly);
+
+ sub mtest {
+ Class->method;
+
+ my Class $obj = bless {};
+
+ $obj->method;
+ }
+
+}
+
+{
+ package Class2;
+ use base qw(BaseClass);
+
+ sub mtest {
+ Class2->method;
+
+ my Class2 $obj = bless {};
+
+ $obj->method;
+ }
+}
+
+use Test;
+
+plan tests => 2;
+
+use B ();
+
+sub cv_root {
+ B::svref_2object(shift)->ROOT;
+}
+
+sub method_in_tree {
+ my $op = shift;
+ if ($$op && ($op->flags & B::OPf_KIDS)) {
+ for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
+ return 1 if $kid->ppaddr =~ /method/i;
+ return 1 if method_in_tree($kid);
+ }
+ }
+ return 0;
+}
+
+ok ! method_in_tree(cv_root(\&Class::mtest));
+ok method_in_tree(cv_root(\&Class2::mtest));
for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
name = SvPV(attr, len);
- if ((negated = (*name == '-'))) {
+ if ((negated = (*name == '-')) || (*name == '+')) {
name++;
len--;
}
}
break;
}
+ case SVt_IV:
+ case SVt_NV:
+ case SVt_PV:
+ case SVt_PVIV:
+ case SVt_PVNV:
+ case SVt_PVAV:
+ case SVt_PVHV:
+ switch ((int)len) {
+ case 8:
+ switch (*name) {
+ case 'r':
+ if (strEQ(name, "readonly")) {
+ if (negated)
+ SvREADONLY_off(sv);
+ else
+ SvREADONLY_on(sv);
+ if (SvTYPE(sv) == SVt_PVAV && SvMAGIC(sv)
+ && mg_find(sv, 'I')) { /* @ISA */
+ if (negated)
+ PL_hints &= ~HINT_CT_MRESOLVE;
+ else
+ PL_hints |= HINT_CT_MRESOLVE;
+ }
+ continue;
+ }
+ break;
+ }
+ }
break;
default:
/* nothing, yet */
projects / platform / upstream / perl.git / commitdiff