| … | |
… | |
| 11 | The purpose of this module is to determine subsets of your perl library, |
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 |
12 | that is, a set of files needed to satisfy certain dependencies (e.g. of a |
| 13 | program). |
13 | program). |
| 14 | |
14 | |
| 15 | The goal is to extract a part of your perl installation including |
15 | The goal is to extract a part of your perl installation including |
| 16 | dependencies. A typical example for this module would be to find out |
16 | dependencies. A typical use case for this module would be to find out |
| 17 | which files are needed to be build a L<PAR> distribution, to link into |
17 | 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 |
18 | an L<App::Staticperl> binary, or to pack with L<Urlader>, to create |
| 19 | stand-alone distributions tailormade to run your app. |
19 | stand-alone distributions tailormade to run your app. |
| 20 | |
20 | |
| 21 | =head1 METHODS |
21 | =head1 METHODS |
| 22 | |
22 | |
| 23 | To use this module, first call the C<new>-constructor and then as many |
23 | To use this module, first call the C<new>-constructor and then as many |
| 24 | other methods as you want, to generate a set of files. |
24 | other methods as you want, to generate a set of files. Then query the set of |
|
|
25 | files and do whatever you want with them. |
|
|
26 | |
|
|
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. |
| 25 | |
31 | |
| 26 | =over 4 |
32 | =over 4 |
| 27 | |
33 | |
| 28 | =cut |
34 | =cut |
| 29 | |
35 | |
| … | |
… | |
| 36 | |
42 | |
| 37 | use common::sense; |
43 | use common::sense; |
| 38 | |
44 | |
| 39 | sub I_SRC () { 0 } |
45 | sub I_SRC () { 0 } |
| 40 | sub I_DEP () { 1 } |
46 | sub I_DEP () { 1 } |
| 41 | sub I_FLAGS() { 2 } |
|
|
| 42 | |
|
|
| 43 | sub T_PL () { 1 } |
|
|
| 44 | sub T_PM () { 2 } |
|
|
| 45 | sub T_EXE() { 3 } |
|
|
| 46 | sub T_BIN() { 4 } |
|
|
| 47 | sub T_DLL() { 5 } |
|
|
| 48 | |
|
|
| 49 | sub F_EVAL () { 0x01 } |
|
|
| 50 | sub F_STRIP() { 0x02 } |
|
|
| 51 | |
47 | |
| 52 | sub croak($) { |
48 | sub croak($) { |
| 53 | require Carp; |
49 | require Carp; |
| 54 | Carp::croak "(Perl::LibExtractor) $_[0]"; |
50 | Carp::croak "(Perl::LibExtractor) $_[0]"; |
| 55 | } |
51 | } |
| … | |
… | |
| 128 | } |
124 | } |
| 129 | |
125 | |
| 130 | sub _set_inc { |
126 | sub _set_inc { |
| 131 | my ($self) = @_; |
127 | my ($self) = @_; |
| 132 | |
128 | |
|
|
129 | my $matchprefix = join "|", map "\Q$_", @{ $self->{inc }}; |
|
|
130 | $matchprefix = qr<^(?:$matchprefix)/>; |
|
|
131 | |
| 133 | my %lib; |
132 | my %lib; |
|
|
133 | my @packlists; |
| 134 | |
134 | |
| 135 | # find all files in all libdirs, earlier ones overwrite later ones |
135 | # find all files in all libdirs, earlier ones overwrite later ones |
| 136 | for my $dir (reverse @{ $self->{inc} }) { |
136 | my @scan = map [$_, ""], @{ $self->{inc} }; |
| 137 | my $scan = sub { |
137 | |
|
|
138 | while (@scan) { |
|
|
139 | my ($root, $dir) = @{ pop @scan }; |
|
|
140 | |
| 138 | my $pfx = length $_[1] ? "$_[1]/" : ""; |
141 | my $pfx = length $dir ? "$dir/" : ""; |
| 139 | #my (@dirs, @files); |
|
|
| 140 | |
142 | |
| 141 | for (do { |
143 | for (do { |
| 142 | opendir my $fh, "$dir/$_[1]" |
144 | opendir my $fh, "$root/$dir" |
| 143 | or croak "$dir/$_[1]: $!"; |
145 | or croak "$root/$dir: $!"; |
| 144 | grep !/^\.\.?$/, readdir $fh |
146 | grep !/^\.\.?$/, readdir $fh |
| 145 | }) { |
147 | }) { |
| 146 | if (-d "$dir/$_[1]/$_/.") { |
148 | if (-d "$root/$dir/$_/.") { |
| 147 | #push @dirs, $_; |
|
|
| 148 | $_[0]($_[0], "$pfx$_"); |
|
|
| 149 | $lib{"$pfx$_/"} = "$dir/$pfx$_"; |
149 | $lib{"$pfx$_/"} = "$root/$pfx$_"; |
|
|
150 | push @scan, [$root, "$pfx$_"]; |
|
|
151 | } elsif ($_ eq ".packlist" && $pfx =~ m%^auto/%) { |
|
|
152 | push @packlists, [$root, $pfx]; |
|
|
153 | } elsif (/\.bs$/ && $pfx =~ m%^auto/% && !-s "$root/$dir/$_") { |
|
|
154 | # skip empty .bs files |
|
|
155 | # } elsif (/\.(?:pod|h|html)$/) { |
|
|
156 | # # not interested in those |
| 150 | } else { |
157 | } else { |
| 151 | #push @files, $_; |
158 | #push @files, $_; |
| 152 | $lib{"$pfx$_"} = "$dir/$pfx$_"; |
159 | $lib{"$pfx$_"} = "$root/$pfx$_"; |
| 153 | } |
|
|
| 154 | } |
160 | } |
|
|
161 | } |
| 155 | |
162 | |
| 156 | #$lib{"$_[1]/"} = [\@dirs, \@files]; # won't work nice with overwrite |
163 | #$lib{"$_[1]/"} = [\@dirs, \@files]; # won't work nice with overwrite |
|
|
164 | } |
|
|
165 | |
|
|
166 | my %packlist; |
|
|
167 | |
|
|
168 | # need to go forward here |
|
|
169 | for (@packlists) { |
|
|
170 | my ($root, $auto) = @$_; |
|
|
171 | |
|
|
172 | my @packlist; |
|
|
173 | |
|
|
174 | open my $fh, "<:perlio", "$root/$auto/.packlist" |
|
|
175 | or die "$root/$auto/.packlist: $!"; |
|
|
176 | |
|
|
177 | $root = qr<^\Q$root/>; |
|
|
178 | |
|
|
179 | while (<$fh>) { |
|
|
180 | chomp; |
|
|
181 | s/ .*$//; # newer-style .packlists might contain key=value pairs |
|
|
182 | s%/\./%/%g; # yeah, these too |
|
|
183 | |
|
|
184 | s/$root// or next; |
|
|
185 | exists $lib{$_} or next; |
|
|
186 | |
|
|
187 | push @packlist, $_; |
|
|
188 | $packlist{$_} = \@packlist; |
| 157 | }; |
189 | } |
| 158 | |
|
|
| 159 | $scan->($scan, ""); |
|
|
| 160 | } |
190 | } |
| 161 | |
191 | |
| 162 | $self->{lib} = \%lib; |
192 | $self->{lib} = \%lib; |
| 163 | |
193 | $self->{packlist} = \%packlist; |
| 164 | my $matchprefix = join "|", map "\Q$_", @{ $self->{inc }}; |
|
|
| 165 | $self->{matchprefix} = qr<^(?:$matchprefix)/>; |
194 | $self->{matchprefix} = $matchprefix; |
| 166 | } |
195 | } |
| 167 | |
196 | |
| 168 | sub _add { |
197 | sub _add { |
| 169 | my ($self, $add) = @_; |
198 | my ($self, $add) = @_; |
| 170 | |
199 | |
| … | |
… | |
| 178 | my @info; |
207 | my @info; |
| 179 | |
208 | |
| 180 | $info[I_SRC] = $lib->{$_} |
209 | $info[I_SRC] = $lib->{$_} |
| 181 | or croak "$_: unable to locate file in perl library"; |
210 | or croak "$_: unable to locate file in perl library"; |
| 182 | |
211 | |
|
|
212 | if ($self->{use_packlists} && exists $self->{packlist}{$_}) { |
|
|
213 | $self->{set}{"$self->{libdir}/$_"} ||= [$self->{lib}{$_} or die] |
|
|
214 | for @{ $self->{packlist}{$_} }; |
| 183 | if (/^(.*)\.pm$/) { |
215 | } elsif (/^(.*)\.pm$/) { |
| 184 | (my $auto = "auto/$1/") =~ s%::%/%g; |
216 | (my $auto = "auto/$1/") =~ s%::%/%g; |
| 185 | $auto =~ m%/([^/]+)/$% or die; |
217 | $auto =~ m%/([^/]+)/$% or die; |
| 186 | my $base = $1; |
218 | my $base = $1; |
| 187 | |
219 | |
| 188 | if (exists $lib->{$auto}) { |
220 | if (exists $lib->{$auto}) { |
| 189 | # auto dir exists, scan it for cool stuff |
221 | # auto dir exists, scan it for cool stuff |
| 190 | |
|
|
| 191 | # 1. packlists |
|
|
| 192 | my $pack = "$auto.packlist"; |
|
|
| 193 | if (my $src = $lib->{$pack} and $self->{use_packlists}) { |
|
|
| 194 | open my $fh, "<:perlio", $src |
|
|
| 195 | or croak "$src: $!"; |
|
|
| 196 | |
|
|
| 197 | my @files; |
|
|
| 198 | |
|
|
| 199 | while (<$fh>) { |
|
|
| 200 | chomp; |
|
|
| 201 | s/ .*$//; # newer-style .packlists might contain key=value pairs |
|
|
| 202 | s%/\./%/%g; # yeah, these too |
|
|
| 203 | |
|
|
| 204 | # only include certain files (.al, .ix, .pm, .pl) |
|
|
| 205 | if (/\.(pm|pl|al|ix|\q$Config{dlext}\E)$/) { |
|
|
| 206 | s/$self->{matchprefix}// |
|
|
| 207 | or croak "$_: not found in library directory"; |
|
|
| 208 | |
|
|
| 209 | my $src = $lib->{$_} |
|
|
| 210 | or croak "$_: not found in library directory"; |
|
|
| 211 | |
|
|
| 212 | $self->{set}{"$self->{libdir}/$_"} = [$src]; |
|
|
| 213 | } |
|
|
| 214 | } |
|
|
| 215 | |
|
|
| 216 | goto skip; # packlists are supposed to contain all relevant files, including autoload and .so's |
|
|
| 217 | } |
|
|
| 218 | |
222 | |
| 219 | # 1. shared object, others are of no interest to us |
223 | # 1. shared object, others are of no interest to us |
| 220 | my $so = "$auto$base.$Config{dlext}"; |
224 | my $so = "$auto$base.$Config{dlext}"; |
| 221 | if (my $src = $lib->{$so}) { |
225 | if (my $src = $lib->{$so}) { |
| 222 | $so = "$self->{libdir}/$so"; |
226 | $so = "$self->{libdir}/$so"; |
| … | |
… | |
| 424 | even if matches by later include patterns. |
428 | even if matches by later include patterns. |
| 425 | |
429 | |
| 426 | Any files not matched by any expression will be included, that is, the |
430 | Any files not matched by any expression will be included, that is, the |
| 427 | filter list has an implicit C<+/**> pattern at the end. |
431 | filter list has an implicit C<+/**> pattern at the end. |
| 428 | |
432 | |
| 429 | #TODO# |
433 | =cut |
|
|
434 | |
|
|
435 | sub _extglob2re { |
|
|
436 | my $self = shift; |
|
|
437 | |
|
|
438 | for (quotemeta $_[0]) { |
|
|
439 | s/\\\*\\\*/.*/g; |
|
|
440 | s/\\\*/[^\/]*/g; |
|
|
441 | s/\\\?/[^\/]/g; |
|
|
442 | |
|
|
443 | unless (s%^\\/%%) { |
|
|
444 | s%\\:\\:%/%g; |
|
|
445 | $_ = (quotemeta $self->{libdir}) . "/$_\\.pm"; |
|
|
446 | } |
|
|
447 | |
|
|
448 | $_ .= '$'; |
|
|
449 | s/(?: \[\^\/\] | \. ) \*\$$//x; # remove ** at end |
|
|
450 | |
|
|
451 | return qr<^$_>s |
|
|
452 | } |
|
|
453 | } |
|
|
454 | |
|
|
455 | sub filter { |
|
|
456 | my ($self, @patterns) = @_; |
|
|
457 | |
|
|
458 | my @include; |
|
|
459 | |
|
|
460 | for my $pat (@patterns) { |
|
|
461 | $pat =~ s/^([+\-])// |
|
|
462 | or croak "$_: not a valid filter pattern (missing + or - prefix)"; |
|
|
463 | my $inc = $1 eq "+"; |
|
|
464 | $pat = $self->_extglob2re ($pat); |
|
|
465 | my @match = grep /$pat/, keys %{ $self->{set} }; |
|
|
466 | say; |
|
|
467 | say $pat; |
|
|
468 | say join "\n", @match; |
|
|
469 | } |
|
|
470 | } |
| 430 | |
471 | |
| 431 | =item $extractor->add_auto |
472 | =item $extractor->add_auto |
| 432 | |
473 | |
| 433 | #todo, not like this |
474 | #todo, not like this |
| 434 | |
475 | |
| … | |
… | |
| 448 | |
489 | |
| 449 | =head2 Glob/path-based modifications |
490 | =head2 Glob/path-based modifications |
| 450 | #TODO |
491 | #TODO |
| 451 | |
492 | |
| 452 | =head1 EXTENDED GLOB PATTERNS |
493 | =head1 EXTENDED GLOB PATTERNS |
|
|
494 | #TODO |
| 453 | |
495 | |
| 454 | =head1 SEE ALSO |
496 | =head1 SEE ALSO |
| 455 | |
497 | |
| 456 | The utility program that comes with this module: L<perl-libextract>. |
498 | The utility program that comes with this module: L<perl-libextract>. |
| 457 | |
499 | |
