From: Yuval Kogman Date: Mon, 11 Aug 2008 00:33:28 +0000 (+0000) Subject: XS version of get_all_package_symbols X-Git-Tag: 0_64_01~42 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=15273f3c0305b96e49dd34030b995623bcd670c5;p=gitmo%2FClass-MOP.git XS version of get_all_package_symbols --- diff --git a/MOP.xs b/MOP.xs index f1071dd..b7dfd03 100644 --- a/MOP.xs +++ b/MOP.xs @@ -2,6 +2,8 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" + +#define NEED_sv_2pv_nolen #include "ppport.h" /* @@ -45,3 +47,107 @@ get_code_info(coderef) PUSHs(newSVpvn(name, strlen(name))); } + +MODULE = Class::MOP PACKAGE = Class::MOP::Package + +void +get_all_package_symbols(package, ...) + SV *package + PROTOTYPE: $;$ + PREINIT: + HV *stash; + SV *type_filter = NULL; + PPCODE: + + switch ( GIMME_V ) { + case G_VOID: return; break; + case G_SCALAR: ST(0) = &PL_sv_undef; return; break; + } + + if ( items > 1 ) type_filter = ST(1); + + PUTBACK; + + ENTER; + SAVETMPS; + PUSHMARK(SP); + XPUSHs(package); + PUTBACK; + call_method("name", 0); + SPAGAIN; + stash = gv_stashsv(POPs, 0); + FREETMPS; + LEAVE; + + PUTBACK; + + if ( stash ) { + register HE *entry; + + (void)hv_iterinit(stash); + + if ( type_filter && SvPOK(type_filter) ) { + const char *const type = SvPV_nolen(type_filter); + + + while ((entry = hv_iternext(stash))) { + SV *const gv = hv_iterval(stash, entry); + SV *const key = hv_iterkeysv(entry); + SV *sv; + char *package = HvNAME(stash); + STRLEN pkglen = strlen(package); + char *fq; + STRLEN fqlen; + + SPAGAIN; + + switch( SvTYPE(gv) ) { + case SVt_PVGV: + switch (*type) { + case 'C': sv = (SV *)GvCVu(gv); break; /* CODE */ + case 'A': sv = (SV *)GvAV(gv); break; /* ARRAY */ + case 'I': sv = (SV *)GvIO(gv); break; /* IO */ + case 'H': sv = (SV *)GvHV(gv); break; /* HASH */ + case 'S': sv = (SV *)GvSV(gv); break; /* SCALAR */ + default: + croak("Unknown type %s\n", type); + } + break; + case SVt_RV: + /* BAH! constants are horrible */ + fqlen = pkglen + SvCUR(key) + 3; + fq = (char *)alloca(fqlen); + snprintf(fq, fqlen, "%s::%s", package, SvPV_nolen(key)); + sv = get_cv(fq, 0); + break; + default: + continue; + } + + if ( sv ) { + SPAGAIN; + EXTEND(SP, 2); + PUSHs(key); + PUSHs(newRV_noinc(sv)); + PUTBACK; + } + } + } else { + EXTEND(SP, HvKEYS(stash) * 2); + + while ((entry = hv_iternext(stash))) { + SV *sv; + SPAGAIN; + sv = hv_iterkeysv(entry); + SPAGAIN; + PUSHs(sv); + PUTBACK; + sv = hv_iterval(stash, entry); + SPAGAIN; + PUSHs(sv); + PUTBACK; + } + } + + } + diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 6c82116..0c0550f 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -9,12 +9,6 @@ use MRO::Compat; use Carp 'confess'; use Scalar::Util 'weaken'; -use Class::MOP::Class; -use Class::MOP::Attribute; -use Class::MOP::Method; - -use Class::MOP::Immutable; - BEGIN { our $VERSION = '0.65'; @@ -63,16 +57,20 @@ BEGIN { # now try our best to get as much # of the XS loaded as possible { - local $@; - eval { - require XSLoader; - XSLoader::load( 'Class::MOP', $VERSION ); + my $e = do { + local $@; + eval { + require XSLoader; + __PACKAGE__->XSLoader::load($VERSION); + }; + $@; }; - die $@ if $@ && $@ !~ /object version|loadable object/; + + die $e if $e && $e !~ /object version|loadable object/; # okay, so the XS failed to load, so # use the pure perl one instead. - *get_code_info = $_PP_get_code_info if $@; + *get_code_info = $_PP_get_code_info if $e; } # get it from MRO::Compat @@ -92,6 +90,12 @@ BEGIN { } } +use Class::MOP::Class; +use Class::MOP::Attribute; +use Class::MOP::Method; + +use Class::MOP::Immutable; + { # Metaclasses are singletons, so we cache them here. # there is no need to worry about destruction though diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm index 9324418..2cff662 100644 --- a/lib/Class/MOP/Package.pm +++ b/lib/Class/MOP/Package.pm @@ -236,29 +236,37 @@ sub list_all_package_symbols { } } -sub get_all_package_symbols { - my ($self, $type_filter) = @_; - my $namespace = $self->namespace; - return %$namespace unless defined $type_filter; - - # for some reason this nasty impl is orders of magnitude aster than a clean version - if ( $type_filter eq 'CODE' ) { - my $pkg; - no strict 'refs'; - return map { - (ref($namespace->{$_}) - ? ( $_ => \&{$pkg ||= $self->name . "::$_"} ) - : ( *{$namespace->{$_}}{CODE} - ? ( $_ => *{$namespace->{$_}}{$type_filter} ) - : ())) - } keys %$namespace; - } else { - return map { - $_ => *{$namespace->{$_}}{$type_filter} - } grep { - !ref($namespace->{$_}) && *{$namespace->{$_}}{$type_filter} - } keys %$namespace; +unless ( defined &get_all_package_symbols ) { + local $@; + eval q/ + sub get_all_package_symbols { + my ($self, $type_filter) = @_; + my $namespace = $self->namespace; + + return %$namespace unless defined $type_filter; + + # for some reason this nasty impl is orders of magnitude aster than a clean version + if ( $type_filter eq 'CODE' ) { + my $pkg; + no strict 'refs'; + return map { + (ref($namespace->{$_}) + ? ( $_ => \&{$pkg ||= $self->name . "::$_"} ) + : ( *{$namespace->{$_}}{CODE} + ? ( $_ => *{$namespace->{$_}}{$type_filter} ) + : ())) + } keys %$namespace; + } else { + return map { + $_ => *{$namespace->{$_}}{$type_filter} + } grep { + !ref($namespace->{$_}) && *{$namespace->{$_}}{$type_filter} + } keys %$namespace; + } } + + 1; + / || warn $@; } 1; diff --git a/t/080_meta_package.t b/t/080_meta_package.t index 3e54a35..2f4271c 100644 --- a/t/080_meta_package.t +++ b/t/080_meta_package.t @@ -233,7 +233,6 @@ is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for { my %syms = Foo->meta->get_all_package_symbols; - is_deeply( [ sort keys %syms ], [ sort Foo->meta->list_all_package_symbols ],