Change 28706 by [EMAIL PROTECTED] on 2006/08/14 10:10:07
Subject: [PATCH] Add Module::Loaded to the core
From: [EMAIL PROTECTED]
Date: Sun, 13 Aug 2006 16:22:09 +0200 (CEST)
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/MANIFEST#1437 edit
... //depot/perl/lib/Module/Loaded.pm#1 add
... //depot/perl/lib/Module/Loaded/t/01_Module-Loaded.t#1 add
Differences ...
==== //depot/perl/MANIFEST#1437 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#1436~28703~ 2006-08-14 02:09:40.000000000 -0700
+++ perl/MANIFEST 2006-08-14 03:10:07.000000000 -0700
@@ -2050,6 +2050,8 @@
lib/Module/CoreList.pm Module::CoreList
lib/Module/CoreList/t/corelist.t Module::CoreList
lib/Module/CoreList/t/find_modules.t Module::CoreList
+lib/Module/Loaded.pm Module::Loaded
+lib/Module/Loaded/t/01_Module-Loaded.t Module::Loaded tests
lib/Module/Load.pm Module::Load
lib/Module/Load/t/01_Module-Load.t Module::Load tests
lib/Module/Load/t/to_load/config_file Module::Load tests
==== //depot/perl/lib/Module/Loaded.pm#1 (text) ====
Index: perl/lib/Module/Loaded.pm
--- /dev/null 2006-07-26 09:27:38.482901250 -0700
+++ perl/lib/Module/Loaded.pm 2006-08-14 03:10:07.000000000 -0700
@@ -0,0 +1,144 @@
+package Module::Loaded;
+
+use strict;
+use Carp qw[carp];
+
+BEGIN { use base 'Exporter';
+ use vars [EMAIL PROTECTED] $VERSION];
+
+ $VERSION = '0.01';
+ @EXPORT = qw[mark_as_loaded mark_as_unloaded is_loaded];
+}
+
+=head1 NAME
+
+Module::Loaded - mark modules as loaded or unloaded
+
+=head1 SYNOPSIS
+
+ use Module::Loaded;
+
+ $bool = mark_as_loaded('Foo'); # Foo.pm is now marked as loaded
+ $loc = is_loaded('Foo'); # location of Foo.pm set to the
+ # loaders location
+ eval "require 'Foo'"; # is now a no-op
+
+ $bool = mark_as_unloaded('Foo'); # Foo.pm no longer marked as loaded
+ eval "require 'Foo'"; # Will try to find Foo.pm in @INC
+
+=head1 DESCRIPTION
+
+When testing applications, often you find yourself needing to provide
+functionality in your test environment that would usually be provided
+by external modules. Rather than munging the C<%INC> by hand to mark
+these external modules as loaded, so they are not attempted to be loaded
+by perl, this module offers you a very simple way to mark modules as
+loaded and/or unloaded.
+
+=head1 FUNCTIONS
+
+=head2 $bool = mark_as_loaded( PACKAGE );
+
+Marks the package as loaded to perl. C<PACKAGE> can be a bareword or
+string.
+
+If the module is already loaded, C<mark_as_loaded> will carp about
+this and tell you from where the C<PACKAGE> has been loaded already.
+
+=cut
+
+sub mark_as_loaded (*) {
+ my $pm = shift;
+ my $file = __PACKAGE__->_pm_to_file( $pm ) or return;
+ my $who = [caller]->[1];
+
+ my $where = is_loaded( $pm );
+ if ( defined $where ) {
+ carp "'$pm' already marked as loaded ('$where')";
+
+ } else {
+ $INC{$file} = $who;
+ }
+
+ return 1;
+}
+
+=head2 $bool = mark_as_unloaded( PACKAGE );
+
+Marks the package as unloaded to perl, which is the exact opposite
+of C<mark_as_loaded>. C<PACKAGE> can be a bareword or string.
+
+If the module is already unloaded, C<mark_as_unloaded> will carp about
+this and tell you the C<PACKAGE> has been unloaded already.
+
+=cut
+
+sub mark_as_unloaded (*) {
+ my $pm = shift;
+ my $file = __PACKAGE__->_pm_to_file( $pm ) or return;
+
+ unless( defined is_loaded( $pm ) ) {
+ carp "'$pm' already marked as unloaded";
+
+ } else {
+ delete $INC{ $file };
+ }
+
+ return 1;
+}
+
+=head2 $loc = is_loaded( PACKAGE );
+
+C<is_loaded> tells you if C<PACKAGE> has been marked as loaded yet.
+C<PACKAGE> can be a bareword or string.
+
+It returns falls if C<PACKAGE> has not been loaded yet and the location
+from where it is said to be loaded on success.
+
+=cut
+
+sub is_loaded (*) {
+ my $pm = shift;
+ my $file = __PACKAGE__->_pm_to_file( $pm ) or return;
+
+ return $INC{$file} if exists $INC{$file};
+
+ return;
+}
+
+
+sub _pm_to_file {
+ my $pkg = shift;
+ my $pm = shift or return;
+
+ my $file = join '/', split '::', $pm;
+ $file .= '.pm';
+
+ return $file;
+}
+
+=head1 AUTHOR
+
+This module by
+Jos Boumans E<lt>[EMAIL PROTECTED]<gt>.
+
+=head1 COPYRIGHT
+
+This module is
+copyright (c) 2004-2005 Jos Boumans E<lt>[EMAIL PROTECTED]<gt>.
+All rights reserved.
+
+This library is free software;
+you may redistribute and/or modify it under the same
+terms as Perl itself.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
+1;
==== //depot/perl/lib/Module/Loaded/t/01_Module-Loaded.t#1 (text) ====
Index: perl/lib/Module/Loaded/t/01_Module-Loaded.t
--- /dev/null 2006-07-26 09:27:38.482901250 -0700
+++ perl/lib/Module/Loaded/t/01_Module-Loaded.t 2006-08-14 03:10:07.000000000
-0700
@@ -0,0 +1,47 @@
+use strict;
+use Test::More 'no_plan';
+
+my $Class = 'Module::Loaded';
+my @Funcs = qw[mark_as_loaded mark_as_unloaded is_loaded];
+my $Mod = 'Foo::Bar'.$$;
+my $Strict = 'strict';
+
+### load the thing
+{ use_ok( $Class );
+ can_ok( $Class, @Funcs );
+}
+
+{ ok( !is_loaded($Mod), "$Mod not loaded yet" );
+ ok( mark_as_loaded($Mod), " $Mod now marked as loaded" );
+ is( is_loaded($Mod), $0, " $Mod is loaded from $0" );
+
+ my $rv = eval "require $Mod; 1";
+ ok( $rv, "$Mod required" );
+ ok( !$@, " require did not die" );
+}
+
+### unload again
+{ ok( mark_as_unloaded($Mod), "$Mod now marked as unloaded" );
+ ok( !is_loaded($Mod), " $Mod now longer loaded" );
+
+ my $rv = eval "require $Mod; 1";
+ ok( !$rv, "$Mod require failed" );
+ ok( $@, " require died" );
+ like( $@, qr/locate/, " with expected error" );
+}
+
+### check for an already loaded module
+{ my $where = is_loaded( $Strict );
+ ok( $where, "$Strict loaded" );
+ ok( mark_as_unloaded( $Strict ),
+ " $Strict unloaded" );
+
+ ### redefining subs, quell warnings
+ { local $SIG{__WARN__} = sub {};
+ my $rv = eval "require $Strict; 1";
+ ok( $rv, "$Strict loaded again" );
+ }
+
+ is( is_loaded( $Strict ), $where,
+ " $Strict is loaded" );
+}
End of Patch.
