Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package TRELoad; |
2 | ||
3 | use 5.008; | |
4 | use strict; | |
5 | use warnings; | |
6 | use Carp; | |
7 | use File::Spec; | |
8 | require Exporter; | |
9 | ||
10 | our @ISA = qw(Exporter); | |
11 | ||
12 | # Items to export into callers namespace by default. Note: do not export | |
13 | # names by default without a very good reason. Use EXPORT_OK instead. | |
14 | # Do not simply export all your public functions/methods/constants. | |
15 | ||
16 | # This allows declaration use TRELoad ':all'; | |
17 | # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK | |
18 | # will save memory. | |
19 | our %EXPORT_TAGS = ( 'all' => [ qw( | |
20 | ||
21 | ) ] ); | |
22 | ||
23 | our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); | |
24 | ||
25 | our @EXPORT = qw( | |
26 | ||
27 | ); | |
28 | ||
29 | our $VERSION = '1.02'; | |
30 | our $Id = 'TRELoad: '; | |
31 | our $Verbose = 0 unless defined $Verbose; | |
32 | ||
33 | our $ModuleBase = '/import/bw/tools/release/perlmod'; | |
34 | $ModuleBase = $ENV{MODULE_BASE} if exists $ENV{MODULE_BASE}; | |
35 | ||
36 | our $PerlVers = '5.8.0'; | |
37 | our $TRE_ENTRY = $ENV{TRE_ENTRY}; | |
38 | ||
39 | our %Loaded; | |
40 | ||
41 | ||
42 | ######################################################################### | |
43 | ||
44 | sub import { | |
45 | my @args = @_; | |
46 | ||
47 | my @caller = caller; | |
48 | my $callpkg = $caller[0]; | |
49 | if($callpkg ne 'main') { | |
50 | $TRE_ENTRY .= '/' unless $TRE_ENTRY =~ m|/$|; | |
51 | $TRE_ENTRY .= $callpkg; | |
52 | ||
53 | } | |
54 | ||
55 | print "$Id CALLING from '$callpkg' with entry '$TRE_ENTRY'\n" if $Verbose; | |
56 | ||
57 | my @modules = parse_import_list(@_); | |
58 | foreach my $importmod (@modules) { | |
59 | my $module = $importmod->{module}; | |
60 | my $importlist = exists $importmod->{importlist} ? | |
61 | $importmod->{importlist} : [':DEFAULT']; | |
62 | my $tre_entry = $importmod->{tre_entry}; | |
63 | ||
64 | if(@$importlist and $importlist->[0] =~ /^\!/) { | |
65 | # First element is a deletion, so prepend :DEFAULT | |
66 | unshift @$importlist, ':DEFAULT'; | |
67 | } | |
68 | ||
69 | my $module_dir = get_module_dir($module, $tre_entry); | |
70 | my $libdir = File::Spec->catdir($module_dir, 'lib', 'site_perl', | |
71 | $PerlVers); | |
72 | unshift @INC, $libdir; | |
73 | # Perhaps we'd need to add this to PERL5LIB to make C libraries work. | |
74 | # Add that if we need to. | |
75 | ||
76 | print "$Id Searching for module $module in $libdir.\n" if $Verbose; | |
77 | ||
78 | require "$module.pm"; | |
79 | ||
80 | local ($_); | |
81 | my @symbol_list = map { get_tag_contents($module, $_) } @$importlist; | |
82 | @symbol_list = negate_symbols(@symbol_list); | |
83 | ||
84 | if(@symbol_list) { | |
85 | ||
86 | my $caller = caller; | |
87 | print "$Id Exporting symbols from $module into $caller: @symbol_list \n" | |
88 | if $Verbose; | |
89 | $Exporter::Verbose = 1; | |
90 | ||
91 | ||
92 | $module->export_to_level(1, $module, @symbol_list); | |
93 | } | |
94 | ||
95 | } | |
96 | ||
97 | ||
98 | } | |
99 | ||
100 | ######################################################################### | |
101 | ||
102 | sub get_module_dir { | |
103 | my $module = shift; | |
104 | my $tre_entry = shift; | |
105 | ||
106 | my $command = "configsrch $module $tre_entry"; | |
107 | my $cmd_output = `$command`; | |
108 | if($?) { | |
109 | my $status = $? >> 8; | |
110 | my $signal = $? & 127; | |
111 | my $core = $? & 128; | |
112 | ||
113 | if($status) { | |
114 | confess "Execution of \"$command\" failed with status $status.\n"; | |
115 | } | |
116 | if($signal) { | |
117 | my $corestring = $core ? '' : ' (core dumped)'; | |
118 | confess "Command \"$command\" died with signal $signal$corestring.\n"; | |
119 | } | |
120 | # should never get here | |
121 | die "$command failed\n"; | |
122 | } | |
123 | my @words = split ' ', $cmd_output; | |
124 | my $version = shift @words; | |
125 | ||
126 | if($version !~ /\d+.\d+/) { | |
127 | croak "Could not find TRE version for module $module.\n"; | |
128 | } | |
129 | ||
130 | if(exists $Loaded{$module}) { | |
131 | my $loaded_vers = $Loaded{$module}; | |
132 | if($version ne $loaded_vers) { | |
133 | warn << "EOT"; | |
134 | $Id WARNING: Previously loaded $module version $loaded_vers, but now TRE_ENTRY | |
135 | $tre_entry | |
136 | specfies version $version. You cannot load two different | |
137 | versions of the same module in a script, so going with version $loaded_vers. | |
138 | This may lead to unexpected behavior. | |
139 | EOT | |
140 | } | |
141 | } else { | |
142 | $Loaded{$module} = $version; | |
143 | } | |
144 | ||
145 | my $module_dir = File::Spec->catdir($ModuleBase, $module, $version); | |
146 | croak "Model directory \"$module_dir\" does not exist.\n" | |
147 | unless -d $module_dir; | |
148 | ||
149 | # Obviously, this will need to do the right thing once TRE is in place. | |
150 | return $module_dir; | |
151 | } | |
152 | ||
153 | ######################################################################### | |
154 | ||
155 | sub negate_symbols { | |
156 | my @symbols_in = @_; | |
157 | ||
158 | local ($_); | |
159 | my %hash = map {$_, 1} @symbols_in; | |
160 | foreach my $key (keys %hash) { | |
161 | if($key =~ /^\!(.*)/) { | |
162 | delete $hash{$key}; | |
163 | delete $hash{$1}; | |
164 | } | |
165 | } | |
166 | return keys %hash; | |
167 | } | |
168 | ||
169 | ######################################################################### | |
170 | ||
171 | sub parse_import_list { | |
172 | my @import_list = @_; | |
173 | ||
174 | my $curpkg = shift @import_list; | |
175 | ||
176 | ||
177 | print "$Id Parsing import list...\n" if $Verbose; | |
178 | ||
179 | my @parsed; | |
180 | my $i = 0; | |
181 | my $start_len = $#import_list + 1; | |
182 | while($i < $start_len) { | |
183 | my $entry = {}; | |
184 | $entry->{module} = $import_list[$i++]; | |
185 | print "$Id module $entry->{module}\n" if $Verbose; | |
186 | if(ref $import_list[$i]) { | |
187 | if(ref $import_list[$i] eq 'ARRAY') { | |
188 | $entry->{importlist} = $import_list[$i++]; | |
189 | print "$Id import @{$entry->{importlist}}\n" if $Verbose; | |
190 | } elsif(ref $import_list[$i] eq 'HASH') { | |
191 | $entry->{hash} = $import_list[$i++]; | |
192 | if(exists $entry->{hash}{import}) { | |
193 | $entry->{importlist} = $entry->{hash}{import}; | |
194 | print "$Id import @{$entry->{importlist}}\n" if $Verbose; | |
195 | } | |
196 | if(exists $entry->{hash}{tre_entry}) { | |
197 | $entry->{tre_entry} = $entry->{hash}{tre_entry}; | |
198 | print "$Id treentry $entry->{tre_entry}\n" if $Verbose; | |
199 | ||
200 | } | |
201 | } | |
202 | } | |
203 | $entry->{tre_entry} = $TRE_ENTRY unless exists $entry->{tre_entry}; | |
204 | push @parsed, $entry; | |
205 | } | |
206 | ||
207 | print "$Id Done parsing import list.\n" if $Verbose; | |
208 | ||
209 | return @parsed; | |
210 | } | |
211 | ||
212 | ######################################################################### | |
213 | ||
214 | sub get_tag_contents { | |
215 | my $pkg = shift; | |
216 | my $tag = shift; | |
217 | ||
218 | my $is_negated = 0; | |
219 | if($tag =~ s/^\!//) { | |
220 | $is_negated = 1; | |
221 | } | |
222 | ||
223 | print "$Id Expanding module=$pkg tag=$tag\n" if $Verbose; | |
224 | if(defined $tag and $tag !~ /^:/) { | |
225 | $tag = "!$tag" if $is_negated; | |
226 | print "$Id $tag\n" if $Verbose; | |
227 | return $tag; | |
228 | } else { | |
229 | $tag =~ s/^://; | |
230 | } | |
231 | ||
232 | my %tags; | |
233 | my @export; | |
234 | { | |
235 | # add a block where I can break all the rules | |
236 | no strict 'refs'; | |
237 | %tags = %{"$pkg" . "::EXPORT_TAGS" }; | |
238 | @export = @{"$pkg" . "::EXPORT" }; | |
239 | } | |
240 | ||
241 | if(exists $tags{$tag}) { | |
242 | @{$tags{$tag}} = map { "!$_" } @{$tags{$tag}} if $is_negated; | |
243 | print "$Id @{$tags{$tag}}\n" if $Verbose; | |
244 | return @{$tags{$tag}}; | |
245 | } elsif($tag eq 'DEFAULT') { | |
246 | print "$Id @export\n" if $Verbose; | |
247 | @export = map { "!$_" } @export if $is_negated; | |
248 | return @export; | |
249 | } else { | |
250 | confess "No such tag $tag in package $pkg\n"; | |
251 | } | |
252 | } | |
253 | ||
254 | ######################################################################### | |
255 | ||
256 | ||
257 | ||
258 | 1; | |
259 | __END__ | |
260 | ||
261 | =head1 NAME | |
262 | ||
263 | TRELoad - Perl extension for loading modules under TRE control | |
264 | ||
265 | =head1 SYNOPSIS | |
266 | ||
267 | use TRELoad 'Foo' => ['abc', 'def'], | |
268 | 'Bar', | |
269 | 'Baz' => [ '$somevar' ]; | |
270 | ||
271 | which is the same as | |
272 | ||
273 | use Foo 'abc', 'def'; | |
274 | use Bar; | |
275 | use Baz '$somevar'; | |
276 | ||
277 | ||
278 | =head1 ABSTRACT | |
279 | ||
280 | This module adds a layer of indirection between modules under | |
281 | TRE control and the scripts/modules that use them. It allows | |
282 | the TRE-controlled modules to be intstalled unmodified. TRELoad | |
283 | emulates the Exporter, so client modules are able to import | |
284 | symbols from the TRE modules. | |
285 | ||
286 | =head1 DESCRIPTION | |
287 | ||
288 | The TRELoad module exists as a layer of indirection between perl | |
289 | modules under TRE control and scripts/modules that use them. The | |
290 | basic idea is that we want to use TRE mechanisms to find perl modules, | |
291 | rather than the include mechanisms built into perl. That said, we | |
292 | want to support arbitrary perl modules and fully export the perl | |
293 | exporter. | |
294 | ||
295 | =head2 USING A TRE MODULE | |
296 | ||
297 | The entire usage for the TRELoad module is the 'use' line. The syntax is: | |
298 | ||
299 | use TRELoad <list>; | |
300 | ||
301 | In its simplest (and most common) usage, the list contains the names | |
302 | of modules to import. For instance, the TRE equivalent of: | |
303 | ||
304 | use Foo; | |
305 | use Bar; | |
306 | ||
307 | is | |
308 | ||
309 | use TRELoad 'Foo', 'Bar'; | |
310 | ||
311 | With this syntax (i.e., no import list explicitly defined for the | |
312 | modules), you import symbols in the default export list, just as you | |
313 | would with the bare 'use' directives. | |
314 | ||
315 | A normal use directive can also contain a list of symbols to import, | |
316 | which override the default export list of the module. For instance: | |
317 | ||
318 | use Foo 'abc', 'def'; | |
319 | ||
320 | will load the Foo module and import the symbols 'abc' and 'def' | |
321 | instead of the default export list. The TRELoad equivalent is to use | |
322 | an array reference immediately following the module name in the | |
323 | TRELoad argument list. The above TRELoad equivalent would be: | |
324 | ||
325 | use TRELoad 'Foo' => ['abc', 'def']; | |
326 | ||
327 | The perl exporter also supports tags (pseudo-symbols starting with | |
328 | ':'), which are names for lists of symbols. There is a predefined tag | |
329 | called ':DEFAULT' which contains all of the symbols in the default | |
330 | export list. These tags are also supported by TRELoad. Therefore, | |
331 | the following statement: | |
332 | ||
333 | use Foo ':DEFAULT', 'abc'; | |
334 | ||
335 | has the TRE equivalent of: | |
336 | ||
337 | use TRELoad 'Foo' => [':DEFAULT', 'abc'] | |
338 | ||
339 | which means to import all symbols in the default export list, plus the | |
340 | symbol 'abc'. | |
341 | ||
342 | TRELoad also supports negations, see 'perldoc Exporter' for more | |
343 | details. As a more complicated example, consider: | |
344 | ||
345 | use Foo 'abc'; | |
346 | use Bar ':DEFAULT', 'aaa', '!bbb', '!:ccc'; | |
347 | use Baz; | |
348 | ||
349 | This means, load Foo, Bar, and Baz. Import the symbol 'abc' from Foo, | |
350 | import all the default symbols from Bar, plus 'aaa', minus the symbol | |
351 | 'bbb' and minus all symbols in the tag ':ccc'. Finally, import the | |
352 | symbols in the default export list from Baz. | |
353 | ||
354 | The TRE equivalent is: | |
355 | ||
356 | use TRELoad 'Foo' => [ 'abc' ], | |
357 | 'Bar' => [ ':DEFAULT', 'aaa', '!bbb', '!:ccc'], | |
358 | 'Baz'; | |
359 | ||
360 | I assume you get the idea. | |
361 | ||
362 | =head2 OVERRIDING TRE_ENTRY | |
363 | ||
364 | The TRELoad module obeys the TRE mechanism of appending tool paths to | |
365 | TRE_ENTRY. It is possible, however, to override the TRE_ENTRY | |
366 | setting. To do this requires a more general syntax. Basically, | |
367 | whereever an array reference can appear in the usage list, you may | |
368 | substitute a hash reference. The legal keys of this hash are 'import' | |
369 | (whose value is an array reference that is treated as an import list) | |
370 | and 'tre_entry' (whose value is intrepreted as a string to use as a | |
371 | value for TRE_ENTRY). | |
372 | ||
373 | For example: | |
374 | ||
375 | use TRELoad 'Foo' => ['abc', 'def']; | |
376 | ||
377 | and | |
378 | ||
379 | use TRELoad 'Foo' => { import => ['abc', 'def'] }; | |
380 | ||
381 | are exactly identical. | |
382 | ||
383 | use TRELoad 'Foo' => { import => ['abc', 'def'], | |
384 | tre_entry => '/SomeTool' }; | |
385 | ||
386 | is the same thing except that it will use the TRE_ENTRY of | |
387 | "/SomeTool". | |
388 | ||
389 | ||
390 | =head2 INSTALLING A MODULE | |
391 | ||
392 | Modules are installed using the normal perl install mechanism. The | |
393 | only TRE-specific step is to override the default install prefix: | |
394 | ||
395 | make clean # if Makefile is already present | |
396 | perl Makefile.PL \ | |
397 | PREFIX=/import/bw/tools/release/perlmod/<module_name>/<version> | |
398 | make | |
399 | make install | |
400 | ||
401 | If it is a new module, you will also need to add a .tver entry for the | |
402 | module name. | |
403 | ||
404 | =head2 EXPORT | |
405 | ||
406 | None. | |
407 | ||
408 | =head2 RESTRICTIONS | |
409 | ||
410 | There are couple of restrictions to be aware of: | |
411 | ||
412 | =over 4 | |
413 | ||
414 | =item | |
415 | ||
416 | You cannot use pattern rules in an import list (i.e., import symbols | |
417 | that begin with '/' or '!/'. There is no reason this couldn't be made | |
418 | to work, but it's a fair amount of work and this feature is almost | |
419 | never used. | |
420 | ||
421 | =item | |
422 | ||
423 | You can only use TRELoad on a top-level module. For instance, if a | |
424 | module Foo contains a Foo.pm with interface code for the underlying | |
425 | modules Foo::Bar and Foo::Baz, you must use a "use TRELoad 'Foo'", | |
426 | since Foo::Bar and Foo::Baz will not be recognized by configsrch. If | |
427 | you need to use those modules directly (which usually is not a good | |
428 | idea), you can do: | |
429 | ||
430 | use TRELoad 'Foo'; | |
431 | use Foo::Bar; | |
432 | use Foo::Baz; | |
433 | ||
434 | The TRELoad line will add the appropriate version of Foo to the | |
435 | include path, so you can just use a regular 'use' for its sub-modules. | |
436 | ||
437 | ||
438 | ||
439 | =item | |
440 | ||
441 | Using a number to specify a minimum version is not supported (as in: | |
442 | "use Foo 3.01;") on the TRELoad 'use' line. You can get the effect, | |
443 | however, by using: | |
444 | ||
445 | use TRELoad 'Foo'; | |
446 | use Foo 3.01; | |
447 | ||
448 | The TRELoad line will add the correct version of Foo to the include | |
449 | path, so the following line will work correctly. | |
450 | ||
451 | =item | |
452 | ||
453 | Use perl-style version numbers for your TRE versions. That is to say, | |
454 | use two decimal places after the '.'. The reason is that perl does a | |
455 | simple ASCII comparison when it compares version numbers, so it | |
456 | believes 1.9 to be more recent than 1.10. TRE does not care, but perl | |
457 | does, so if users want to check the version of the module (see | |
458 | previous bullet), this convention is required. | |
459 | ||
460 | ||
461 | =item | |
462 | ||
463 | You cannot load two different versions of a module in the same script. | |
464 | For instance, suppose you had a module called Abc and another module | |
465 | called Composite, where Composite itself used Abc. If your .tver file | |
466 | consisted of: | |
467 | ||
468 | Abc / 1.01 | |
469 | Abc /Composite 1.02 | |
470 | Composite / 2.01 | |
471 | ||
472 | you would be able to use Abc by itself, and you would get version | |
473 | 1.01. You could use Composite by itself, which would get version 1.02 | |
474 | of Abc. What you cannot do is include Abc by itself AND from within | |
475 | Composite via something like: | |
476 | ||
477 | use TRELoad 'Abc', 'Composite'; | |
478 | ||
479 | This is because it would try to load BOTH versions of 1.01 and 1.02 | |
480 | of Abc in the same interpreter, and the names would conflict. In this | |
481 | case, TRELoad prints a warning message to stderr and uses the first | |
482 | version loaded of the module in question. It is impossible to make | |
483 | this work without modifying the modules themselves, and the major | |
484 | design goal of TRELoad was to enable the TRE use of arbitrary perl | |
485 | modules. | |
486 | ||
487 | =back | |
488 | ||
489 | =head1 SEE ALSO | |
490 | ||
491 | perlmod(1), Exporter(3), | |
492 | ||
493 | =head1 AUTHOR | |
494 | ||
495 | ||
496 | =cut |