From: Florian Ragwitz <rafl@debian.org>
Date: Sat, 1 May 2010 22:15:19 +0000 (+0200)
Subject: Allow requiring a version with is_class_loaded, load_class and load_first_existing_class.
X-Git-Tag: 1.01~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4154c4d09ba34bd81ce12dde18012bba797a353c;p=gitmo%2FClass-MOP.git

Allow requiring a version with is_class_loaded, load_class and load_first_existing_class.
---

diff --git a/Changes b/Changes
index 1cebd7e..cb2de1a 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,10 @@
 Revision history for Perl extension Class-MOP.
 
+  [NEW FEATURES]
+
+  * is_class_loaded, load_class and load_first_existing_class now allow
+    specifying a minimum required version (Florian Ragwitz).
+
   [BUG FIXES]
 
   * The __INSTANCE__ parameter to Class::MOP::Class::new_object now enforces
diff --git a/Makefile.PL b/Makefile.PL
index 38b00dc..11d6db8 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -18,6 +18,7 @@ if ( -d '.git' || $ENV{MAINTAINER_MODE} ) {
 }
 
 requires 'Carp';
+requires 'Data::OptList';
 requires 'Devel::GlobalDestruction';
 requires 'MRO::Compat'  => '0.05';
 requires 'Scalar::Util' => '1.18';
diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index 561b3bf..2391519 100644
--- a/lib/Class/MOP.pm
+++ b/lib/Class/MOP.pm
@@ -10,6 +10,7 @@ use MRO::Compat;
 
 use Carp          'confess';
 use Scalar::Util  'weaken', 'reftype', 'blessed';
+use Data::OptList;
 use Try::Tiny;
 
 use Class::MOP::Mixin::AttributeCore;
@@ -78,12 +79,13 @@ sub _class_to_pmfile {
 }
 
 sub load_first_existing_class {
-    my @classes = @_
+    my $classes = Data::OptList::mkopt(\@_)
       or return;
 
-    foreach my $class (@classes) {
-        unless ( _is_valid_class_name($class) ) {
-            my $display = defined($class) ? $class : 'undef';
+    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)";
         }
     }
@@ -91,34 +93,48 @@ sub load_first_existing_class {
     my $found;
     my %exceptions;
 
-    for my $class (@classes) {
-        my $file = _class_to_pmfile($class);
+    for my $class (@{ $classes }) {
+        my ($name, $options) = @{ $class };
 
-        return $class if is_class_loaded($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);
+        }
 
-        return $class if try {
+        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 ($class) because: $_";
+                confess "Couldn't load class ($name) because: $_";
             }
 
             return;
         };
     }
 
