File Coverage

lib/App/PP/Autolink.pm
Criterion Covered Total %
statement 47 319 14.7
branch 0 110 0.0
condition 0 20 0.0
subroutine 16 29 55.1
pod 0 9 0.0
total 63 487 12.9


line stmt bran cond sub pod time code
1             # logic initially based on pp_simple.pl
2             # Should cache the Module::Scandeps result
3             # and then clean it up after using it.
4            
5             package App::PP::Autolink;
6            
7 1     1   1222 use strict;
  1         3  
  1         30  
8 1     1   5 use warnings;
  1         2  
  1         22  
9 1     1   23 use 5.014;
  1         3  
10            
11 1     1   5 use Carp;
  1         2  
  1         70  
12 1     1   579 use English qw / -no_match_vars /;
  1         1653  
  1         5  
13            
14 1     1   336 use File::Which qw( which );
  1         4  
  1         51  
15 1     1   563 use Capture::Tiny qw/ capture /;
  1         23849  
  1         72  
16 1     1   8 use List::Util 1.45 qw( uniq any );
  1         19  
  1         102  
17 1     1   522 use File::Find::Rule qw/ rule find /;
  1         8328  
  1         8  
18 1     1   1023 use Path::Tiny qw/ path /;
  1         12746  
  1         101  
19             #use File::Temp qw/ tempfile /;
20 1     1   697 use Module::ScanDeps;
  1         25626  
  1         72  
21 1     1   1002 use Env qw /@PATH/;
  1         2630  
  1         7  
22            
23 1     1   182 use Config;
  1         2  
  1         35  
24 1     1   638 use Getopt::ArgvFile default=>1;
  1         3824  
  1         7  
25 1     1   3966 use Getopt::Long qw / GetOptionsFromArray :config pass_through /;
  1         10994  
  1         11  
26            
27             our $VERSION = '2.11';
28            
29 1     1   355 use constant CASE_INSENSITIVE_OS => ($^O eq 'MSWin32');
  1         79  
  1         3947  
