Commit | Line | Data |
---|---|---|
271e5113 JB |
1 | package Module::Loaded; |
2 | ||
3 | use strict; | |
4 | use Carp qw[carp]; | |
5 | ||
6 | BEGIN { use base 'Exporter'; | |
7 | use vars qw[@EXPORT $VERSION]; | |
8 | ||
9 | $VERSION = '0.01'; | |
10 | @EXPORT = qw[mark_as_loaded mark_as_unloaded is_loaded]; | |
11 | } | |
12 | ||
13 | =head1 NAME | |
14 | ||
15 | Module::Loaded - mark modules as loaded or unloaded | |
16 | ||
17 | =head1 SYNOPSIS | |
18 | ||
19 | use Module::Loaded; | |
20 | ||
21 | $bool = mark_as_loaded('Foo'); # Foo.pm is now marked as loaded | |
22 | $loc = is_loaded('Foo'); # location of Foo.pm set to the | |
23 | # loaders location | |
24 | eval "require 'Foo'"; # is now a no-op | |
25 | ||
26 | $bool = mark_as_unloaded('Foo'); # Foo.pm no longer marked as loaded | |
27 | eval "require 'Foo'"; # Will try to find Foo.pm in @INC | |
28 | ||
29 | =head1 DESCRIPTION | |
30 | ||
31 | When testing applications, often you find yourself needing to provide | |
32 | functionality in your test environment that would usually be provided | |
33 | by external modules. Rather than munging the C<%INC> by hand to mark | |
34 | these external modules as loaded, so they are not attempted to be loaded | |
35 | by perl, this module offers you a very simple way to mark modules as | |
36 | loaded and/or unloaded. | |
37 | ||
38 | =head1 FUNCTIONS | |
39 | ||
40 | =head2 $bool = mark_as_loaded( PACKAGE ); | |
41 | ||
42 | Marks the package as loaded to perl. C<PACKAGE> can be a bareword or | |
43 | string. | |
44 | ||
45 | If the module is already loaded, C<mark_as_loaded> will carp about | |
46 | this and tell you from where the C<PACKAGE> has been loaded already. | |
47 | ||
48 | =cut | |
49 | ||
50 | sub mark_as_loaded (*) { | |
51 | my $pm = shift; | |
52 | my $file = __PACKAGE__->_pm_to_file( $pm ) or return; | |
53 | my $who = [caller]->[1]; | |
54 | ||
55 | my $where = is_loaded( $pm ); | |
56 | if ( defined $where ) { | |
57 | carp "'$pm' already marked as loaded ('$where')"; | |
58 | ||
59 | } else { | |
60 | $INC{$file} = $who; | |
61 | } | |
62 | ||
63 | return 1; | |
64 | } | |
65 | ||
66 | =head2 $bool = mark_as_unloaded( PACKAGE ); | |
67 | ||
68 | Marks the package as unloaded to perl, which is the exact opposite | |
69 | of C<mark_as_loaded>. C<PACKAGE> can be a bareword or string. | |
70 | ||
71 | If the module is already unloaded, C<mark_as_unloaded> will carp about | |
72 | this and tell you the C<PACKAGE> has been unloaded already. | |
73 | ||
74 | =cut | |
75 | ||
76 | sub mark_as_unloaded (*) { | |
77 | my $pm = shift; | |
78 | my $file = __PACKAGE__->_pm_to_file( $pm ) or return; | |
79 | ||
80 | unless( defined is_loaded( $pm ) ) { | |
81 | carp "'$pm' already marked as unloaded"; | |
82 | ||
83 | } else { | |
84 | delete $INC{ $file }; | |
85 | } | |
86 | ||
87 | return 1; | |
88 | } | |
89 | ||
90 | =head2 $loc = is_loaded( PACKAGE ); | |
91 | ||
92 | C<is_loaded> tells you if C<PACKAGE> has been marked as loaded yet. | |
93 | C<PACKAGE> can be a bareword or string. | |
94 | ||
95 | It returns falls if C<PACKAGE> has not been loaded yet and the location | |
96 | from where it is said to be loaded on success. | |
97 | ||
98 | =cut | |
99 | ||
100 | sub is_loaded (*) { | |
101 | my $pm = shift; | |
102 | my $file = __PACKAGE__->_pm_to_file( $pm ) or return; | |
103 | ||
104 | return $INC{$file} if exists $INC{$file}; | |
105 | ||
106 | return; | |
107 | } | |
108 | ||
109 | ||
110 | sub _pm_to_file { | |
111 | my $pkg = shift; | |
112 | my $pm = shift or return; | |
113 | ||
114 | my $file = join '/', split '::', $pm; | |
115 | $file .= '.pm'; | |
116 | ||
117 | return $file; | |
118 | } | |
119 | ||
120 | =head1 AUTHOR | |
121 | ||
122 | This module by | |
123 | Jos Boumans E<lt>kane@cpan.orgE<gt>. | |
124 | ||
125 | =head1 COPYRIGHT | |
126 | ||
127 | This module is | |
128 | copyright (c) 2004-2005 Jos Boumans E<lt>kane@cpan.orgE<gt>. | |
129 | All rights reserved. | |
130 | ||
131 | This library is free software; | |
132 | you may redistribute and/or modify it under the same | |
133 | terms as Perl itself. | |
134 | ||
135 | =cut | |
136 | ||
137 | # Local variables: | |
138 | # c-indentation-style: bsd | |
139 | # c-basic-offset: 4 | |
140 | # indent-tabs-mode: nil | |
141 | # End: | |
142 | # vim: expandtab shiftwidth=4: | |
143 | ||
144 | 1; |