-    if ( @classes > 1 ) {
-        confess "Can't locate any of @classes in \@INC (\@INC contains: @INC).";
+    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]) . " in \@INC (\@INC contains: @INC).";
+        confess "Can't locate " . _class_to_pmfile($classes->[0]->[0]) . " in \@INC (\@INC contains: @INC).";
     }
 }
 
 sub load_class {
-    load_first_existing_class($_[0]);
+    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
@@ -914,7 +930,7 @@ Note that these are all called as B<functions, not methods>.
 
 =over 4
 
-=item B<Class::MOP::load_class($class_name)>
+=item B<Class::MOP::load_class($class_name, \%options?)>
 
 This will load the specified C<$class_name>, if it is not already
 loaded (as reported by C<is_class_loaded>). This function can be used
@@ -923,9 +939,15 @@ 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 recognised is C<-version>, which will ensure
+that the loaded class has at least the required version.
+
+See also L</Class Loading Options>.
+
 For historical reasons, this function explicitly returns a true value.
 
-=item B<Class::MOP::is_class_loaded($class_name)>
+=item B<Class::MOP::is_class_loaded($class_name, \%options?)>
 
 Returns a boolean indicating whether or not C<$class_name> has been
 loaded.
@@ -937,6 +959,12 @@ positives. In particular, loading any of the core L<IO> modules will
 cause most of the rest of the core L<IO> modules to falsely report
 having been loaded, due to the way the base L<IO> module works.
 
+You can pass a hash reference with options as second argument. The
+only option currently recognised is C<-version>, which will ensure
+that the loaded class has at least the required version.
+
+See also L</Class Loading Options>.
+
 =item B<Class::MOP::get_code_info($code)>
 
 This function returns two values, the name of the package the C<$code>
@@ -963,6 +991,8 @@ variable which is not package specific.
 
 =item B<Class::MOP::load_first_existing_class(@class_names)>
 
+=item B<Class::MOP::load_first_existing_class($classA, \%optionsA?, $classB, ...)>
+
 B<NOTE: DO NOT USE THIS FUNCTION, IT IS FOR INTERNAL USE ONLY!>
 
 Given a list of class names, this function will attempt to load each
@@ -971,6 +1001,13 @@ one in turn.
 If it finds a class it can load, it will return that class' name.  If
 none of the classes can be loaded, it will throw an exception.
 
+Additionally, you can pass a hash reference with options after each
+class name. Currently, only C<-version> is recognised and will ensure
+that the loaded class has at least the required version. If the class
+version is not sufficient, an exception will be raised.
+
+See also L</Class Loading Options>.
+
 =back
 
 =head2 Metaclass cache functions
@@ -1024,6 +1061,17 @@ This will remove the metaclass stored in the C<$name> key.
 
 =back
 
+=head2 Class Loading Options
+
+=over 4
+
+=item -version
+
+Can be used to pass a minimum required version that will be checked
+against the class version after it was loaded.
+
+=back
+
 =head1 SEE ALSO
 
 =head2 Books
diff --git a/mop.c b/mop.c
index 0d170be..a5ded4f 100644
--- a/mop.c
+++ b/mop.c
@@ -194,7 +194,8 @@ static struct {
     DECLARE_KEY_WITH_VALUE(package_cache_flag, "_package_cache_flag"),
     DECLARE_KEY(methods),
     DECLARE_KEY(VERSION),
-    DECLARE_KEY(ISA)
+    DECLARE_KEY(ISA),
+    DECLARE_KEY_WITH_VALUE(_version, "-version")
 };
 
 SV *
diff --git a/mop.h b/mop.h
index 288c8ad..e30510d 100644
--- a/mop.h
+++ b/mop.h
@@ -27,6 +27,7 @@ typedef enum {
     KEY_methods,
     KEY_VERSION,
     KEY_ISA,
+    KEY__version,
     key_last,
 } mop_prehashed_key_t;
 
diff --git a/t/083_load_class.t b/t/083_load_class.t
index 67553be..b2a41ef 100644
--- a/t/083_load_class.t
+++ b/t/083_load_class.t
@@ -145,4 +145,36 @@ throws_ok {
         'an @ISA with members does mean a class is loaded' );
 }
 
+{
+    {
+        package Class::WithVersion;
+        our $VERSION = 23;
+    };
+
+    ok( Class::MOP::is_class_loaded('Class::WithVersion', { -version => 13 }),
+        'version 23 satisfies version requirement 13' );
+
+    ok( !Class::MOP::is_class_loaded('Class::WithVersion', { -version => 42 }),
+        'version 23 does not satisfy version requirement 42' );
+
+    throws_ok {
+        Class::MOP::load_first_existing_class('Affe', 'Tiger', 'Class::WithVersion' => { -version => 42 });
+    } qr/Class::WithVersion version 42 required--this is only version 23/,
+    'load_first_existing_class gives correct exception on old version';
+
+    lives_ok {
+        Class::MOP::load_first_existing_class('Affe', 'Tiger', 'Class::WithVersion' => { -version => 13 });
+    } 'loading class with required version with load_first_existing_class';
+
+    throws_ok {
+        Class::MOP::load_class('Class::WithVersion' => { -version => 42 });
+    } qr/Class::WithVersion version 42 required--this is only version 23/,
+    'load_class gives correct exception on old version';
+
+    lives_ok {
+        Class::MOP::load_class('Class::WithVersion' => { -version => 13 });
+    } 'loading class with required version with load_class';
+
+}
+
 done_testing;
diff --git a/xs/MOP.xs b/xs/MOP.xs
index 9ca0970..fd4bf1d 100644
--- a/xs/MOP.xs
+++ b/xs/MOP.xs
@@ -11,6 +11,35 @@ find_method (const char *key, STRLEN keylen, SV *val, void *ud)
     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;
+}
+
 EXTERN_C XS(boot_Class__MOP__Mixin__HasMethods);
 EXTERN_C XS(boot_Class__MOP__Package);
 EXTERN_C XS(boot_Class__MOP__Mixin__AttributeCore);
@@ -45,8 +74,9 @@ get_code_info(coderef)
         }
 
 void
-is_class_loaded(klass)
+is_class_loaded(klass, options=NULL)
     SV *klass
+    HV *options
     PREINIT:
         HV *stash;
         bool found_method = FALSE;
@@ -61,6 +91,15 @@ is_class_loaded(klass)
             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;