ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/Perl-LibExtractor/LibExtractor.pm
(Generate patch)

Comparing cvsroot/Perl-LibExtractor/LibExtractor.pm (file contents):
Revision 1.2 by root, Sat Jan 14 18:42:53 2012 UTC vs.
Revision 1.3 by root, Sat Jan 14 21:14:36 2012 UTC

… …
88 88
89To prepend custom dirs just do this: 89To prepend custom dirs just do this:
90 90
91 inc => ["mydir", @INC], 91 inc => ["mydir", @INC],
92 92
93=item use_packlists => 1 93=item use_packlist => 1
94 94
95Enable (if true) or disable the use of C<.packlists>. If enabled, then 95Enable (if true) or disable the use of C<.packlist> files. If enabled,
96each time a module is included, the complete distribution that contains 96then each time a module is included, the complete distribution that
97it is included as well. See L<ALGORITHMS>, below. 97contains it is included (and traced) as well. See L<ALGORITHMS>, below.
98 98
99=back 99=back
100 100
101=cut 101=cut
102 102
… …
107 exedir => "bin", 107 exedir => "bin",
108 libdir => "lib", 108 libdir => "lib",
109 bindir => "bin", 109 bindir => "bin",
110 dlldir => "bin", 110 dlldir => "bin",
111 inc => [grep $_ ne ".", @INC], 111 inc => [grep $_ ne ".", @INC],
112 use_packlists => 1, 112 use_packlist => 1,
113 %kv, 113 %kv,
114 set => {}, 114 set => {},
115 }, $class; 115 }, $class;
116 116
117 my %inc_seen; 117 my %inc_seen;
… …
207 my @info; 207 my @info;
208 208
209 $info[I_SRC] = $lib->{$_} 209 $info[I_SRC] = $lib->{$_}
210 or croak "$_: unable to locate file in perl library"; 210 or croak "$_: unable to locate file in perl library";
211 211
212 if ($self->{use_packlists} && exists $self->{packlist}{$_}) { 212 if ($self->{use_packlist} && exists $self->{packlist}{$_}) {
213 $self->{set}{"$self->{libdir}/$_"} ||= [$self->{lib}{$_} or die] 213 $self->{set}{"$self->{libdir}/$_"} ||= [$self->{lib}{$_} or die]
214 for @{ $self->{packlist}{$_} }; 214 for @{ $self->{packlist}{$_} };
215
216# for (grep /\.pm$/, @{ $self->{packlist}{$_} }) {
217# s/\.pm$//;
218# s%/%::%g;
219# my $pkg = "libextractor" . ++$self->{count};
220# $self->add_eval ("{ package $pkg; eval 'use $_' }")
221# unless $self->{_add_do}{$_}++;
222# }
223#
224# $self->{_add_do}{$_}++ or $self->add_eval ("do q\x00$_\x00")
225# for grep /\.pl$/, @{ $self->{packlist}{$_} };
226
215 } elsif (/^(.*)\.pm$/) { 227 } elsif (/^(.*)\.pm$/) {
216 (my $auto = "auto/$1/") =~ s%::%/%g; 228 (my $auto = "auto/$1/") =~ s%::%/%g;
217 $auto =~ m%/([^/]+)/$% or die; 229 $auto =~ m%/([^/]+)/$% or die;
218 my $base = $1; 230 my $base = $1;
219 231
… …
267} 279}
268 280
269sub _trace { 281sub _trace {
270 my ($self, $file, $eval) = @_; 282 my ($self, $file, $eval) = @_;
271 283
272 $self->{trace_begin} .= "#line \"$file\" 1\n$eval;\n"; 284 $self->{trace_begin} .= "\n#line \"$file\" 1\n$eval;\n";
273} 285}
274 286
275sub _trace_flush { 287sub _trace_flush {
276 my ($self) = @_; 288 my ($self) = @_;
277 289
290 # ->_add might add additional files to trace
278 return unless exists $self->{trace_begin} or exists $self->{trace_check}; 291 while (exists $self->{trace_begin} or exists $self->{trace_check}) {
279
280 my $tmpdir = newdir File::Temp; 292 my $tmpdir = newdir File::Temp;
281 my $dir = $tmpdir->dirname; 293 my $dir = $tmpdir->dirname;
282 294
283 open my $fh, ">:perlio", "$dir/eval" 295 open my $fh, ">:perlio", "$dir/eval"
284 or croak "$dir/eval: $!"; 296 or croak "$dir/eval: $!";
285 syswrite $fh, 297 syswrite $fh,
286 'BEGIN { @INC = (' . (join ", ", map "q\x00$_\x00", @{ $self->{inc} }) . ") }\n" 298 'BEGIN { @INC = (' . (join ", ", map "q\x00$_\x00", @{ $self->{inc} }) . ") }\n"
287 . "BEGIN { chdir q\x00$dir\x00 or die q\x00$dir: \$!\x00 }\n" 299 . "BEGIN { chdir q\x00$dir\x00 or die q\x00$dir: \$!\x00 }\n"
288 . 'BEGIN { ' . (delete $self->{trace_begin}) . "}\n" 300 . 'BEGIN { ' . (delete $self->{trace_begin}) . "}\n"
289 . "CHECK {\n" 301 . "CHECK {\n"
290 . 'open STDOUT, ">:raw", "out" or die "out: $!";' 302 . 'open STDOUT, ">:raw", "out" or die "out: $!";'
291 . 'print join "\x00", values %INC;' 303 . 'print join "\x00", values %INC;'
292 . 'open STDERR, ">stderr";' # suppress "syntax OK" message from perl 304 . 'open STDERR, ">stderr";' # suppress "syntax OK" message from perl
293 . "}\n" 305 . "}\n"
294 . (delete $self->{trace_check}); 306 . (delete $self->{trace_check});
295 close $fh; 307 close $fh;
296 308
297 my $secure_perl_path = $Config{perlpath}; 309 my $secure_perl_path = $Config{perlpath};
298 310
299 if ($^O ne 'VMS') { 311 if ($^O ne 'VMS') {
300 $secure_perl_path .= $Config{_exe} 312 $secure_perl_path .= $Config{_exe}
301 unless $secure_perl_path =~ m/$Config{_exe}$/i; 313 unless $secure_perl_path =~ m/$Config{_exe}$/i;
302 } 314 }
303 315
304 system $secure_perl_path, "-c", "$dir/eval" 316 system $secure_perl_path, "-c", "$dir/eval"
305 and croak "trace failure, check trace process output."; 317 and croak "trace failure, check trace process output - caught";
306 318
307 my @inc = split /\x00/, do { 319 my @inc = split /\x00/, do {
308 open my $fh, "<:perlio", "$dir/out" 320 open my $fh, "<:perlio", "$dir/out"
309 or croak "$dir/out: $!"; 321 or croak "$dir/out: $!";
310 local $/; 322 local $/;
311 scalar readline $fh 323 scalar readline $fh
312 }; 324 };
313 325
314 my $matchprefix = $self->{matchprefix}; 326 my $matchprefix = $self->{matchprefix};
315 327
316 # remove the library directory prefix, hope for the best 328 # remove the library directory prefix, hope for the best
317 s/$matchprefix// 329 s/$matchprefix//
318 or croak "$_: file outside any library directory" 330 or croak "$_: file outside any library directory"
319 for @inc; 331 for @inc;
320 332
321 $self->_add (\@inc); 333 $self->_add (\@inc);
334 }
322} 335}
323 336
324=item $extractor->add_mod ($module[, $module...]) 337=item $extractor->add_mod ($module[, $module...])
325 338
326Adds the given module(s) to the file set - the module name must be specified 339Adds the given module(s) to the file set - the module name must be specified
… …
338=cut 351=cut
339 352
340sub add_mod { 353sub add_mod {
341 my $self = shift; 354 my $self = shift;
342 355
356 for (@_) {
343 my $pkg = "libextractor" . ++$self->{count}; 357 my $pkg = "libextractor" . ++$self->{count};
344
345 $self->_trace ("use $_", "{ package $pkg; use $_ }") 358 $self->_trace ("use $_", "{ package $pkg; use $_ }")
346 for @_; 359 unless $self->{add_mod}{$_}++;
360 }
347} 361}
348 362
349=item $extractor->add_exe ($name[, $name...]) 363=item $extractor->add_exe ($name[, $name...])
350 364
351Adds the given (perl) program(s) to the file set, that is, a program 365Adds the given (perl) program(s) to the file set, that is, a program
… …
394 408
395sub add_eval { 409sub add_eval {
396 my ($self, $eval) = @_; 410 my ($self, $eval) = @_;
397 411
398 $eval =~ s/\x00/\x00."\\x00".q\x00/g; 412 $eval =~ s/\x00/\x00."\\x00".q\x00/g;
399 $self->_trace ($eval, "eval q\x00$eval\x00 or die;\n"); 413 $self->_trace ($eval,
414 "local \$^H = \$^H;" # vvvvvvvvvvvvvvvvvvvv = use strict; use utf8
415 . "eval q\x00BEGIN { \$^H = \$^H | 0x800600 } $eval\x00; die \"\$\@\" if \$\@;\n"
416 );
400} 417}
401 418
402=item $extractor->add_perl 419=item $extractor->add_perl
403 420
404Adds the perl binary itself to the file set, including the libperl dll, if 421Adds the perl binary itself to the file set, including the libperl dll, if
405needed. 422needed.
406 423
424#TODO#
425
407=item $extractor->add_unicore_minimal 426=item $extractor->add_core_support
408 427
428Try to add modules and files needed to support commonly-used builtin
429language features. For example to open a scalar for I/O you need the
430L<PerlIO::scalar> module:
431
432 open $fh, "<", \$scalar
433
434A number of regex and string features (e.g. C<ucfirst>) need some unicore
435files, e.g.:
436
437 'my $x = chr 1234; "\u$x\U$x\l$x\L$x"; $x =~ /\d|\w|\s|\b|$x/i';
438
439This call adds these files (simply by executing code similar to the above
440code fragments).
441
442Notable things that are missing are other PerlIO layers, such as
443L<PerlIO::encoding>, and named character and character class matches.
444
445=cut
446
447sub add_core_support {
448 my ($self) = @_;
449
450 $self->add_eval ('my $v; open my $fh, "<", \$v');
451 $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');
452}
453
409=item $extractor->add_unicore_all 454=item $extractor->add_unicore
455
456#TODO
410 457
411=item $extractor->add_glob ($modglob[, $modglob...]) 458=item $extractor->add_glob ($modglob[, $modglob...])
412 459
413#TODO# 460#TODO#
414 461
… …
453} 500}
454 501
455sub filter { 502sub filter {
456 my ($self, @patterns) = @_; 503 my ($self, @patterns) = @_;
457 504
505 $self->_trace_flush;
506
507 my $set = $self->{set};
458 my @include; 508 my %include;
459 509
460 for my $pat (@patterns) { 510 for my $pat (@patterns) {
461 $pat =~ s/^([+\-])// 511 $pat =~ s/^([+\-])//
462 or croak "$_: not a valid filter pattern (missing + or - prefix)"; 512 or croak "$_: not a valid filter pattern (missing + or - prefix)";
463 my $inc = $1 eq "+"; 513 my $inc = $1 eq "+";
464 $pat = $self->_extglob2re ($pat); 514 $pat = $self->_extglob2re ($pat);
515
465 my @match = grep /$pat/, keys %{ $self->{set} }; 516 my @match = grep /$pat/, keys %$set;
466 say;
467 say $pat;
468 say join "\n", @match;
469 }
470}
471 517
472=item $extractor->add_auto 518 if ($inc) {
519 @include{@match} = delete @$set{@match};
520 } else {
521 delete @$set{@{ $_->[I_DEP] }} # remove dependents
522 for delete @$set{@match};
523 }
524 }
473 525
474#todo, not like this 526 my @include = keys %include;
527 @$set{@include} = delete @include{@include};
528}
529
530=item $extractor->runtime_only
531
532This removes all files that are not needed at runtime, such as static
533archives, header and other files needed only for compilation of modules,
534and pod and html files (which are unlikely to be needed at runtime).
535
536This is quite useful when you want to have only fiels actually needed to
537execute a program.
538
539=cut
540
541sub runtime_only {
542 my ($self) = @_;
543
544 $self->_trace_flush;
545
546 my $set = $self->{set};
547
548 # delete all static libraries
549 delete @$set{ grep m%^\Q$self->{libdir}\E/auto/(?:.+/)?([^\/]+)/\1\Q$Config{_a}\E$%s, keys %$set };
550
551 # delete all extralibs.ld and extralibs.all (no clue what the latter is for)
552 delete @$set{ grep m%^\Q$self->{libdir}\E/auto/.*/extralibs\.(?:ld|all)$%s, keys %$set };
553
554 # delete all .pod, .h, .html files (hopefully none of them are used at runtime)
555 delete @$set{ grep m%^\Q$self->{libdir}\E/.*.(?:pod|h|html)$%s, keys %$set };
556}
475 557
476=back 558=back
477 559
478=head1 ALGORITHMS 560=head1 ALGORITHMS
479#TODO 561#TODO

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines