From: Jos I. Boumans Date: Sun, 13 Aug 2006 16:22:09 +0000 (+0200) Subject: Add Module::Loaded to the core X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=271e5113b6f272563b3b2a7eff9bd6917f8315c5;p=p5sagit%2Fp5-mst-13.2.git Add Module::Loaded to the core Message-ID: <9310.80.127.35.68.1155478929.squirrel@webmail.xs4all.nl> p4raw-id: //depot/perl@28706 --- diff --git a/MANIFEST b/MANIFEST index 757c1b1..e01eb22 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2050,6 +2050,8 @@ lib/Module/CoreList/bin/corelist Module::CoreList 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 diff --git a/lib/Module/Loaded.pm b/lib/Module/Loaded.pm new file mode 100644 index 0000000..6ab2676 --- /dev/null +++ b/lib/Module/Loaded.pm @@ -0,0 +1,144 @@ +package Module::Loaded; + +use strict; +use Carp qw[carp]; + +BEGIN { use base 'Exporter'; + use vars qw[@EXPORT $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 can be a bareword or +string. + +If the module is already loaded, C will carp about +this and tell you from where the C 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. C can be a bareword or string. + +If the module is already unloaded, C will carp about +this and tell you the C 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 tells you if C has been marked as loaded yet. +C can be a bareword or string. + +It returns falls if C 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 Ekane@cpan.orgE. + +=head1 COPYRIGHT + +This module is +copyright (c) 2004-2005 Jos Boumans Ekane@cpan.orgE. +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; diff --git a/lib/Module/Loaded/t/01_Module-Loaded.t b/lib/Module/Loaded/t/01_Module-Loaded.t new file mode 100644 index 0000000..f4c1a46 --- /dev/null +++ b/lib/Module/Loaded/t/01_Module-Loaded.t @@ -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" ); +}