30            
31             my $RE_DLL_EXT = qr/\.$Config::Config{so}$/i;
32             if ($^O eq 'darwin') {
33             $RE_DLL_EXT = qr/\.($Config::Config{so}|bundle)$/i;
34             }
35            
36             my $ldd_exe = which('ldd');
37            
38            
39             sub new {
40 0     0 0   my ($class, @args) = @_;
41            
42 0           my $self = bless {}, $class;
43            
44             $self->{autolink_list_method}
45 0 0         = $^O eq 'MSWin32' ? 'get_autolink_list'
    0          
    0          
46             : $^O eq 'darwin' ? 'get_autolink_list_macos'
47             : $ldd_exe ? 'get_autolink_list_ldd'
48             # objdump behaves differently on linux (centos at least)
49             : die 'Unable to generate autolink list';
50            
51             # slightly messy, but issues with pass_through and --no-x
52 0           $self->{no_execute_flag} = not grep {$_ eq '-x'} @args;
  0            
53            
54             # Should trap any scandeps args (if diff from pp).
55 0           my @args_array = @args;
56 0           my @argv_linkers;
57            
58 0           GetOptionsFromArray (
59             \@args_array,
60             "link|l=s" => \@argv_linkers,
61             );
62 0           $self->{argv_linkers} = \@argv_linkers;
63 0           $self->{args_to_pass_to_pp} = \@args_array;
64            
65             # pp allows multiple .pl files.
66 0 0         my $script_fullname = $args[-1] or die 'no input file specified';
67 0           $self->{script_fullname} = $script_fullname;
68            
69 0           $self->{alien_sys_installs} = [];
70 0           $self->{alien_deps} = [];
71            
72 0           return $self;
73             }
74            
75             sub build {
76 0     0 0   my ($self) = @_;
77            
78             # reassemble the arg list
79 0           my $argv_linkers = $self->{argv_linkers};
80 0           my $args_array = $self->{args_to_pass_to_pp};
81             my @args_for_pp = (
82 0           (map {("--link" => $_)} @$argv_linkers),
  0            
83             @$args_array,
84             );
85            
86 0           my $method = $self->{autolink_list_method};
87 0           my @dll_list = $self->$method;
88 0           my $alien_sys_installs = $self->{alien_sys_installs};
89            
90             # two-step process to get unique paths
91 0           my %tmp = map {($_ => '--link')} (@dll_list, @$alien_sys_installs);
  0            
92 0           my @links = reverse %tmp;
93            
94 0 0         if (@$alien_sys_installs) {
95 0           say 'Alien sys dlls added: ' . join ' ', @$alien_sys_installs;
96 0           say '';
97             }
98             else {
99 0           say "No alien system dlls detected\n";
100             }
101            
102 0           say 'Detected link list: ' . join ' ', grep {$_ ne '--link'} @links;
  0            
103 0           say '';
104            
105 0           my @aliens = uniq @{$self->{alien_deps}};
  0            
106 0           my @alien_deps = map {; '-M' => $_} @aliens;
  0            
107 0           say 'Detected aliens: ' . join ' ', sort @aliens;
108 0           say '';
109            
110 0           my @command = (
111             'pp',
112             @links,
113             #"--cachedeps=$cache_file",
114             @alien_deps,
115             @args_for_pp,
116             );
117            
118 0           say 'CMD: ' . join ' ', @command;
119 0 0         system (@command) == 0
120             or die "system @command failed: $?";
121            
122 0           return;
123             }
124            
125            
126            
127             sub get_autolink_list {
128 0     0 0   my ($self) = @_;
129            
130 0           my $argv_linkers = $self->{argv_linkers};
131            
132 0 0         my $OBJDUMP = which('objdump') or die "objdump not found";
133            
134 0           my @exe_path = @PATH;
135            
136 0           my @system_paths;
137            
138 0 0         if ($OSNAME =~ /MSWin32/i) {
139             # skip anything under the C:\Windows folder,
140             # blank entries
141             # and no longer extant folders
142 0   0       my $system_root = $ENV{SystemRoot} || $ENV{WINDIR};
143             @system_paths
144 0           = map {path($_)->stringify} # otherwise we hit issues on SP5.36
145 0 0         grep {$_ and $_ =~ m|^\Q$system_root\E|i}
  0            
146             @exe_path;
147             @exe_path
148 0           = map {path($_)->stringify}
149 0 0 0       grep {$_ and (-e $_) and $_ !~ m|^\Q$system_root\E|i}
  0            
150             @exe_path;
151             #say "PATHS: " . join ' ', @exe_path;
152             }
153             # what to skip for linux or mac?
154            
155             # get all the DLLs in the path - saves repeated searching lower down
156             my @dll_files
157 0           = map {$_->stringify}
158 0           map {path($_)->children ( qr /$Config::Config{so}$/)}
  0            
159             @exe_path;
160            
161 0           if (CASE_INSENSITIVE_OS) {
162             @dll_files = map {lc $_} @dll_files;
163             }
164            
165 0           my %dll_file_hash;
166 0           foreach my $file (@dll_files) {
167 0           my $basename = path($file)->basename;
168 0   0       $dll_file_hash{$basename} //= $file; # we only want the first in the path
169             }
170            
171            
172             # lc is dirty and underhanded
173             # - need to find a different approach to get
174             # canonical file name while handling case,
175             # poss Win32::GetLongPathName
176 0           my @dlls = @$argv_linkers;
177 0           push @dlls,
178             $self->get_dep_dlls;
179            
180 0           if (CASE_INSENSITIVE_OS) {
181             @dlls = map {path ($_)->stringify} map {lc $_} @dlls;
182             }
183             #say join "\n", @dlls;
184            
185 0           my $re_skippers = $self->get_dll_skipper_regexp();
186 0           my %full_list;
187             my %searched_for;
188 0           my $iter = 0;
189            
190 0           my @missing;
191            
192             DLL_CHECK:
193 0           while (1) {
194 0           $iter++;
195 0           say "DLL check iter: $iter";
196             #say join ' ', @dlls;
197             my ( $stdout, $stderr, $exit ) = capture {
198 0     0     system( $OBJDUMP, '-p', @dlls );
199 0           };
200 0 0         if( $exit ) {
201 0           $stderr =~ s{\s+$}{};
202 0           warn "(@dlls):$exit: $stderr ";
203 0           exit;
204             }
205 0           @dlls = $stdout =~ /DLL.Name:\s*(\S+)/gmi;
206            
207 0           if (CASE_INSENSITIVE_OS) {
208             @dlls = map {lc $_} @dlls;
209             }
210            
211             # extra grep appears wasteful but useful for debug
212             # since we can easily disable it
213             @dlls
214             = sort
215 0           grep {!exists $full_list{$_}}
216 0           grep {$_ !~ /$re_skippers/}
  0            
217             uniq
218             @dlls;
219            
220 0 0         if (!@dlls) {
221 0           say 'no more DLLs';
222 0           last DLL_CHECK;
223             }
224            
225 0           my @dll2;
226 0           foreach my $file (@dlls) {
227 0 0         next if $searched_for{$file};
228            
229 0 0         if (exists $dll_file_hash{$file}) {
230 0           push @dll2, $dll_file_hash{$file};
231             }
232             else {
233 0           push @missing, $file;
234             }
235            
236 0           $searched_for{$file}++;
237             }
238 0           @dlls = uniq @dll2;
239 0           my $key_count = keys %full_list;
240 0           @full_list{@dlls} = (1) x @dlls;
241            
242             # did we add anything new?
243 0 0         last DLL_CHECK if $key_count == scalar keys %full_list;
244             }
245            
246 0           my @l2 = sort keys %full_list;
247            
248 0 0         if (@missing) {
249 0           my @missing2;
250             MISSING:
251 0           foreach my $file (uniq @missing) {
252             next MISSING
253 0 0   0     if any {; -e "$_/$file"} @system_paths;
  0            
254 0           push @missing2, $file;
255             }
256            
257 0 0         if (@missing2) {
258             say STDERR "\nUnable to locate these DLLS, packed script might not work: "
259 0           . join ' ', sort {$a cmp $b} @missing2;
  0            
260 0           say '';
261             }
262             }
263            
264 0 0         return wantarray ? @l2 : \@l2;
265             }
266            
267             sub _resolve_rpath_mac {
268 0     0     my ($source, $target) = @_;
269            
270 0           say "Resolving rpath for $source wrt $target";
271            
272             # clean up the target
273 0           $target =~ s|\@rpath/||;
274            
275 0           my @results = qx /otool -l $source/;
276 0           while (my $line = shift @results) {
277 0 0         last if $line =~ /LC_RPATH/;
278             }
279 0           my @lc_rpath_chunk;
280 0           while (my $line = shift @results) {
281 0 0         last if $line =~ /LC_/; # any other command
282 0           push @lc_rpath_chunk, $line;
283             }
284             my @paths
285 0           = map {s/\s\(offset.+$//r}
286 0           map {s/^\s+path //r}
287 0           grep {/^\s+path/}
  0            
288             @lc_rpath_chunk;
289 0           my $loader_path = path ($source)->parent->stringify;
290 0           my @checked_paths;
291 0           foreach my $path (@paths) {
292 0           chomp $path; # should be done above
293 0           $path =~ s/\@loader_path/$loader_path/;
294 0           $path = path($path, $target);
295 0 0         if ($path->exists) {
296 0           $path = $path->realpath->stringify;
297 0           push @checked_paths, $path;
298             }
299             }
300            
301             # should handle multiple paths
302 0           return $checked_paths[0];
303             }
304            
305             sub _resolve_loader_path_mac {
306 0     0     my ($source, $target) = @_;
307 0           say "Resolving loader_path for $source wrt $target";
308 0           my $source_path = path($source)->parent->stringify;
309 0           $target =~ s/\@loader_path/$source_path/;
310 0           return $target;
311             }
312            
313            
314             sub get_autolink_list_macos {
315 0     0 0   my ($self) = @_;
316            
317 0           my $argv_linkers = $self->{argv_linkers};
318            
319 0 0         my $OTOOL = which('otool') or die "otool not found";
320            
321 0           my @bundle_list = $self->get_dep_dlls;
322 0           my @libs_to_pack;
323             my %seen;
324            
325 0           my @target_libs = (
326             @$argv_linkers,
327             @bundle_list,
328             #'/usr/local/opt/libffi/lib/libffi.6.dylib',
329             #($pixbuf_query_loader,
330             #find_so_files ($gdk_pixbuf_dir) ) if $pack_gdkpixbuf,
331             );
332 0           while (my $lib = shift @target_libs) {
333 0           say "otool -L $lib";
334 0           my @lib_arr = qx /otool -L $lib/;
335 0 0         warn qq["otool -L $lib" failed\n]
336             if not $? == 0;
337 0           shift @lib_arr; # first result is dylib we called otool on
338             DEP_LIB:
339 0           foreach my $line (@lib_arr) {
340 0           $line =~ /^\s+(.+?)\s/;
341 0           my $dylib = $1;
342 0 0         if ($dylib =~ /\@rpath/i) {
    0          
343 0           my $orig_name = $dylib;
344 0           $dylib = _resolve_rpath_mac($lib, $dylib);
345 0 0         if (!defined $dylib) {
346 0           say STDERR "Cannot resolve rpath for $orig_name, dependency of $lib";
347 0           next DEP_LIB;
348             }
349             }
350             elsif ($dylib =~ /\@loader_path/) {
351 0           my $orig_name = $dylib;
352 0           $dylib = _resolve_loader_path_mac($lib, $dylib);
353             }
354 0 0         next if $seen{$dylib};
355 0 0         next if $dylib =~ m{^/System}; # skip system libs
356             #next if $dylib =~ m{^/usr/lib/system};
357 0 0         next if $dylib =~ m{^/usr/lib/libSystem};
358 0 0         next if $dylib =~ m{^/usr/lib/};
359 0 0         next if $dylib =~ m{\Qdarwin-thread-multi-2level/auto/share/dist/Alien\E}; # another alien
360 0           say "adding $dylib for $lib";
361 0           push @libs_to_pack, $dylib;
362 0           $seen{$dylib}++;
363             # add this dylib to the search set
364 0           push @target_libs, $dylib;
365             }
366             }
367            
368 0           @libs_to_pack = sort @libs_to_pack;
369            
370 0 0         return wantarray ? @libs_to_pack : \@libs_to_pack;
371             }
372            
373             sub get_autolink_list_ldd {
374 0     0 0   my ($self) = @_;
375            
376 0           my $argv_linkers = $self->{argv_linkers};
377            
378 0           my @bundle_list = $self->get_dep_dlls;
379 0           my @libs_to_pack;
380             my %seen;
381            
382 0           my $RE_skip = $self->get_ldd_skipper_regexp;
383            
384 0           my @target_libs = (
385             @$argv_linkers,
386             @bundle_list,
387             );
388 0           while (my $lib = shift @target_libs) {
389 0 0         if ($lib =~ $RE_skip) {
390 0           say "skipping $lib";
391 0           next;
392             }
393            
394 0           say "ldd $lib";
395 0           my $out = qx /ldd $lib/;
396 0 0         warn qq["ldd $lib" failed\n]
397             if not $? == 0;
398            
399             # much of this logic is from PAR::Packer
400             # https://github.com/rschupp/PAR-Packer/blob/04a133b034448adeb5444af1941a5d7947d8cafb/myldr/find_files_to_embed/ldd.pl#L47
401 0           my %dlls = $out =~ /^ \s* (\S+) \s* => \s* ( \/ \S+ ) /gmx;
402            
403             DLL:
404 0           foreach my $name (keys %dlls) {
405             #say "$name, $dlls{$name}";
406 0 0 0       if ($seen{$name} or $name =~ $RE_skip) {
407 0           delete $dlls{$name};
408 0           next DLL;
409             }
410            
411 0           $seen{$name}++;
412            
413 0           my $path = path($dlls{$name})->realpath;
414            
415             #say "Checking $name => $path";
416            
417 0 0 0       if (not -r $path) {
    0 0        
418 0           warn qq[# ldd reported strange path: $path\n];
419 0           delete $dlls{$name};
420             }
421             elsif (
422             #$path =~ m{^(?:/usr)?/lib(?:32|64)?/} # system lib
423             $path =~ $RE_skip
424             or $path =~ m{\Qdarwin-thread-multi-2level/auto/share/dist/Alien\E} # alien in share
425             or $name =~ m{^lib(?:c|gcc_s|stdc\+\+)\.} # should already be packed?
426             ) {
427             #say "skipping $name => $path";
428             #warn "re1" if $path =~ m{^(?:/usr)?/lib(?:32|64)/};
429             #warn "re2" if $path =~ m{\Qdarwin-thread-multi-2level/auto/share/dist/Alien\E};
430             #warn "re3" if $name =~ m{^lib(?:gcc_s|stdc\+\+)\.};
431 0           delete $dlls{$name};
432             }
433             }
434 0           push @target_libs, sort values %dlls;
435 0           push @libs_to_pack, sort values %dlls;
436             }
437            
438 0           @libs_to_pack = sort @libs_to_pack;
439            
440 0 0         return wantarray ? @libs_to_pack : \@libs_to_pack;
441             }
442            
443            
444             # needed for gdkpixbuf, when we support it
445             sub find_so_files {
446 0     0 0   my ($self, $target_dir) = @_;
447 0 0         return if !defined $target_dir;
448            
449 0           my @files = File::Find::Rule->extras({ follow => 1, follow_skip=>2 })
450             ->file()
451             ->name( qr/\.so$/ )
452             ->in( $target_dir );
453 0 0         return wantarray ? @files : \@files;
454             }
455            
456             sub get_ldd_skipper_regexp {
457 0     0 0   my ($self) = @_;
458 0           my @skip = qw /libm libc libpthread libdl/;
459 0           my $sk = join '|', @skip;
460 0           my $qr_skip = qr {\b(?:$sk)\.$Config::Config{so}};
461            
462 0           return $qr_skip;
463             }
464            
465             sub get_dll_skipper_regexp {
466 0     0 0   my ($self) = @_;
467            
468             # PAR packs these automatically these days.
469 0           my @skip = qw /
470             perl5\d\d
471             libstdc\+\+\-6
472             libgcc_s_seh\-1
473             libwinpthread\-1
474             libgcc_s_sjlj\-1
475             /;
476 0           my $sk = join '|', @skip;
477 0           my $qr_skip = qr /^(?:$sk)$RE_DLL_EXT$/;
478 0           return $qr_skip;
479             }
480            
481             # find dependent dlls
482             # could also adapt some of Module::ScanDeps::_compile_or_execute
483             # as it handles more edge cases
484             sub get_dep_dlls {
485 0     0 0   my ($self) = @_;
486            
487 0           my $script = $self->{script_fullname};
488 0           my $no_execute_flag = $self->{no_execute_flag};
489 0           my $alien_sys_installs = $self->{alien_sys_installs};
490 0           my $cache_file = $self->{cache_file};
491            
492             # This is clunky:
493             # make sure $script/../lib is in @INC
494             # assume script is in a bin folder
495 0           my $rlib_path = (path ($script)->parent->parent->stringify) . '/lib';
496             #say "======= $rlib_path/lib ======";
497 0 0         local @INC = (@INC, $rlib_path)
498             if -d $rlib_path;
499            
500 0           my $deps_hash = scan_deps(
501             files => [ $script ],
502             recurse => 1,
503             execute => !$no_execute_flag,
504             cache_file => $cache_file,
505             );
506            
507             #my @lib_paths
508             # = map {path($_)->absolute}
509             # grep {defined} # needed?
510             # @Config{qw /installsitearch installvendorarch installarchlib/};
511             #say join ' ', @lib_paths;
512             my @lib_paths
513 0           = reverse sort {length $a <=> length $b}
514 0           map {path($_)->absolute}
  0            
515             @INC;
516            
517 0           my $paths = join '|', map {quotemeta} map {path($_)->stringify} @lib_paths;
  0            
  0            
518 0           my $inc_path_re = qr /^($paths)/i;
519             #say $inc_path_re;
520            
521             #say "DEPS HASH:" . join "\n", keys %$deps_hash;
522 0           my %dll_hash;
523             my @aliens;
524 0           foreach my $package (keys %$deps_hash) {
525 0           my $details = $deps_hash->{$package};
526 0   0       my @uses = @{$details->{uses} // []};
  0            
527 0 0         if ($details->{key} =~ m{^Alien/.+\.pm$}) {
528 0           push @aliens, $package;
529             }
530            
531             push @uses, $package
532 0 0         if $details->{file} =~ $RE_DLL_EXT;
533            
534 0 0         next if !@uses;
535            
536 0           foreach my $dll (grep {$_ =~ $RE_DLL_EXT} @uses) {
  0            
537 0           my $dll_path = path($deps_hash->{$package}{file})->stringify;
538 0           my $inc_path;
539 0 0         if ($dll_path =~ m/$inc_path_re/) {
540 0           $inc_path = $1;
541             }
542             else {
543             # fallback, get inc_path as all before /lib/
544 0           $inc_path = ($dll_path =~ s|(?<=/lib/).+?$||r);
545             }
546             # if the path is relative then we need to prepend the inc_path
547 0 0         $dll_path = path($dll)->is_absolute
548             ? $dll
549             : path ($inc_path, $dll)->stringify;
550             # We were getting double paths under SP 5.36.
551             # It should be fixed now but leave here just in case.
552 0 0         if ($dll_path =~ /^\w:.+:/){
553 0           warn "Fixing double dir path: $dll_path}";
554 0           $dll_path =~ s/^.+(.):/$1:/;
555             }
556             #say $dll_path;
557 0 0         croak "either cannot find or cannot read $dll_path "
558             . "for package $package"
559             if not -r $dll_path;
560 0           $dll_hash{$dll_path}++;
561             }
562             }
563             # handle aliens
564             ALIEN:
565 0           foreach my $package (@aliens) {
566 0 0         next if $package =~ m{^Alien/(Base|Build)};
567 0           my $package_inc_name = $package;
568 0           $package =~ s{/}{::}g;
569 0           $package =~ s/\.pm$//;
570 0 0         if (!$INC{$package_inc_name}) {
571             # if the execute flag was off then try to load the package
572 0           eval "require $package";
573 0 0         if ($@) {
574 0           say "Unable to require $package, skipping (error is $@)";
575 0           next ALIEN;
576             }
577             }
578             # some older aliens might do different things
579 0 0         next ALIEN if !$package->isa ('Alien::Base');
580 0           say "Finding dynamic libs for $package";
581 0           foreach my $path ($package->dynamic_libs) {
582             # warn $path;
583 0           $dll_hash{$path}++;
584             }
585 0 0         if ($package->install_type eq 'system') {
586 0           push @$alien_sys_installs, $package->dynamic_libs;
587             }
588 0           push @{$self->{alien_deps}}, $package;
  0            
589             }
590            
591 0           my @dll_list = sort keys %dll_hash;
592 0 0         return wantarray ? @dll_list : \@dll_list;
593             }
594            
595            
596             1;
597            
598             __END__