From: Dave Rolsky Date: Mon, 1 Aug 2011 02:03:58 +0000 (-0500) Subject: Deprecate CMOP::{load_class, is_class_loaded, load_first_existing_class} X-Git-Tag: 2.0300~87 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2f41724d3e3b450e2b73c3971e7a89e35e1bbb70;p=gitmo%2FMoose.git Deprecate CMOP::{load_class, is_class_loaded, load_first_existing_class} --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 81f76b6..54bbd37 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -9,6 +9,7 @@ use 5.008; use MRO::Compat; use Carp 'confess'; +use Class::Load (); use Scalar::Util 'weaken', 'isweak', 'reftype', 'blessed'; use Data::OptList; use Try::Tiny; @@ -66,89 +67,25 @@ XSLoader::load( # because I don't yet see a good reason to do so. } -sub _class_to_pmfile { - my $class = shift; - - my $file = $class . '.pm'; - $file =~ s{::}{/}g; - - return $file; +sub load_class { + Class::MOP::Deprecated::deprecated( + 'The Class::MOP::load_class subroutine is deprecated.' + . ' Please use Class::Load instead.' ); + goto &Class::Load::load_class; } sub load_first_existing_class { - my $classes = Data::OptList::mkopt(\@_) - or return; - - foreach my $class (@{ $classes }) { - my $name = $class->[0]; - unless ( _is_valid_class_name($name) ) { - my $display = defined($name) ? $name : 'undef'; - confess "Invalid class name ($display)"; - } - } - - my $found; - my %exceptions; - - for my $class (@{ $classes }) { - my ($name, $options) = @{ $class }; - - if ($options) { - return $name if is_class_loaded($name, $options); - if (is_class_loaded($name)) { - # we already know it's loaded and too old, but we call - # ->VERSION anyway to generate the exception for us - $name->VERSION($options->{-version}); - } - } - else { - return $name if is_class_loaded($name); - } - - my $file = _class_to_pmfile($name); - return $name if try { - local $SIG{__DIE__}; - require $file; - $name->VERSION($options->{-version}) - if defined $options->{-version}; - return 1; - } - catch { - unless (/^Can't locate \Q$file\E in \@INC/) { - confess "Couldn't load class ($name) because: $_"; - } - - return; - }; - } - - if ( @{ $classes } > 1 ) { - my @list = map { $_->[0] } @{ $classes }; - confess "Can't locate any of @list in \@INC (\@INC contains: @INC)."; - } else { - confess "Can't locate " . _class_to_pmfile($classes->[0]->[0]) . " in \@INC (\@INC contains: @INC)."; - } -} - -sub load_class { - load_first_existing_class($_[0], ref $_[1] ? $_[1] : ()); - - # This is done to avoid breaking code which checked the return value. Said - # code is dumb. The return value was _always_ true, since it dies on - # failure! - return 1; + Class::MOP::Deprecated::deprecated( + 'The Class::MOP::load_first_existing_class subroutine is deprecated.' + . ' Please use Class::Load instead.' ); + goto &Class::Load::load_first_existing_class; } -sub _is_valid_class_name { - my $class = shift; - - return 0 if ref($class); - return 0 unless defined($class); - return 0 unless length($class); - - return 1 if $class =~ /^\w+(?:::\w+)*$/; - - return 0; +sub is_class_loaded { + Class::MOP::Deprecated::deprecated( + 'The Class::MOP::is_class_loaded subroutine is deprecated.' + . ' Please use Class::Load instead.' ); + goto &Class::Load::is_class_loaded; } sub _definition_context { @@ -989,37 +926,6 @@ Note that these are all called as B. =over 4 -=item B - -This will load the specified C<$class_name>, if it is not already -loaded (as reported by C). This function can be used -in place of tricks like C or using C -unconditionally. - -If the module cannot be loaded, an exception is thrown. - -You can pass a hash reference with options as second argument. The -only option currently recognized is C<-version>, which will ensure -that the loaded class has at least the required version. - -For historical reasons, this function explicitly returns a true value. - -=item B - -Returns a boolean indicating whether or not C<$class_name> has been -loaded. - -This does a basic check of the symbol table to try and determine as -best it can if the C<$class_name> is loaded, it is probably correct -about 99% of the time, but it can be fooled into reporting false -positives. In particular, loading any of the core L modules will -cause most of the rest of the core L modules to falsely report -having been loaded, due to the way the base L module works. - -You can pass a hash reference with options as second argument. The -only option currently recognized is C<-version>, which will ensure -that the loaded class has at least the required version. - =item B This function returns two values, the name of the package the C<$code> diff --git a/lib/Class/MOP/Deprecated.pm b/lib/Class/MOP/Deprecated.pm index a2a34e0..1ae1f61 100644 --- a/lib/Class/MOP/Deprecated.pm +++ b/lib/Class/MOP/Deprecated.pm @@ -4,6 +4,9 @@ use strict; use warnings; use Package::DeprecationManager -deprecations => { + 'Class::MOP::load_class' => '2.0200', + 'Class::MOP::load_first_existing_class' => '2.0200', + 'Class::MOP::is_class_loaded' => '2.0200', }; 1; diff --git a/lib/Class/MOP/Module.pm b/lib/Class/MOP/Module.pm index 077cd38..5cc151a 100644 --- a/lib/Class/MOP/Module.pm +++ b/lib/Class/MOP/Module.pm @@ -74,7 +74,7 @@ sub _instantiate_module { my($self, $version, $authority) = @_; my $package_name = $self->name; - Class::MOP::_is_valid_class_name($package_name) + _is_valid_class_name($package_name) || confess "creation of $package_name failed: invalid package name"; $self->add_package_symbol('$VERSION' => $version) @@ -85,6 +85,18 @@ sub _instantiate_module { return; } +sub _is_valid_class_name { + my $class = shift; + + return 0 if ref($class); + return 0 unless defined($class); + return 0 unless length($class); + + return 1 if $class =~ /^\w+(?:::\w+)*$/; + + return 0; +} + 1; # ABSTRACT: Module Meta Object diff --git a/t/cmop/self_introspection.t b/t/cmop/self_introspection.t index c735f74..dd16b19 100644 --- a/t/cmop/self_introspection.t +++ b/t/cmop/self_introspection.t @@ -44,6 +44,8 @@ my @class_mop_package_methods = qw( my @class_mop_module_methods = qw( _new + _is_valid_class_name + _instantiate_module version authority identifier create diff --git a/xs/MOP.xs b/xs/MOP.xs index 398ea4e..0bf05dc 100644 --- a/xs/MOP.xs +++ b/xs/MOP.xs @@ -1,45 +1,5 @@ #include "mop.h" -static bool -find_method (const char *key, STRLEN keylen, SV *val, void *ud) -{ - bool *found_method = (bool *)ud; - PERL_UNUSED_ARG(key); - PERL_UNUSED_ARG(keylen); - PERL_UNUSED_ARG(val); - *found_method = TRUE; - return FALSE; -} - -static bool -check_version (SV *klass, SV *required_version) -{ - bool ret = 0; - - dSP; - ENTER; - SAVETMPS; - PUSHMARK(SP); - EXTEND(SP, 2); - PUSHs(klass); - PUSHs(required_version); - PUTBACK; - - call_method("VERSION", G_DISCARD|G_VOID|G_EVAL); - - SPAGAIN; - - if (!SvTRUE(ERRSV)) { - ret = 1; - } - - PUTBACK; - FREETMPS; - LEAVE; - - return ret; -} - MODULE = Class::MOP PACKAGE = Class::MOP PROTOTYPES: DISABLE @@ -59,53 +19,3 @@ get_code_info(coderef) mPUSHs(newSVpv(pkg, 0)); mPUSHs(newSVpv(name, 0)); } - -void -is_class_loaded(klass, options=NULL) - SV *klass - HV *options - PREINIT: - HV *stash; - bool found_method = FALSE; - PPCODE: - SvGETMAGIC(klass); - if (!(SvPOKp(klass) && SvCUR(klass))) { /* XXX: SvPOK does not work with magical scalars */ - XSRETURN_NO; - } - - stash = gv_stashsv(klass, 0); - if (!stash) { - XSRETURN_NO; - } - - if (options && hv_exists_ent(options, KEY_FOR(_version), HASH_FOR(_version))) { - HE *required_version = hv_fetch_ent(options, KEY_FOR(_version), 0, HASH_FOR(_version)); - if (check_version (klass, HeVAL(required_version))) { - XSRETURN_YES; - } - - XSRETURN_NO; - } - - if (hv_exists_ent (stash, KEY_FOR(VERSION), HASH_FOR(VERSION))) { - HE *version = hv_fetch_ent(stash, KEY_FOR(VERSION), 0, HASH_FOR(VERSION)); - SV *version_sv; - if (version && HeVAL(version) && (version_sv = GvSV(HeVAL(version))) - && SvOK(version_sv)) { - XSRETURN_YES; - } - } - - if (hv_exists_ent (stash, KEY_FOR(ISA), HASH_FOR(ISA))) { - HE *isa = hv_fetch_ent(stash, KEY_FOR(ISA), 0, HASH_FOR(ISA)); - if (isa && HeVAL(isa) && GvAV(HeVAL(isa)) && av_len(GvAV(HeVAL(isa))) != -1) { - XSRETURN_YES; - } - } - - mop_get_package_symbols(stash, TYPE_FILTER_CODE, find_method, &found_method); - if (found_method) { - XSRETURN_YES; - } - - XSRETURN_NO;