develooper Front page | perl.perl5.porters | Postings from August 2001

Re: [PATCH] new tests for the coderef-in-@INC

Thread Previous
From:
Michael G Schwern
Date:
August 27, 2001 16:47
Subject:
Re: [PATCH] new tests for the coderef-in-@INC
Message ID:
20010827194730.C12582@blackrider
On Tue, Aug 28, 2001 at 12:02:46AM +0100, Nicholas Clark wrote:
> On Mon, Aug 27, 2001 at 10:36:27PM +0200, Rafael Garcia-Suarez wrote:
> > I wrote some basic tests for the coderef-in-@INC feature.
> > I placed them in a new file t/op/inccode.t (I also patched MANIFEST).

Not to be a broken record here, but could we switch this to
Test::More?  It's not critical functionality.


--- /dev/null	Mon Aug 27 19:46:54 2001
+++ /usr/local/src/perl-current/t/op/inccode.t	Mon Aug 27 19:46:54 2001
@@ -0,0 +1,110 @@
+#!./perl -wT
+
+# Tests for the coderef-in-@INC feature
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+use Config;
+
+BEGIN {
+    require Test::More;
+
+    # This test relies on perlio, but the feature being tested does not.
+    # The dependency should eventually be purged and use something like
+    # Tie::Handle instead.
+    if( $Config{useperlio} ) {
+        Test::More->import(tests => 21);
+    }
+    else {
+        Test::More->import('skip_all');
+    }
+}
+
+sub fooinc {
+    my ($self, $filename) = @_;
+    if (substr($filename,0,3) eq 'Foo') {
+        open my $fh, '<', \("package ".substr($filename,0,-3)."; 1;");
+        return $fh;
+    }
+    else {
+        return undef;
+    }
+}
+
+push @INC, \&fooinc;
+
+ok( !eval { require Bar; 1 },      'Trying non-magic package' );
+
+ok( eval { require Foo; 1 },       'require() magic via code ref'  ); 
+ok( exists $INC{'Foo.pm'},         '  %INC sees it' );
+
+ok( eval "use Foo1; 1;",           'use()' );  
+ok( exists $INC{'Foo1.pm'},        '  %INC sees it' );
+
+ok( eval { do 'Foo2.pl'; 1 },      'do()' ); 
+ok( exists $INC{'Foo2.pl'},        '  %INC sees it' );
+
+pop @INC;
+
+
+sub fooinc2 {
+    my ($self, $filename) = @_;
+    if (substr($filename, 0, length($self->[1])) eq $self->[1]) {
+        open my $fh, '<', \("package ".substr($filename,0,-3)."; 1;");
+        return $fh;
+    }
+    else {
+        return undef;
+    }
+}
+
+push @INC, [ \&fooinc2, 'Bar' ];
+
+ok( eval { require Foo; 1; },     'Originally loaded packages preserved' );
+ok( !eval { require Foo3; 1; },   'Original magic INC purged' );
+
+ok( eval { require Bar; 1 },      'require() magic via array ref' );
+ok( exists $INC{'Bar.pm'},        '  %INC sees it' );
+
+ok( eval "use Bar1; 1;",          'use()' );
+ok( exists $INC{'Bar1.pm'},       '  %INC sees it' );
+
+ok( eval { do 'Bar2.pl'; 1 },     'do()' );
+ok( exists $INC{'Bar2.pl'},       '  %INC sees it' );
+
+pop @INC;
+
+sub FooLoader::INC {
+    my ($self, $filename) = @_;
+    if (substr($filename,0,4) eq 'Quux') {
+        open my $fh, '<', \("package ".substr($filename,0,-3)."; 1;");
+        return $fh;
+    }
+    else {
+        return undef;
+    }
+}
+
+push @INC, bless( {}, 'FooLoader' );
+
+ok( eval { require Quux; 1 },      'require() magic via hash object' );
+ok( exists $INC{'Quux.pm'},        '  %INC sees it' );
+
+pop @INC;
+
+push @INC, bless( [], 'FooLoader' );
+
+ok( eval { require Quux1; 1 },     'require() magic via array object' );
+ok( exists $INC{'Quux1.pm'},       '  %INC sees it' );
+
+pop @INC;
+
+push @INC, bless( \(my $x = 1), 'FooLoader' );
+
+ok( eval { require Quux2; 1 },     'require() magic via scalar object' );
+ok( exists $INC{'Quux2.pm'},       '  %INC sees it' );
+
+pop @INC;
--- /usr/local/src/perl-current/MANIFEST~	Mon Aug 27 19:36:48 2001
+++ /usr/local/src/perl-current/MANIFEST	Mon Aug 27 19:36:48 2001
@@ -2034,6 +2034,7 @@
 t/op/gv.t			See if typeglobs work
 t/op/hashwarn.t			See if warnings for bad hash assignments work
 t/op/inc.t			See if inc/dec of integers near 32 bit limit work
+t/op/inccode.t                  See if refs work in @INC
 t/op/index.t			See if index works
 t/op/int.t			See if int works
 t/op/join.t			See if join works


-- 

Michael G. Schwern   <schwern@pobox.com>    http://www.pobox.com/~schwern/
Perl6 Quality Assurance     <perl-qa@perl.org>	     Kwalitee Is Job One
Manipulation is its own reward
	http://www.goats.com/archive/010430.html

Thread Previous


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About