Hello,
if anyone is interested, here is what I am testing at the moment. Added cache_cb
to M::SD as described before and using it from PAR-Packer. PAR-Packer gets a
cd|cachedeps (filename) option.
I use it like 'pp -cd deps.dat -more_options script.pl' or
'pp -cd deps.dat -o test.exe -e "use Tk; tkinit; MainLoop;" 'Works fine for me.
Thanks you for any comments or suggestions.
Cheers Christoph
--- C:\DOKUME~1\chris\LOKALE~1\Temp\ScanDeps.pm-revBASE.svn001.tmp.pm Fr Jul
3 16:08:10 2009
+++ C:\devel\M-SD_wc\trunk\lib\Module\ScanDeps.pm Fr Jul 3 13:27:10 2009
@@ -2,7 +2,8 @@
use 5.006;
use strict;
use vars qw( $VERSION @EXPORT @EXPORT_OK @ISA $CurrentPackage @IncludeLibs
$ScanFileRE );
-
+warn "testing cached M::SD\n";
+use warnings;
$VERSION = '0.91';
@EXPORT = qw( scan_deps scan_deps_runtime );
@EXPORT_OK = qw( scan_line scan_chunk add_deps scan_deps_runtime
path_to_inc_name );
@@ -499,7 +500,7 @@
return $inc_name;
}
-my $Keys = 'files|keys|recurse|rv|skip|first|execute|compile|warn_missing';
+my $Keys =
'files|keys|recurse|rv|skip|first|execute|compile|warn_missing|cache_cb';
sub scan_deps {
my %args = (
rv => {},
@@ -560,8 +561,12 @@
sub scan_deps_static {
my ($args) = @_;
- my ($files, $keys, $recurse, $rv, $skip, $first, $execute, $compile,
$_skip) =
- @$args{qw( files keys recurse rv skip first execute compile _skip )};
+ my ($files, $keys, $recurse, $rv,
+ $skip, $first, $execute, $compile,
+ $cache_cb, $_skip)
+ = @$args{qw( files keys recurse rv
+ skip first execute compile
+ cache_cb _skip )};
$rv ||= {};
$_skip ||= { %{$skip || {}} };
@@ -573,66 +578,62 @@
and $file ne lc($file) and $_skip->{lc($file)}++;
next unless $file =~ $ScanFileRE;
- local *FH;
- open FH, $file or die "Cannot open $file: $!";
+ my @pm;
+ my $found_in_cache;
+ if ($cache_cb){
+ my $pm_aref;
+ # cache_cb populates \...@pm on success
+ $found_in_cache = $cache_cb->(action => 'read',
+ key => $key,
+ file => $file,
+ modules => \...@pm,
+ );
+ unless( $found_in_cache ){
+ @pm = scan_file($file);
+ $cache_cb->(action => 'write',
+ key => $key,
+ file => $file,
+ modules => \...@pm,
+ );
+ }
+ }else{ # no caching callback given
+ @pm = scan_file($file);
+ }
+
+ foreach my $pm (@pm){
+ add_deps(
+ used_by => $key,
+ rv => $args->{rv},
+ modules => [$pm],
+ skip => $args->{skip},
+ warn_missing => $args->{warn_missing},
+ );
- $SeenTk = 0;
- # Line-by-line scanning
- LINE:
- while (<FH>) {
- chomp(my $line = $_);
- foreach my $pm (scan_line($line)) {
- last LINE if $pm eq '__END__';
+ my $preload = _get_preload($pm) or next;
- # Skip Tk hits from Term::ReadLine and Tcl::Tk
- my $pathsep = qr/\/|\\|::/;
- if ($pm =~ /^Tk\b/) {
- next if $file =~
/(?:^|${pathsep})Term${pathsep}ReadLine\.pm$/;
- next if $file =~ /(?:^|${pathsep})Tcl${pathsep}Tk\W/;
- }
-
- if ($pm eq '__POD__') {
- while (<FH>) { last if (/^=cut/) }
- next LINE;
- }
-
- $pm = 'CGI/Apache.pm' if $file =~ /^Apache(?:\.pm)$/;
-
- add_deps(
- used_by => $key,
- rv => $args->{rv},
- modules => [$pm],
- skip => $args->{skip},
- warn_missing => $args->{warn_missing},
- );
-
- my $preload = _get_preload($pm) or next;
-
- add_deps(
- used_by => $key,
- rv => $args->{rv},
- modules => $preload,
- skip => $args->{skip},
- warn_missing => $args->{warn_missing},
- );
- }
+ add_deps(
+ used_by => $key,
+ rv => $args->{rv},
+ modules => $preload,
+ skip => $args->{skip},
+ warn_missing => $args->{warn_missing},
+ );
}
- close FH;
-
- # }}}
}
# Top-level recursion handling {{{
+
while ($recurse) {
my $count = keys %$rv;
my @files = sort grep -T $_->{file}, values %$rv;
scan_deps_static({
- files => [ map $_->{file}, @files ],
- keys => [ map $_->{key}, @files ],
- rv => $rv,
- skip => $skip,
- recurse => 0,
- _skip => $_skip,
+ files => [ map $_->{file}, @files ],
+ keys => [ map $_->{key}, @files ],
+ rv => $rv,
+ skip => $skip,
+ recurse => 0,
+ cache_cb => $cache_cb,
+ _skip => $_skip,
}) or ($args->{_deep} and return);
last if $count == keys %$rv;
}
@@ -689,6 +690,43 @@
return ($rv);
}
+sub scan_file{
+ my $file = shift;
+ my %found;
+ my $FH;
+ open $FH, $file or die "Cannot open $file: $!";
+
+ $SeenTk = 0;
+ # Line-by-line scanning
+ LINE:
+ while (<$FH>) {
+ chomp(my $line = $_);
+ foreach my $pm (scan_line($line)) {
+ last LINE if $pm eq '__END__';
+
+ # Skip Tk hits from Term::ReadLine and Tcl::Tk
+ my $pathsep = qr/\/|\\|::/;
+ if ($pm =~ /^Tk\b/) {
+ next if $file =~ /(?:^|${pathsep})Term${pathsep}ReadLine\.pm$/;
+ next if $file =~ /(?:^|${pathsep})Tcl${pathsep}Tk\W/;
+ }
+ if ($pm eq '__POD__') {
+ while (<$FH>) {
+ last if (/^=cut/);
+ }
+ next LINE;
+ }
+ $SeenTk || do{$SeenTk = 1 if $pm =~ /Tk\.pm$/;};
+ # the following line does not make much sense here ???
+ # $file is an absolute path and will never match
+ #$pm = 'CGI/Apache.pm' if $file =~ /^Apache(?:\.pm)$/;
+ $found{$pm}++;
+ }
+ }
+ close $FH or die "Cannot close $file: $!";
+ return keys %found;
+}
+
sub scan_line {
my $line = shift;
my %found;
@@ -708,7 +746,8 @@
# use VERSION:
if (/^\s*(?:use|require)\s+([\d\._]+)/) {
# include feaure.pm if we have 5.9.5 or better
- if (version->new($1) >= version->new("5.9.5")) { # seems to catch
5.9, too (but not 5.9.4)
+ if (version->new($1) >= version->new("5.9.5")) {
+ # seems to catch 5.9, too (but not 5.9.4)
return "feature.pm";
}
}
@@ -881,6 +920,7 @@
}
}
}
+
$rv->{$module} ||= {
file => $file,
key => $module,
@@ -939,6 +979,7 @@
$type = 'shared' if $ext eq lc(dl_ext());
$type = 'autoload' if ($ext eq '.ix' or $ext eq '.al');
$type ||= 'data';
+
_add_info( rv => $rv, module =>
"auto/$path/$_->{name}",
file => $_->{file}, used_by => $module,
type => $type );
--- C:\DOKUME~1\chris\LOKALE~1\Temp\Packer.pm-revBASE.svn000.tmp.pm Fr Jul
3 16:05:38 2009
+++ C:\devel\PAR-Packer_wc\trunk\lib\PAR\Packer.pm Do Jul 2 22:13:45 2009
@@ -35,7 +35,9 @@
use Module::ScanDeps ();
use PAR ();
use PAR::Filter ();
-
+use Storable;
+use Digest::MD5;
+use Carp;
use constant OPTIONS => {
'a|addfile:s@' => 'Additional files to pack',
'A|addlist:s@' => 'File containing list of additional files to pack',
@@ -69,6 +71,7 @@
'vv|verbose2', => 'Verbosity level 2',
'vvv|verbose3', => 'Verbosity level 3',
'z|compress:i' => 'Compression level',
+ 'cd|cachedeps:s' => 'Cache detected dependencies in a file',
};
my $ValidOptions = {};
@@ -657,7 +660,14 @@
my $root = '';
$root = "$Config{archname}/" if ($opt->{m});
$self->{pack_attrib}{root} = '';
-
+ my $cachefile = '';
+ my $use_cache = 0;
+ my @cache_cb;
+ $cachefile = $opt->{cachedeps} if ($opt->{cachedeps});
+ if ($cachefile){
+ _init_cache($cachefile);
+ @cache_cb = (cache_cb => \&_cache_cb);
+ }
my $par_file = $self->{par_file};
my (@modules, @data, @exclude);
@@ -726,12 +736,14 @@
? $self->_obj_function($fe, 'scan_deps_runtime')
: $self->_obj_function($fe, 'scan_deps');
+
$scan_dispatch->(
- rv => \%map,
- files => \...@files,
- execute => $opt->{x},
- compile => $opt->{c},
- skip => \%skip,
+ rv => \%map,
+ files => \...@files,
+ execute => $opt->{x},
+ compile => $opt->{c},
+ skip => \%skip,
+ @cache_cb,
($opt->{n}) ? () : (
recurse => 1,
first => 1,
@@ -873,7 +885,9 @@
$dep_manifest->{'MANIFEST'} = [ string => "<<placeholder>>" ];
$dep_manifest->{'META.yml'} = [ string => "<<placeholder>>" ];
-
+ if ($cachefile){
+ _store_cache($cachefile);
+ }
return ($dep_manifest);
}
@@ -1650,6 +1664,70 @@
unlink $self->{parl} if $self->{parl_is_temporary};
}
+{
+my $cache;
+sub _init_cache{
+ my $file = shift;
+ eval{$cache = retrieve($file)};
+ warn $@ if ($@);
+ unless ($cache){
+ warn "Couldn't retrieve data from file $file. Building new cache.";
+ $cache = {};
+ }
+}
+
+sub _store_cache{
+ my $file = shift;
+ Storable::nstore($cache, $file)
+ or warn "Could not store cache to file $file!";
+}
+
+sub _cache_cb{
+ my %args = @_;
+ if ( $args{action} eq 'read' ){
+ return _read_cache( %args );
+ }
+ elsif ( $args{action} eq 'write' ){
+ return _write_cache( %args );
+ }
+ croak "action must be read or write\n";
+}
+
+sub _read_cache{
+ my %args = @_;
+ my ($key, $file, $mod_aref) = @args{qw/key file modules/};
+ return 0 unless (exists $cache->{$key});
+ ### we have an entry - check MD5
+ my $entry = $cache->{$key};
+ my $checksum = _file_2_md5($file);
+ if ($entry->{checksum} eq $checksum){
+ @$mod_aref = @{$entry->{modules}};
+ return 1;
+ }
+ return 0;
+}
+
+sub _write_cache{
+ my %args = @_;
+ my ($key, $file, $mod_aref) = @args{qw/key file modules/};
+ my $entry = $cache->{$key} ||= {};
+ my $checksum = _file_2_md5($file);
+ $entry->{checksum} = $checksum;
+ $entry->{modules} = [...@$mod_aref];
+ return 1;
+}
+
+sub _file_2_md5{
+ my $file = shift;
+ open my $fh, '<', $file or die "can't open $file: $!";
+ my $md5 = Digest::MD5->new;
+ $md5->addfile($fh);
+ close $fh or die "can't close $file: $!";
+ return $md5->hexdigest;
+}
+}
+
+
1;
=head1 SEE ALSO
