ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Perl-LibExtractor/LibExtractor.pm
Revision: 1.12
Committed: Fri Jan 20 00:05:34 2012 UTC (14 years, 7 months ago) by root
Branch: MAIN
Changes since 1.11: +37 -81 lines
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 root 1.1 =head1 NAME
2    
3     Perl::LibExtractor - determine perl library subsets for building distributions
4    
5     =head1 SYNOPSIS
6    
7     use Perl::LibExtractor;
8    
9     =head1 DESCRIPTION
10    
11     The purpose of this module is to determine subsets of your perl library,
12     that is, a set of files needed to satisfy certain dependencies (e.g. of a
13     program).
14    
15     The goal is to extract a part of your perl installation including
16 root 1.2 dependencies. A typical use case for this module would be to find out
17 root 1.1 which files are needed to be build a L<PAR> distribution, to link into
18     an L<App::Staticperl> binary, or to pack with L<Urlader>, to create
19     stand-alone distributions tailormade to run your app.
20    
21     =head1 METHODS
22    
23     To use this module, first call the C<new>-constructor and then as many
24 root 1.5 other methods as you want, to generate a set of files. Then query the set
25     of files and do whatever you want with them.
26 root 1.2
27     The command-line utility F<perl-libextract> can be a convenient
28     alternative to using this module directly, and offers a few extra options,
29     such as to copy out the files into a new directory, strip them and/or
30     manipulate them in other ways.
31 root 1.1
32     =cut
33    
34     package Perl::LibExtractor;
35    
36     our $VERSION = '0.1';
37    
38     use Config;
39 root 1.7 use File::Spec ();
40 root 1.1 use File::Temp ();
41    
42     use common::sense;
43    
44     sub I_SRC () { 0 }
45     sub I_DEP () { 1 }
46    
47     sub croak($) {
48     require Carp;
49     Carp::croak "(Perl::LibExtractor) $_[0]";
50     }
51    
52 root 1.8 my $canonpath = File::Spec->can ("canonpath");
53     my $case_tolerant = File::Spec->case_tolerant;
54 root 1.7
55     sub canonpath($) {
56     local $_ = $canonpath->(File::Spec::, $_[0]);
57     s%\\%/%g;
58 root 1.8 # $_ = lc if $case_tolerant; # we assume perl file name case is always the same
59 root 1.7 $_
60     }
61    
62 root 1.5 =head2 CREATION
63    
64     =over 4
65    
66 root 1.1 =item $extractor = new Perl::LibExtractor [key => value...]
67    
68     Creates a new extractor object. Each extractor object stores some
69     configuration options and a subset of files that can be queried at any
70     time,.
71    
72 root 1.12 Binary executables (such as the perl interpreter) are stored inside
73     F<bin/>, perl scripts are stored under F<script/>, perl library files are
74     stored under F<lib/> and shared libraries are stored under F<dll/>.
75    
76 root 1.1 The following key-value pairs exist, with default values as specified.
77    
78     =over 4
79    
80     =item inc => \@INC without "."
81    
82     An arrayref with paths to perl library directories. The default is
83     C<\@INC>, with F<.> removed.
84    
85     To prepend custom dirs just do this:
86    
87     inc => ["mydir", @INC],
88    
89 root 1.3 =item use_packlist => 1
90 root 1.1
91 root 1.3 Enable (if true) or disable the use of C<.packlist> files. If enabled,
92 root 1.5 then each time a file is traced, the complete distribution that contains
93     it is included (but not traced).
94    
95     If disabled, only shared objects and autoload files will be added.
96 root 1.1
97     =back
98    
99     =cut
100    
101     sub new {
102     my ($class, %kv) = @_;
103    
104     my $self = bless {
105 root 1.12 inc => [grep $_ ne ".", @INC],
106 root 1.3 use_packlist => 1,
107 root 1.1 %kv,
108     set => {},
109     }, $class;
110    
111     my %inc_seen;
112 root 1.4 my @inc = grep !$inc_seen{$_}++ && -d "$_/.", @{ $self->{inc} };
113 root 1.1 $self->{inc} = \@inc;
114    
115     $self->_set_inc;
116    
117     $self
118     }
119    
120 root 1.4 sub _perl_path() {
121     my $secure_perl_path = $Config{perlpath};
122    
123     if ($^O ne 'VMS') {
124     $secure_perl_path .= $Config{_exe}
125     unless $secure_perl_path =~ m/$Config{_exe}$/i;
126     }
127    
128     $secure_perl_path
129     }
130    
131 root 1.8 sub _path2match {
132     my $re = join "|", map "\Q$_", @_;
133    
134     $re = "(?:$re)\\/";
135     $re =~ s%\\[/\\]%[/\\\\]%g; # we support / and \ on all OSes, keep your fingers crossed
136    
137     $case_tolerant
138     ? qr<$re>i
139     : qr<$re>
140     }
141    
142 root 1.11 sub _read_packlist {
143     my ($self, $root, $path) = @_;
144    
145     my $lib = $self->{lib};
146    
147     my @packlist;
148    
149     open my $fh, "<:perlio", "$root/$path"
150     or die "$root/$path: $!";
151    
152     $root = _path2match $root;
153    
154     while (<$fh>) {
155     chomp;
156     s/ .*$//; # newer-style .packlists might contain key=value pairs
157    
158     s/$root// and exists $lib->{$_}
159     or next;
160    
161     push @packlist, canonpath $_;
162     }
163    
164     \@packlist
165     }
166    
167 root 1.1 sub _set_inc {
168     my ($self) = @_;
169    
170 root 1.8 my $matchprefix = _path2match @{ $self->{inc }};
171 root 1.2
172 root 1.1 my %lib;
173 root 1.2 my @packlists;
174 root 1.1
175     # find all files in all libdirs, earlier ones overwrite later ones
176 root 1.2 my @scan = map [$_, ""], @{ $self->{inc} };
177    
178     while (@scan) {
179     my ($root, $dir) = @{ pop @scan };
180    
181     my $pfx = length $dir ? "$dir/" : "";
182    
183     for (do {
184     opendir my $fh, "$root/$dir"
185     or croak "$root/$dir: $!";
186     grep !/^\.\.?$/, readdir $fh
187     }) {
188     if (-d "$root/$dir/$_/.") {
189     $lib{"$pfx$_/"} = "$root/$pfx$_";
190     push @scan, [$root, "$pfx$_"];
191     } elsif ($_ eq ".packlist" && $pfx =~ m%^auto/%) {
192     push @packlists, [$root, $pfx];
193     } elsif (/\.bs$/ && $pfx =~ m%^auto/% && !-s "$root/$dir/$_") {
194     # skip empty .bs files
195     # } elsif (/\.(?:pod|h|html)$/) {
196     # # not interested in those
197     } else {
198     #push @files, $_;
199     $lib{"$pfx$_"} = "$root/$pfx$_";
200 root 1.1 }
201 root 1.2 }
202    
203     #$lib{"$_[1]/"} = [\@dirs, \@files]; # won't work nice with overwrite
204     }
205    
206     my %packlist;
207 root 1.1
208 root 1.2 # need to go forward here
209     for (@packlists) {
210 root 1.11 my $packlist = $self->_read_packlist ($_->[0], "$_->[1]/.packlist");
211 root 1.2
212 root 1.11 $packlist{$_} = $packlist
213     for @$packlist;
214 root 1.1 }
215    
216 root 1.8 $self->{lib} = \%lib;
217     $self->{packlist} = \%packlist;
218 root 1.2 $self->{matchprefix} = $matchprefix;
219 root 1.1 }
220    
221 root 1.5 =back
222    
223     =head2 TRACE/PACKLIST BASED ADDING
224    
225     The following methods add various things to the set of files.
226    
227     Each time a perl file is added, it is scanned by tracing either loading,
228     execution or compiling it, and seeing which other perl modules and
229     libraries have been loaded.
230    
231     For each library file found this way, additional dependencies are added:
232     if packlists are enabled, then all files of the distribution that contains
233     the file will be added. If packlists are disabled, then only shared
234     objects and autoload files for modules will be added.
235    
236     Only files from perl library directories will be added automatically. Any
237     other files (such as manpages or scripts installed in the F<bin>
238     directory) are skipped.
239    
240     If there is an error, such as a module not being found, then this module
241     croaks (as opposed to silently skipping). If you want to add something of
242     which you are not sure it exists, then you can wrap the call into C<eval
243     {}>. In some cases, you can avoid this by executing the code you want
244     to work later using C<add_eval> - see C<add_core_support> for an actual
245     example of this technique.
246    
247     Note that packlists are meant to add files not covered by other
248     mechanisms, such as resource files and other data files loaded directly by
249     a module - they are not meant to add dependencies that are missed because
250     they only happen at runtime.
251    
252     For example, with packlists, when using L<AnyEvent>, then all event loop
253     backends are automatically added as well, but I<not> any event loops
254     (i.e. L<AnyEvent::Impl::POE> is added, but L<POE> itself is not). Without
255     packlists, only the backend that is being used is added (i.e. normally
256     none, as loading AnyEvent does not instantly load any backend).
257    
258     To catch the extra event loop dependencies, you can either initialise
259     AnyEvent so it picks a suitable backend:
260    
261     $extractor->add_eval ("use AnyEvent; AnyEvent::detect");
262    
263     Or you can directly load the backend modules you plan to use:
264    
265     $extractor->add_mod ("AnyEvent::Impl::EV", "AnyEvent::Impl::Perl");
266    
267     An example of a program (or module) that has extra resource files is
268     L<Deliantra::Client> - the normal tracing (without packlist usage) will
269     correctly add all submodules, but miss the fonts and textures. By using
270     the packlist, those files are added correctly.
271    
272     =over 4
273    
274     =cut
275    
276 root 1.1 sub _add {
277     my ($self, $add) = @_;
278    
279     my $lib = $self->{lib};
280     my $path;
281    
282     for (@$add) {
283 root 1.12 $path = "lib/$_";
284 root 1.1
285     $self->{set}{$path} ||= do {
286     my @info;
287    
288     $info[I_SRC] = $lib->{$_}
289     or croak "$_: unable to locate file in perl library";
290    
291 root 1.3 if ($self->{use_packlist} && exists $self->{packlist}{$_}) {
292 root 1.12 $self->{set}{"lib/$_"} ||= [$self->{lib}{$_} or die]
293 root 1.2 for @{ $self->{packlist}{$_} };
294 root 1.3
295     # for (grep /\.pm$/, @{ $self->{packlist}{$_} }) {
296     # s/\.pm$//;
297     # s%/%::%g;
298     # my $pkg = "libextractor" . ++$self->{count};
299     # $self->add_eval ("{ package $pkg; eval 'use $_' }")
300     # unless $self->{_add_do}{$_}++;
301     # }
302     #
303     # $self->{_add_do}{$_}++ or $self->add_eval ("do q\x00$_\x00")
304     # for grep /\.pl$/, @{ $self->{packlist}{$_} };
305    
306 root 1.2 } elsif (/^(.*)\.pm$/) {
307 root 1.1 (my $auto = "auto/$1/") =~ s%::%/%g;
308     $auto =~ m%/([^/]+)/$% or die;
309     my $base = $1;
310    
311     if (exists $lib->{$auto}) {
312     # auto dir exists, scan it for cool stuff
313    
314     # 1. shared object, others are of no interest to us
315     my $so = "$auto$base.$Config{dlext}";
316     if (my $src = $lib->{$so}) {
317 root 1.12 $so = "lib/$so";
318 root 1.1 push @{ $info[I_DEP] }, $so; $self->{set}{$so} = [$src];
319     }
320    
321     # 2. autoloader/autosplit
322     my $ix = "${auto}autosplit.ix";
323     if (my $src = $lib->{$ix}) {
324 root 1.12 $ix = "lib/$ix";
325 root 1.1 push @{ $info[I_DEP] }, $ix; $self->{set}{$ix} = [$src];
326    
327     open my $fh, "<:perlio", $src
328     or croak "$src: $!";
329    
330     my $package;
331    
332     while (<$fh>) {
333     if (/^\s*sub\s+ ([^[:space:];]+) \s* (?:\([^)]*\))? \s*;?\s*$/x) {
334     my $al = "auto/$package/$1.al";
335     my $src = $lib->{$al}
336     or croak "$al: autoload file not found, but should be there.";
337    
338 root 1.12 $al = "lib/$al";
339 root 1.1 push @{ $info[I_DEP] }, $al; $self->{set}{$al} = [$src];
340    
341     } elsif (/^\s*package\s+([^[:space:];]+)\s*;?\s*$/) {
342     ($package = $1) =~ s/::/\//g;
343     } elsif (/^\s*(?:#|1?\s*;?\s*$)/) {
344     # nop
345     } else {
346     warn "WARNING: $src: unparsable line, please report: $_";
347     }
348     }
349     }
350    
351     skip:
352     }
353     }
354    
355     \@info
356     };
357     }
358     }
359    
360     sub _trace {
361     my ($self, $file, $eval) = @_;
362    
363 root 1.3 $self->{trace_begin} .= "\n#line \"$file\" 1\n$eval;\n";
364 root 1.1 }
365    
366     sub _trace_flush {
367     my ($self) = @_;
368    
369 root 1.3 # ->_add might add additional files to trace
370     while (exists $self->{trace_begin} or exists $self->{trace_check}) {
371     my $tmpdir = newdir File::Temp;
372     my $dir = $tmpdir->dirname;
373    
374     open my $fh, ">:perlio", "$dir/eval"
375     or croak "$dir/eval: $!";
376     syswrite $fh,
377     'BEGIN { @INC = (' . (join ", ", map "q\x00$_\x00", @{ $self->{inc} }) . ") }\n"
378     . "BEGIN { chdir q\x00$dir\x00 or die q\x00$dir: \$!\x00 }\n"
379     . 'BEGIN { ' . (delete $self->{trace_begin}) . "}\n"
380     . "CHECK {\n"
381     . 'open STDOUT, ">:raw", "out" or die "out: $!";'
382     . 'print join "\x00", values %INC;'
383     . 'open STDERR, ">stderr";' # suppress "syntax OK" message from perl
384     . "}\n"
385     . (delete $self->{trace_check});
386     close $fh;
387    
388 root 1.4 system _perl_path, "-c", "$dir/eval"
389 root 1.3 and croak "trace failure, check trace process output - caught";
390 root 1.1
391 root 1.3 my @inc = split /\x00/, do {
392     open my $fh, "<:perlio", "$dir/out"
393     or croak "$dir/out: $!";
394     local $/;
395     scalar readline $fh
396     };
397 root 1.1
398 root 1.3 my $matchprefix = $self->{matchprefix};
399 root 1.1
400 root 1.3 # remove the library directory prefix, hope for the best
401     s/$matchprefix//
402     or croak "$_: file outside any library directory"
403     for @inc;
404 root 1.1
405 root 1.3 $self->_add (\@inc);
406     }
407 root 1.1 }
408    
409     =item $extractor->add_mod ($module[, $module...])
410    
411     Adds the given module(s) to the file set - the module name must be specified
412     as in C<use>, i.e. with C<::> as separators and without F<.pm>.
413    
414     The program will be loaded with the default import list, any dependent
415     files, such as the shared object implementing xs functions, or autoload
416     files, will also be added.
417    
418 root 1.5 If you want to use a different import list (for those rare modules wghere
419     import lists trigger different backend modules to be loaded for example),
420     you can use C<add_eval> instead:
421    
422     $extractor->add_eval ("use Module qw(a b c)");
423    
424 root 1.1 Example: add F<Coro.pm> and F<AnyEvent/AIO.pm>, and all relevant files
425     from the distribution they are part of.
426    
427     $extractor->add_mod ("Coro", "AnyEvent::AIO");
428    
429     =cut
430    
431     sub add_mod {
432     my $self = shift;
433    
434 root 1.3 for (@_) {
435     my $pkg = "libextractor" . ++$self->{count};
436     $self->_trace ("use $_", "{ package $pkg; use $_ }")
437     unless $self->{add_mod}{$_}++;
438     }
439 root 1.1 }
440    
441 root 1.12 =item $extractor->add_bin ($name[, $name...])
442 root 1.1
443     Adds the given (perl) program(s) to the file set, that is, a program
444     installed by some perl module, written in perl (an example would be the
445     L<perl-libextract> program that is part of the C<Perl::LibExtractor>
446     distribution).
447    
448 root 1.5 Example: add the deliantra client program installed by the
449 root 1.12 L<Deliantra::Client> module and put it under F<bin/deliantra>.
450 root 1.1
451 root 1.12 $extractor->add_bin ("deliantra");
452 root 1.1
453     =cut
454    
455 root 1.12 sub add_bin {
456 root 1.1 my $self = shift;
457    
458     exe:
459     for my $exe (@_) {
460     for my $dir ($Config{sitebinexp}, $Config{vendorbinexp}, $Config{binexp}) {
461     if (open my $fh, "<:perlio", "$dir/$exe") {
462 root 1.12 if (-f $fh) {
463     my $file = do { local $/; readline $fh };
464 root 1.1
465 root 1.12 $self->_trace_flush if exists $self->{trace_check};
466     $self->{trace_check} = $file;
467 root 1.1
468 root 1.12 $self->{set}{"bin/$exe"} = ["$dir/$exe"];
469     next exe;
470     }
471 root 1.1 }
472     }
473    
474 root 1.12 croak "add_bin ($exe): executable not found";
475 root 1.1 }
476     }
477    
478     =item $extractor->add_eval ($string)
479    
480 root 1.5 Evaluates the string as perl code and adds all modules that are loaded
481     by it. For example, this would add L<AnyEvent> and the default backend
482     implementation module and event loop module:
483 root 1.1
484     $extractor->add_eval ("use AnyEvent; AnyEvent::detect");
485    
486 root 1.5 Each code snippet will be executed in its own package and under C<use
487     strict>.
488    
489 root 1.1 =cut
490    
491     sub add_eval {
492     my ($self, $eval) = @_;
493    
494 root 1.5 my $pkg = "libextractor" . ++$self->{count};
495 root 1.1 $eval =~ s/\x00/\x00."\\x00".q\x00/g;
496 root 1.3 $self->_trace ($eval,
497     "local \$^H = \$^H;" # vvvvvvvvvvvvvvvvvvvv = use strict; use utf8
498 root 1.5 . "eval q\x00package $pkg; BEGIN { \$^H = \$^H | 0x800600 } $eval\x00; die \"\$\@\" if \$\@;\n"
499 root 1.3 );
500 root 1.1 }
501    
502 root 1.5 =back
503    
504     =head2 OTHER METHODS FOR ADDING FILES
505    
506     The following methods add commonly used files that are either not covered
507     by other methods or add commonly-used dependencies.
508    
509     =over 4
510    
511 root 1.1 =item $extractor->add_perl
512    
513     Adds the perl binary itself to the file set, including the libperl dll, if
514     needed.
515    
516 root 1.12 For example, on UNIX systems, this usually adds a F<exe/perl> and possibly
517     some F<dll/libperl.so.XXX>.
518 root 1.5
519 root 1.4 =cut
520    
521     sub add_perl {
522     my ($self) = @_;
523    
524 root 1.12 $self->{set}{"exe/perl$Config{_exe}"} = [_perl_path];
525 root 1.4
526     # on debian, we have the special case of a perl binary linked against
527     # a static libperl.a (which is not available), but the Config says to use
528     # a shared library, which is in the wrong directory, too (which breaks
529     # every other perl installation on the system - they are so stupid).
530    
531     # that means we can't find the libperl.so, because dbeian actively breaks
532     # their perl install, and we don't need it. we work around this by silently
533     # not including the libperl if we cannot find it.
534    
535     if ($Config{useshrplib} eq "true") {
536 root 1.8 my ($libperl, $libpath);
537    
538     if ($^O eq "cygwin") {
539     $libperl = $Config{libperl};
540     $libpath = "$Config{binexp}/$libperl";
541     } elsif ($^O eq "MSWin32") {
542     ($libperl = $Config{libperl}) =~ s/\Q$Config{_a}\E$/.$Config{so}/;
543     $libpath = "$Config{binexp}/$libperl";
544     } else {
545     $libperl = $Config{libperl};
546     $libpath = $self->{lib}{"CORE/$libperl"};
547 root 1.4 }
548 root 1.8
549 root 1.12 $self->{set}{"dll/$libperl"} = $libpath
550 root 1.8 if length $libpath && -e $libpath;
551 root 1.4 }
552     }
553 root 1.3
554     =item $extractor->add_core_support
555    
556     Try to add modules and files needed to support commonly-used builtin
557     language features. For example to open a scalar for I/O you need the
558     L<PerlIO::scalar> module:
559    
560     open $fh, "<", \$scalar
561    
562     A number of regex and string features (e.g. C<ucfirst>) need some unicore
563     files, e.g.:
564    
565     'my $x = chr 1234; "\u$x\U$x\l$x\L$x"; $x =~ /\d|\w|\s|\b|$x/i';
566    
567     This call adds these files (simply by executing code similar to the above
568     code fragments).
569    
570     Notable things that are missing are other PerlIO layers, such as
571     L<PerlIO::encoding>, and named character and character class matches.
572    
573     =cut
574    
575     sub add_core_support {
576     my ($self) = @_;
577    
578     $self->add_eval ('my $v; open my $fh, "<", \$v');
579     $self->add_eval ('my $x = chr 1234; "\u$x\U$x\l$x\L$x"; $x =~ /\d|\w|\s|\b|\R|\h|\v|$x/i');
580 root 1.10 $self->add_eval ('split " ", chr 1234'); # usually covered by the regex above
581     $self->add_eval ('/\x{1234}(?<a>)\g{a}/') if $] >= 5.010; # usually covered by the regex above
582 root 1.3 }
583 root 1.1
584 root 1.3 =item $extractor->add_unicore
585    
586 root 1.11 Adds (hopefully) all files from the unicore database that will ever be
587 root 1.5 needed.
588    
589     If you are not sure which unicode character classes and similar unicore
590     databases you need, and you do not care about an extra one thousand(!)
591     files comprising 4MB of data, then you can just call this method, which
592     adds basically all files from perl's unicode database.
593    
594 root 1.11 Note that C<add_core_support> also adds some unicore files, but it's not a
595     subset of C<add_unicore> - the former adds all files neccessary to support
596     core builtins (which includes some unicore files and other things), while
597     the latter adds all unicore files (but nothing else).
598    
599     When in doubt, use both.
600    
601 root 1.5 =cut
602    
603     sub add_unicore {
604     my ($self) = @_;
605    
606     $self->_add ([grep m%^unicore/.*\.pl$%, keys %{ $self->{lib} }]);
607     }
608    
609 root 1.11 =item $extractor->add_core
610    
611     This adds all files from the perl core distribution, that is, all library
612     files that come with perl.
613    
614     This is a superset of C<add_core_support> and C<add_unicore>.
615    
616     This is quite a lot, but on the plus side, you can be sure nothing is
617     missing.
618    
619     This requires a full perl installation - many distributions (Debian
620     GNU/Linux for example) don't package all library files that perl installs.
621    
622     =cut
623    
624     sub add_core {
625     my ($self) = @_;
626    
627     my $lib = $self->{lib};
628    
629     for (@{
630     $self->_read_packlist ($Config{privlibexp}, ".packlist")
631     }) {
632     $self->{set}{$_} ||= [
633 root 1.12 "lib/"
634 root 1.11 . ($lib->{$_} or croak "$_: unable to locate file in perl library")
635     ];
636     }
637     }
638    
639 root 1.5 =back
640    
641     =head2 GLOB-BASED ADDING AND FILTERING
642 root 1.1
643 root 1.5 These methods add or manipulate files by using glob-based patterns.
644    
645     These glob patterns work similarly to glob patterns in the shell:
646    
647     =over 4
648    
649     =item /
650    
651     A F</> at the start of the pattern interprets the pattern as a file
652     path inside the file set, almost the same as in the shell. For example,
653     F</bin/perl*> would match all files whose names starting with F<perl>
654     inside the F<bin> directory in the set.
655    
656     If the F</> is missing, then the pattern is interpreted as a module name
657 root 1.12 (a F<.pm> file). For example, F<Coro> matches the file F<lib/Coro.pm> ,
658     while F<Coro::*> would match F<lib/Coro/*.pm>.
659 root 1.5
660     =item *
661    
662     A single star matches anything inside a single directory component. For
663     example, F</lib/Coro/*.pm> would match all F<.pm> files inside the
664     F<lib/Coro/> directory, but not any files deeper in the hierarchy.
665 root 1.1
666 root 1.5 Another way to look at it is that a single star matches anything but a
667     slash (F</>).
668 root 1.1
669 root 1.5 =item **
670 root 1.1
671 root 1.5 A double star matches any number of characters in the path, including F</>.
672 root 1.1
673 root 1.5 For example, F<AnyEvent::**> would match all modules whose names start
674     with C<AnyEvent::>, no matter how deep in the hierarchy they are.
675 root 1.1
676 root 1.5 =back
677 root 1.1
678 root 1.2 =cut
679    
680     sub _extglob2re {
681 root 1.5 for (quotemeta $_[1]) {
682 root 1.2 s/\\\*\\\*/.*/g;
683     s/\\\*/[^\/]*/g;
684     s/\\\?/[^\/]/g;
685    
686     unless (s%^\\/%%) {
687     s%\\:\\:%/%g;
688 root 1.12 $_ = "lib/$_\\.pm";
689 root 1.2 }
690    
691     $_ .= '$';
692     s/(?: \[\^\/\] | \. ) \*\$$//x; # remove ** at end
693    
694     return qr<^$_>s
695     }
696     }
697    
698 root 1.5 =over 4
699    
700     =item $extractor->add_glob ($modglob[, $modglob...])
701    
702     Adds all files from the perl library that match the given glob pattern.
703    
704     For example, you could implement C<add_unicore> yourself like this:
705    
706     $extractor->add_glob ("/unicore/**.pl");
707    
708     =cut
709    
710     sub add_glob {
711     my $self = shift;
712    
713     for (@_) {
714     my $pat = $self->_extglob2re ($_);
715     $self->_add ([grep /$pat/, keys %{ $self->{lib} }]);
716     }
717     }
718    
719     =item $extractor->filter ($pattern[, $pattern...])
720    
721     Applies a series of include/exclude filters. Each filter must start with
722     either C<+> or C<->, to designate the pattern as I<include> or I<exclude>
723     pattern. The rest of the pattern is a normal glob pattern.
724    
725     An exclude pattern (C<->) instantly removes all matching files from
726     the set. An include pattern (C<+>) protects matching files from later
727     removals.
728    
729     That is, if you have an include pattern then all files that were matched
730     by it will be included in the set, regardless of any further exclude
731     patterns matching the same files.
732    
733     Likewise, any file excluded by a pattern will not be included in the set,
734     even if matched by later include patterns.
735    
736     Any files not matched by any expression will simply stay in the set.
737    
738     For example, to remove most of the useless autoload functions by the POSIX
739     module (they either do the same thing as a builtin or always raise an
740 root 1.12 error), you would use this:
741 root 1.5
742     $extractor->filter ("-/lib/auto/POSIX/*.al");
743    
744     This does not remove all autoload files, only the ones not defined by a
745     subclass (e.g. it leaves C<POSIX::SigRt::xxx> alone).
746    
747     =cut
748    
749 root 1.2 sub filter {
750     my ($self, @patterns) = @_;
751    
752 root 1.3 $self->_trace_flush;
753    
754     my $set = $self->{set};
755     my %include;
756 root 1.2
757     for my $pat (@patterns) {
758     $pat =~ s/^([+\-])//
759     or croak "$_: not a valid filter pattern (missing + or - prefix)";
760     my $inc = $1 eq "+";
761     $pat = $self->_extglob2re ($pat);
762 root 1.3
763     my @match = grep /$pat/, keys %$set;
764    
765     if ($inc) {
766     @include{@match} = delete @$set{@match};
767     } else {
768     delete @$set{@{ $_->[I_DEP] }} # remove dependents
769     for delete @$set{@match};
770     }
771 root 1.2 }
772 root 1.3
773     my @include = keys %include;
774     @$set{@include} = delete @include{@include};
775 root 1.2 }
776 root 1.1
777 root 1.3 =item $extractor->runtime_only
778    
779     This removes all files that are not needed at runtime, such as static
780     archives, header and other files needed only for compilation of modules,
781     and pod and html files (which are unlikely to be needed at runtime).
782 root 1.1
783 root 1.8 This is quite useful when you want to have only files actually needed to
784 root 1.3 execute a program.
785    
786     =cut
787    
788     sub runtime_only {
789     my ($self) = @_;
790    
791     $self->_trace_flush;
792    
793     my $set = $self->{set};
794    
795 root 1.8 # delete all static libraries, also windows stuff
796 root 1.12 delete @$set{ grep m%^lib/auto/(?:.+/)?([^\/]+)/\1(?:\Q$Config{_a}\E|\.pdb|\.exp)$%s, keys %$set };
797 root 1.3
798     # delete all extralibs.ld and extralibs.all (no clue what the latter is for)
799 root 1.12 delete @$set{ grep m%^lib/auto/.*/extralibs\.(?:ld|all)$%s, keys %$set };
800 root 1.3
801     # delete all .pod, .h, .html files (hopefully none of them are used at runtime)
802 root 1.12 delete @$set{ grep m%^lib/.*\.(?:pod|h|html)$%s, keys %$set };
803 root 1.11
804     # delete unneeded unicore files
805 root 1.12 delete @$set{ grep m%^lib/unicore/(?:mktables(?:\.lst)?|.*\.txt)$%s, keys %$set };
806 root 1.3 }
807 root 1.1
808     =back
809    
810 root 1.5 =head2 RESULT SET
811    
812     =over 4
813 root 1.1
814 root 1.5 =item $set = $extractor->set
815 root 1.1
816 root 1.5 Returns a hash reference that represents the result set. The hash is the
817     actual internal storage hash and can only be modified as described below.
818 root 1.1
819 root 1.5 Each key in the hash is the path inside the set, without a leading slash,
820     e.g.:
821 root 1.1
822 root 1.5 bin/perl
823     lib/unicore/lib/Blk/Superscr.pl
824     lib/AnyEvent/Impl/EV.pm
825    
826     The value is an array reference with mostly unspecified contents, except
827     the first element, which is the file system path where the actual file can
828     be found.
829    
830     This code snippet lists all files inside the set:
831    
832     print "$_\n"
833     for sort keys %{ $extractor->set });
834    
835     This code fragment prints C<< filesystem_path => set_path >> pairs for all
836     files in the set:
837    
838     my $set = $extractor->set;
839     while (my ($set,$fspath) = each %$set) {
840     print "$fspath => $set\n";
841     }
842 root 1.1
843 root 1.5 You can implement your own filtering by asking for the result set with
844     C<< $extractor->set >>, and then deleting keys from the referenced hash
845     - since you can ask for the result set at any time you can add things,
846     filter them out this way, and add additional things.
847    
848     =back
849    
850     =cut
851    
852     sub set {
853 root 1.6 $_[0]->_trace_flush;
854 root 1.5 $_[0]{set}
855     }
856    
857     =head1 EXAMPLE
858    
859     To package he deliantra client (L<Deliantra::Client>), finding all
860     (perl) files needed to run it is a first step. This can be done by using
861     something like the following code snippet:
862    
863 root 1.12 my $ex = new Perl::LibExtractor;
864 root 1.5
865     $ex->add_perl;
866     $ex->add_core_support;
867 root 1.12 $ex->add_bin ("deliantra");
868 root 1.5 $ex->add_mod ("AnyEvent::Impl::EV");
869     $ex->add_mod ("AnyEvent::Impl::Perl");
870     $ex->add_mod ("Urlader");
871     $ex->filter ("-/*/auto/POSIX/**.al");
872     $ex->runtime_only;
873    
874     First it sets the perl library directory to F<pm> and F<.> (the latter
875     to work around some AutoLoader bugs), so perl uses only the perl library
876     files that came with the binary package.
877    
878     Then it sets some environment variable to override the system default
879     (which might be incompatible).
880    
881     Then it runs the client itself, using C<require>. Since C<require> only
882     looks in the perl library directory this is the reaosn why the scripts
883     were put there (of course, since F<.> is also included it doesn't matter,
884     but I refuse to yield to bugs).
885    
886     Finally it exits with a clean status to signal "ok" to Urlader.
887    
888     Back to the original C<Perl::LibExtractor> script: after initialising a
889     new set, the script simply adds the F<perl> interpreter and core support
890     files (just in case, not all are needed, but some are, and I am too lazy
891     to find out which ones exactly).
892    
893     Then it adds the deliantra executable itself, which in turn adds most of
894     the required modules. After that, the AnyEvent implementation modules are
895     added because these dependencies are not picked up automatically.
896    
897     The L<Urlader> module is added because the client itself does not depend
898     on it at all, but the wrapper does.
899    
900     At this point, all required files are present, and it's time to slim
901     down: most of the ueseless POSIX autoloaded functions are removed,
902     not because they are so big, but because creating files is a costly
903     operation in itself, so even small fiels have considerable overhead when
904     unpacking. Then files not required for running the client are removed.
905    
906     And that concludes it, the set is now ready.
907 root 1.1
908     =head1 SEE ALSO
909    
910     The utility program that comes with this module: L<perl-libextract>.
911    
912     L<App::Staticperl>, L<Urlader>, L<Perl::Squish>.
913    
914 root 1.5 =head1 LICENSE
915    
916     This software package is licensed under the GPL version 3 or any later
917     version, see COPYING for details.
918    
919     This license does not, of course, apply to any output generated by this
920     software.
921    
922 root 1.1 =head1 AUTHOR
923    
924     Marc Lehmann <schmorp@schmorp.de>
925     http://home.schmorp.de/
926    
927     =cut
928    
929     1;
930