r40186 - in /branches/upstream/libmodule-scandeps-perl/current: AUTHORS Changes MANIFEST META.yml lib/Module/ScanDeps.pm lib/Module/ScanDeps/Cache.pm script/scandeps.pl t/14-scan_chunk.t t/14-static_functional_cached.t t/Utils.pm
ansgar-guest at users.alioth.debian.org
ansgar-guest at users.alioth.debian.org
Sun Jul 19 17:11:44 UTC 2009
Author: ansgar-guest
Date: Sun Jul 19 17:11:36 2009
New Revision: 40186
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=40186
Log:
[svn-upgrade] Integrating new upstream version, libmodule-scandeps-perl (0.93)
Added:
branches/upstream/libmodule-scandeps-perl/current/lib/Module/ScanDeps/Cache.pm
branches/upstream/libmodule-scandeps-perl/current/t/14-scan_chunk.t
branches/upstream/libmodule-scandeps-perl/current/t/14-static_functional_cached.t
Modified:
branches/upstream/libmodule-scandeps-perl/current/AUTHORS
branches/upstream/libmodule-scandeps-perl/current/Changes
branches/upstream/libmodule-scandeps-perl/current/MANIFEST
branches/upstream/libmodule-scandeps-perl/current/META.yml
branches/upstream/libmodule-scandeps-perl/current/lib/Module/ScanDeps.pm
branches/upstream/libmodule-scandeps-perl/current/script/scandeps.pl
branches/upstream/libmodule-scandeps-perl/current/t/Utils.pm
Modified: branches/upstream/libmodule-scandeps-perl/current/AUTHORS
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmodule-scandeps-perl/current/AUTHORS?rev=40186&op=diff
==============================================================================
--- branches/upstream/libmodule-scandeps-perl/current/AUTHORS (original)
+++ branches/upstream/libmodule-scandeps-perl/current/AUTHORS Sun Jul 19 17:11:36 2009
@@ -6,6 +6,7 @@
Adam Kennedy (ADAMK)
Adrian Issott
Alan Stewart
+Alexandr Ciornii (CHORNY)
Andrew Lee
Brian Cassidy (BRICAS)
Bruce Winter
Modified: branches/upstream/libmodule-scandeps-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmodule-scandeps-perl/current/Changes?rev=40186&op=diff
==============================================================================
--- branches/upstream/libmodule-scandeps-perl/current/Changes (original)
+++ branches/upstream/libmodule-scandeps-perl/current/Changes Sun Jul 19 17:11:36 2009
@@ -1,3 +1,13 @@
+[Changes for 0.93 - 2009-07-19]
+* Implement caching of dependencies (Christoph Lamprecht)
+
+[Changes for 0.92 - 2009-07-19]
+* Fix bug with {type} being set to unexpected values in some cases (Christoph Lamprecht)
+* Add tests for scan_chunk (Alexandr Ciornii)
+* Add special case for parent.pm (Alexandr Ciornii)
+* Fix for "use parent::something" (Alexandr Ciornii)
+* Add special case for Catalyst.pm (Alexandr Ciornii)
+
[Changes for 0.91 - 2009-06-22]
* Add special case for Tk's setPalette call (Christoph Lamprecht)
Modified: branches/upstream/libmodule-scandeps-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmodule-scandeps-perl/current/MANIFEST?rev=40186&op=diff
==============================================================================
--- branches/upstream/libmodule-scandeps-perl/current/MANIFEST (original)
+++ branches/upstream/libmodule-scandeps-perl/current/MANIFEST Sun Jul 19 17:11:36 2009
@@ -10,6 +10,7 @@
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
lib/Module/ScanDeps.pm
+lib/Module/ScanDeps/Cache.pm
lib/Module/ScanDeps/DataFeed.pm
Makefile.PL
MANIFEST This list of files
@@ -22,6 +23,8 @@
t/11-finds-shared-lib.t
t/12-ScanFileRE.t
t/13-static_prefork_test.t
+t/14-scan_chunk.t
+t/14-static_functional_cached.t
t/2-static_functional_interface_fake.t
t/3-static_oo_interface_real.t
t/4-static_functional_interface_options_fake.t
Modified: branches/upstream/libmodule-scandeps-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmodule-scandeps-perl/current/META.yml?rev=40186&op=diff
==============================================================================
--- branches/upstream/libmodule-scandeps-perl/current/META.yml (original)
+++ branches/upstream/libmodule-scandeps-perl/current/META.yml Sun Jul 19 17:11:36 2009
@@ -27,4 +27,4 @@
resources:
license: http://dev.perl.org/licenses/
repository: http://svn.openfoundry.org/par/Module-ScanDeps/trunk/
-version: 0.91
+version: 0.93
Modified: branches/upstream/libmodule-scandeps-perl/current/lib/Module/ScanDeps.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmodule-scandeps-perl/current/lib/Module/ScanDeps.pm?rev=40186&op=diff
==============================================================================
--- branches/upstream/libmodule-scandeps-perl/current/lib/Module/ScanDeps.pm (original)
+++ branches/upstream/libmodule-scandeps-perl/current/lib/Module/ScanDeps.pm Sun Jul 19 17:11:36 2009
@@ -1,10 +1,10 @@
package Module::ScanDeps;
-
use 5.006;
use strict;
+use warnings;
use vars qw( $VERSION @EXPORT @EXPORT_OK @ISA $CurrentPackage @IncludeLibs $ScanFileRE );
-$VERSION = '0.91';
+$VERSION = '0.93';
@EXPORT = qw( scan_deps scan_deps_runtime );
@EXPORT_OK = qw( scan_line scan_chunk add_deps scan_deps_runtime path_to_inc_name );
@@ -96,9 +96,9 @@
=head2 B<scan_deps>
$rv_ref = scan_deps(
- files => \@files, recurse => $recurse,
- rv => \%rv, skip => \%skip,
- compile => $compile, execute => $execute,
+ files => \@files, recurse => $recurse,
+ rv => \%rv, skip => \%skip,
+ compile => $compile, execute => $execute,
);
$rv_ref = scan_deps(@files); # shorthand, with recurse => 1
@@ -119,6 +119,10 @@
If C<$execute> is an array reference, runs the files contained
in it instead of C<@files>.
+
+If performance of the scanning process is a concern, C<cache_file> can be
+set to a filename. The scanning results will be cached and written to the
+file. This will speed up the scanning process on subsequent runs.
Additionally, an option C<warn_missing> is recognized. If set to true,
C<scan_deps> issues a warning to STDERR for every module file that the
@@ -500,7 +504,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|cache_file';
sub scan_deps {
my %args = (
rv => {},
@@ -510,7 +514,21 @@
if (!defined($args{keys})) {
$args{keys} = [map {path_to_inc_name($_, $args{warn_missing})} @{$args{files}}];
}
-
+ my $cache_file = $args{cache_file};
+ my $using_cache;
+ if ($cache_file) {
+ require Module::ScanDeps::Cache;
+ $using_cache = Module::ScanDeps::Cache::init_from_file($cache_file);
+ if( $using_cache ){
+ $args{cache_cb} = Module::ScanDeps::Cache::get_cache_cb();
+ }else{
+ my @missing = Module::ScanDeps::Cache::prereq_missing();
+ warn join(' ',
+ "Can not use cache_file: Needs Modules [",
+ @missing,
+ "]\n",);
+ }
+ }
my ($type, $path);
foreach my $input_file (@{$args{files}}) {
if ($input_file !~ $ScanFileRE) {
@@ -518,8 +536,7 @@
next;
}
- $type = 'module';
- $type = 'data' unless $input_file =~ /\.p[mh]$/io;
+ $type = _gettype($input_file);
$path = $input_file;
if ($type eq 'module') {
# necessary because add_deps does the search for shared libraries and such
@@ -554,6 +571,10 @@
);
}
+ if ( $using_cache ){
+ Module::ScanDeps::Cache::store_cache();
+ }
+
# do not include the input files themselves as dependencies!
delete $args{rv}{$_} foreach @{$args{files}};
@@ -562,8 +583,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 || {}} };
@@ -575,66 +600,62 @@
and $file ne lc($file) and $_skip->{lc($file)}++;
next unless $file =~ $ScanFileRE;
- local *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;
- }
-
- $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},
- );
+ 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,
+ );
}
- }
- close FH;
-
- # }}}
+ }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},
+ );
+
+ 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},
+ );
+ }
}
# 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;
}
@@ -691,6 +712,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;
@@ -710,7 +768,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";
}
}
@@ -744,16 +803,21 @@
sub _typical_module_loader_chunk {
local $_ = shift;
my $loader = shift;
+ my $prefix='';
+ if (@_ and $_[0]) {
+ $prefix=$_[0].'::';
+ }
my $loader_file = $loader;
$loader_file =~ s/::/\//;
$loader_file .= ".pm";
$loader = quotemeta($loader);
- if (/^\s* use \s+ $loader \b \s* (.*)/sx) {
+ if (/^\s* use \s+ $loader(?!\:) \b \s* (.*)/sx) {
return [
$loader_file,
- map { s{::}{/}g; "$_.pm" }
- grep { length and !/^q[qw]?$/ } split(/[^\w:]+/, $1)
+ map { my $mod="$prefix$_";$mod=~s{::}{/}g; "$mod.pm" }
+ grep { length and !/^q[qw]?$/ and !/-/ } split(/[^\w:-]+/, $1)
+ #should skip any module name that contains '-', not split it in two
];
}
return();
@@ -768,8 +832,13 @@
# TODO: There's many more of these "loader" type modules on CPAN!
# scan for the typical module-loader modules
- foreach my $loader (qw(asa base prefork POE encoding maybe only::matching)) {
+ foreach my $loader (qw(asa base parent prefork POE encoding maybe only::matching)) {
my $retval = _typical_module_loader_chunk($_, $loader);
+ return $retval if $retval;
+ }
+
+ foreach my $loader (qw(Catalyst)) {
+ my $retval = _typical_module_loader_chunk($_, $loader,'Catalyst::Plugin');
return $retval if $retval;
}
@@ -925,8 +994,7 @@
next;
}
- my $type = 'module';
- $type = 'data' unless $file =~ /\.p[mh]$/i;
+ my $type = _gettype($file);
_add_info( rv => $rv, module => $module,
file => $file, used_by => $used_by,
type => $type );
@@ -937,10 +1005,11 @@
foreach (_glob_in_inc("auto/$path")) {
next if $_->{file} =~ m{\bauto/$path/.*/}; # weed out subdirs
next if $_->{name} =~ m/(?:^|\/)\.(?:exists|packlist)$/;
- my $ext = lc($1) if $_->{name} =~ /(\.[^.]+)$/;
+ my ($ext,$type);
+ $ext = lc($1) if $_->{name} =~ /(\.[^.]+)$/;
next if $ext eq lc(lib_ext());
- my $type = 'shared' if $ext eq lc(dl_ext());
- $type = 'autoload' if $ext eq '.ix' or $ext eq '.al';
+ $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}",
@@ -1202,7 +1271,7 @@
my $name = shift;
my $dlext = quotemeta(dl_ext());
- return 'autoload' if $name =~ /(?:\.ix|\.al|\.bs)$/i;
+ return 'autoload' if $name =~ /(?:\.ix|\.al)$/i;
return 'module' if $name =~ /\.p[mh]$/i;
return 'shared' if $name =~ /\.$dlext$/i;
return 'data';
Added: branches/upstream/libmodule-scandeps-perl/current/lib/Module/ScanDeps/Cache.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmodule-scandeps-perl/current/lib/Module/ScanDeps/Cache.pm?rev=40186&op=file
==============================================================================
--- branches/upstream/libmodule-scandeps-perl/current/lib/Module/ScanDeps/Cache.pm (added)
+++ branches/upstream/libmodule-scandeps-perl/current/lib/Module/ScanDeps/Cache.pm Sun Jul 19 17:11:36 2009
@@ -1,0 +1,97 @@
+package Module::ScanDeps::Cache;
+use strict;
+use warnings;
+my $has_DMD5;
+eval { require Digest::MD5 };
+$has_DMD5 = 1 unless $@;
+my $has_Storable;
+eval { require Storable };
+$has_Storable = 1 unless $@;
+
+
+my $cache;
+my $cache_file;
+my $cache_dirty;
+
+sub prereq_missing{
+ my @missing;
+ push @missing, 'Digest::MD5' unless $has_DMD5;
+ push @missing, 'Storable' unless $has_Storable;
+ return @missing;
+}
+
+sub init_from_file{
+ my $c_file = shift;
+ return 0 if prereq_missing();
+ eval{$cache = Storable::retrieve($c_file)};
+ #warn $@ if ($@);
+ unless ($cache){
+ warn "Couldn't retrieve data from file $c_file. Building new cache.\n";
+ $cache = {};
+ }
+ $cache_file = $c_file;
+ return 1;
+}
+
+sub store_cache{
+ my $c_file = shift || $cache_file;
+ # no need to store to the file we retrieved from
+ # unless we have seen changes written to the cache
+ return unless ($cache_dirty
+ || $c_file ne $cache_file);
+ Storable::nstore($cache, $c_file)
+ or warn "Could not store cache to file $c_file!";
+}
+
+sub get_cache_cb{
+ return sub{
+ my %args = @_;
+ if ( $args{action} eq 'read' ){
+ return _read_cache( %args );
+ }
+ elsif ( $args{action} eq 'write' ){
+ return _write_cache( %args );
+ }
+ die "action in cache_cb must be read or write!";
+ };
+}
+
+### check for existence of the entry
+### check for identity of the file
+### pass cached value in $mod_aref
+### return true in case of a hit
+
+sub _read_cache{
+ my %args = @_;
+ my ($key, $file, $mod_aref) = @args{qw/key file modules/};
+ return 0 unless (exists $cache->{$key});
+ 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];
+ $cache_dirty = 1;
+ 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;
+
Modified: branches/upstream/libmodule-scandeps-perl/current/script/scandeps.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmodule-scandeps-perl/current/script/scandeps.pl?rev=40186&op=diff
==============================================================================
--- branches/upstream/libmodule-scandeps-perl/current/script/scandeps.pl (original)
+++ branches/upstream/libmodule-scandeps-perl/current/script/scandeps.pl Sun Jul 19 17:11:36 2009
@@ -10,7 +10,7 @@
use subs qw( _name _modtree );
my %opts;
-getopts('BVRxce:', \%opts);
+getopts('BVRxce:C:', \%opts);
my (%map, %skip);
my $core = $opts{B};
@@ -26,7 +26,7 @@
push @ARGV, $filename;
}
-die "Usage: $0 [ -B ] [ -V ] [ -x | -c ] [ -R ] [ -e STRING | FILE ... ]\n" unless @ARGV;
+die "Usage: $0 [ -B ] [ -V ] [ -x | -c ] [ -R ] [-C FILE ] [ -e STRING | FILE ... ]\n" unless @ARGV;
my @files = @ARGV;
while (<>) {
@@ -40,6 +40,7 @@
$opts{x} ? ( execute => 1 ) :
$opts{c} ? ( compile => 1 ) : (),
$opts{V} ? ( warn_missing => 1 ) : (),
+ $opts{C} ? ( cache_file => $opts{C}) : (),
);
@@ -145,6 +146,7 @@
% scandeps.pl -B *.pm # Include core modules
% scandeps.pl -V *.pm # Show autoload/shared/data files
% scandeps.pl -R *.pm # Don't recurse
+ % scandeps.pl -C CACHEFILE # use CACHEFILE to cache dependencies
=head1 DESCRIPTION
@@ -202,6 +204,11 @@
dependencies that aren't really dependencies, you have probably found
false positives.
+=item -C CACHEFILE
+
+Use CACHEFILE to speed up the scanning process by caching dependencies.
+Creates CACHEFILE if it does not exist yet.
+
=back
=head1 SEE ALSO
Added: branches/upstream/libmodule-scandeps-perl/current/t/14-scan_chunk.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmodule-scandeps-perl/current/t/14-scan_chunk.t?rev=40186&op=file
==============================================================================
--- branches/upstream/libmodule-scandeps-perl/current/t/14-scan_chunk.t (added)
+++ branches/upstream/libmodule-scandeps-perl/current/t/14-scan_chunk.t Sun Jul 19 17:11:36 2009
@@ -1,0 +1,50 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+use Module::ScanDeps qw/scan_chunk/;
+
+{
+my $chunk=<<'EOT';
+use strict;
+EOT
+my @array=sort (scan_chunk($chunk));
+is_deeply(\@array,[sort qw{strict.pm}]);
+}
+
+{
+my $chunk=<<'EOT';
+use base qw(strict);
+EOT
+my @array=sort (scan_chunk($chunk));
+is_deeply(\@array,[sort qw{base.pm strict.pm}]);
+}
+
+{
+my $chunk=<<'EOT';
+use parent qw(strict);
+EOT
+my @array=sort (scan_chunk($chunk));
+is_deeply(\@array,[sort qw{parent.pm strict.pm}]);
+}
+
+{
+my $chunk=<<'EOT';
+use parent::doesnotexists qw(strict);
+EOT
+my @array=sort (scan_chunk($chunk));
+is_deeply(\@array,[sort qw{parent/doesnotexists.pm}]);
+}
+
+{
+my $chunk=<<'EOT';
+use Catalyst qw/-Debug ConfigLoader Session::State::Cookie/
+EOT
+#-Debug should be skipped
+my @array=sort (scan_chunk($chunk));
+is_deeply(\@array,[sort qw{Catalyst.pm Catalyst/Plugin/ConfigLoader.pm Catalyst/Plugin/Session/State/Cookie.pm}]);
+}
+
+
Added: branches/upstream/libmodule-scandeps-perl/current/t/14-static_functional_cached.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmodule-scandeps-perl/current/t/14-static_functional_cached.t?rev=40186&op=file
==============================================================================
--- branches/upstream/libmodule-scandeps-perl/current/t/14-static_functional_cached.t (added)
+++ branches/upstream/libmodule-scandeps-perl/current/t/14-static_functional_cached.t Sun Jul 19 17:11:36 2009
@@ -1,0 +1,382 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+use lib qw(t t/data/static);
+use Utils;
+use version;
+
+
+##############################################################
+# Tests compilation of Module::ScanDeps
+##############################################################
+BEGIN { use_ok( 'Module::ScanDeps' ); }
+
+
+
+##############################################################
+# Static dependency check of a script that doesn't use
+# anything with basic cache_cb test added
+##############################################################
+my @roots1 = qw(t/data/static/null.pl);
+my $expected_rv1 =
+{
+ "null.pl" => {
+ file => generic_abs_path("t/data/static/null.pl"),
+ key => "null.pl",
+ type => "data",
+ },
+};
+expected_cache_cb_args({key => 'null.pl',
+ file => 't/data/static/null.pl',
+ });
+
+my $rv1 = scan_deps(files => \@roots1,
+ cache_cb => \&cache_cb
+ );
+compare_scandeps_rvs($rv1, $expected_rv1, \@roots1);
+
+### check if we can use M::SD::Cache
+my $skip_cache_tests = 1;
+eval {require Module::ScanDeps::Cache;};
+unless ($@){
+ $skip_cache_tests = Module::ScanDeps::Cache::prereq_missing();
+ warn $skip_cache_tests, "\n";
+}
+my $cache_file = 'deps_cache.dat';
+
+for my $t(qw/write_cache use_cache/){
+
+ SKIP:
+ {
+ skip "Skipping M:SD::Cache tests" , 289 if $skip_cache_tests;
+
+ ##############################################################
+ # Static dependency check of a circular dependency:
+ # ___
+ # |/_ \
+ # M _M
+ # \____/|
+ #
+ ##############################################################
+ my @roots2 = qw(t/data/static/egg.pm);
+ my $expected_rv2 =
+ {
+ "chicken.pm" => {
+ file => generic_abs_path("t/data/static/chicken.pm"),
+ key => "chicken.pm",
+ type => "module",
+ used_by => ["egg.pm"],
+ uses => ["egg.pm"],
+ },
+ "egg.pm" => {
+ file => generic_abs_path("t/data/static/egg.pm"),
+ key => "egg.pm",
+ type => "module",
+ used_by => ["chicken.pm"],
+ uses => ["chicken.pm"],
+ },
+ };
+
+ # Functional i/f
+ my $rv2 = scan_deps(files => \@roots2,
+ cache_file => $cache_file,
+ recurse => 1,
+ );
+ compare_scandeps_rvs($rv2, $expected_rv2, \@roots2);
+
+ ##############################################################
+ # Static dependency check of the following dependency tree
+ #
+ # M
+ # /|\
+ # / | \
+ # / | \
+ # / M \
+ # / / \ \
+ # / / \ \
+ # M M M M
+ # \ \ / /
+ # \ \ / /
+ # \ M /
+ # \ | /
+ # \ | /
+ # M
+ #
+ # With dependencies always going from the top downwards
+ ##############################################################
+ my @roots3 = qw(t/data/static/outer_diamond_N.pm);
+ my $expected_rv3 =
+ {
+ "inner_diamond_E.pm" => {
+ file => generic_abs_path("t/data/static/inner_diamond_E.pm"),
+ key => "inner_diamond_E.pm",
+ type => "module",
+ used_by => ["inner_diamond_N.pm"],
+ uses => ["inner_diamond_S.pm"],
+ },
+ "inner_diamond_N.pm" => {
+ file => generic_abs_path("t/data/static/inner_diamond_N.pm"),
+ key => "inner_diamond_N.pm",
+ type => "module",
+ used_by => ["outer_diamond_N.pm"],
+ uses => ["inner_diamond_E.pm", "inner_diamond_W.pm"],
+ },
+ "inner_diamond_S.pm" => {
+ file => generic_abs_path("t/data/static/inner_diamond_S.pm"),
+ key => "inner_diamond_S.pm",
+ type => "module",
+ used_by => ["inner_diamond_W.pm", "inner_diamond_E.pm"],
+ uses => ["outer_diamond_S.pm"],
+ },
+ "inner_diamond_W.pm" => {
+ file => generic_abs_path("t/data/static/inner_diamond_W.pm"),
+ key => "inner_diamond_W.pm",
+ type => "module",
+ used_by => ["inner_diamond_N.pm"],
+ uses => ["inner_diamond_S.pm"],
+ },
+ "outer_diamond_E.pm" => {
+ file => generic_abs_path("t/data/static/outer_diamond_E.pm"),
+ key => "outer_diamond_E.pm",
+ type => "module",
+ used_by => ["outer_diamond_N.pm"],
+ uses => ["outer_diamond_S.pm"],
+ },
+ "outer_diamond_N.pm" => {
+ file => generic_abs_path("t/data/static/outer_diamond_N.pm"),
+ key => "outer_diamond_N.pm",
+ type => "module",
+ uses => ["inner_diamond_N.pm", "outer_diamond_E.pm", "outer_diamond_W.pm"],
+ },
+ "outer_diamond_S.pm" => {
+ file => generic_abs_path("t/data/static/outer_diamond_S.pm"),
+ key => "outer_diamond_S.pm",
+ type => "module",
+ used_by => ["outer_diamond_E.pm", "outer_diamond_W.pm", "inner_diamond_S.pm"],
+ },
+ "outer_diamond_W.pm" => {
+ file => generic_abs_path("t/data/static/outer_diamond_W.pm"),
+ key => "outer_diamond_W.pm",
+ type => "module",
+ used_by => ["outer_diamond_N.pm"],
+ uses => ["outer_diamond_S.pm"],
+ },
+ };
+
+ # Functional i/f
+ my $rv3 = scan_deps(cache_file => $cache_file,
+ recurse => 1,
+ files => \@roots3);
+ compare_scandeps_rvs($rv3, $expected_rv3, \@roots3);
+
+
+ ##############################################################
+ # Static dependency check of the following dependency tree
+ # (i.e. multiple inputs)
+ #
+ # InputA.pl InputB.pl InputC.pl
+ # / \ \ /
+ # / \ \ /
+ # / \ \ /
+ # TestA.pm TestB.pm TestC.pm /
+ # \ /
+ # \ /
+ # TestD.pm
+ #
+ ##############################################################
+ my @roots4 = qw(t/data/static/InputA.pl
+ t/data/static/InputB.pl
+ t/data/static/InputC.pl);
+ my $expected_rv4 =
+ {
+ "InputA.pl" => {
+ file => generic_abs_path("t/data/static/InputA.pl"),
+ key => "InputA.pl",
+ type => "data",
+ uses => ["TestA.pm", "TestB.pm"],
+ },
+ "InputB.pl" => {
+ file => generic_abs_path("t/data/static/InputB.pl"),
+ key => "InputB.pl",
+ type => "data",
+ uses => ["TestC.pm"],
+ },
+ "InputC.pl" => {
+ file => generic_abs_path("t/data/static/InputC.pl"),
+ key => "InputC.pl",
+ type => "data",
+ uses => ["TestD.pm"],
+ },
+ "TestA.pm" => {
+ file => generic_abs_path("t/data/static/TestA.pm"),
+ key => "TestA.pm",
+ type => "module",
+ used_by => ["InputA.pl"],
+ },
+ "TestB.pm" => {
+ file => generic_abs_path("t/data/static/TestB.pm"),
+ key => "TestB.pm",
+ type => "module",
+ used_by => ["InputA.pl"],
+ },
+ "TestC.pm" => {
+ file => generic_abs_path("t/data/static/TestC.pm"),
+ key => "TestC.pm",
+ type => "module",
+ used_by => ["InputB.pl"],
+ uses => ["TestD.pm"],
+ },
+ "TestD.pm" => {
+ file => generic_abs_path("t/data/static/TestD.pm"),
+ key => "TestD.pm",
+ type => "module",
+ used_by => ["InputC.pl", "TestC.pm"],
+ },
+ };
+
+ # Functional i/f
+ my $rv4 = scan_deps(cache_file => $cache_file,
+ recurse => 1,
+ files => \@roots4);
+ compare_scandeps_rvs($rv4, $expected_rv4, \@roots4);
+
+
+ ##############################################################
+ # Static dependency check of the following dependency tree
+ # Tests the .pm only lists the .pl once in it's used_by entries
+ #
+ # Duplicator.pl
+ # / \
+ # / \
+ # / \
+ # \ /
+ # \ /
+ # \ /
+ # Duplicated.pm
+ #
+ ##############################################################
+ my @roots5 = qw(t/data/static/Duplicator.pl);
+ my $expected_rv5 =
+ {
+ "Duplicated.pm" => {
+ file => generic_abs_path("t/data/static/Duplicated.pm"),
+ key => "Duplicated.pm",
+ type => "module",
+ used_by => ["Duplicator.pl"],
+ },
+ "Duplicator.pl" => {
+ file => generic_abs_path("t/data/static/Duplicator.pl"),
+ key => "Duplicator.pl",
+ type => "data",
+ uses => ["Duplicated.pm"],
+ },
+ };
+
+ # Functional i/f
+ my $rv5 = scan_deps(cache_file => $cache_file,
+ recurse => 1,
+ files => \@roots5);
+ compare_scandeps_rvs($rv5, $expected_rv5, \@roots5);
+
+
+ } ### SKIP block wrapping M::SD::Cache tests
+} ### end of for (qw/write_cache use_cache/)
+
+
+
+
+
+### cache testing helper functions ###
+{
+my ($cb_args, $expecting_write);
+
+sub expected_cache_cb_args{
+ $cb_args = shift;
+}
+sub cache_cb{
+ my %args = @_;
+ is($args{key}, $cb_args->{key}, "check arg 'key' in cache_cb.");
+ is($args{file}, $cb_args->{file}, "check arg 'file' in cache_cb.");
+ if ( $expecting_write ){
+ is($args{action}, 'write', "expecting write action");
+ }
+ if ($args{action} eq 'read'){
+ $expecting_write = 1;
+ return 0;
+ }
+ elsif ( $args{action} eq 'write' ){
+ $expecting_write = 0;
+ return 1
+ }
+ my $action = $args{action};
+ ok( 0, "wrong action: got [$action] must be 'read' or 'write'");
+}
+
+
+}### end cache testing helper functions ###
+
+### test Module::ScanDeps::Cache.pm
+
+SKIP:
+{
+ skip "Skipping M:SD::Cache tests" , 9 if $skip_cache_tests;
+ my %files = ('file1.pl' => "use TestModule;\n",
+ 'file2.pl' => "use TestModule;\n",
+ 'file3.pl' => "use TestModule;\n return 0;\n");
+
+ for my $name (keys %files){
+ open my $fh, '>', $name or die "Can not open file $name: $!";
+ print $fh $files{$name};
+ close $fh or die "Can not close file $name: $!";
+ }
+
+ my $cb = Module::ScanDeps::Cache::get_cache_cb();
+ my $mod = [];
+ my $ret = $cb->(key => 'testfile',
+ file => 'file1.pl',
+ action => 'read',
+ modules => $mod
+ );
+ is( $ret, 0, "File not present in cache");
+ $ret = $cb->(key => 'testfile',
+ file => 'file1.pl',
+ modules => [qw /TestModule.pm/],
+ action => 'write',
+ );
+ is( $ret, 1, "Writing file to cache");
+ $ret = $cb->(key => 'testfile',
+ file => 'file1.pl',
+ action => 'read',
+ modules => $mod
+ );
+ is( $ret, 1, "File is present in cache");
+ is( $mod->[0], 'TestModule.pm', "cache_cb sets modules 1");
+ $mod = [];
+ $ret = $cb->(key => 'testfile',
+ file => 'file2.pl',
+ action => 'read',
+ modules => $mod
+ );
+ is( $ret, 1, "Identical file returns the same dependencies from cache");
+ is( $mod->[0], 'TestModule.pm', "cache_cb sets modules 2");
+ $mod = [];
+ $ret = $cb->(key => 'testfile',
+ file => 'file3.pl',
+ action => 'read',
+ modules => $mod
+ );
+ is( $ret, 0, "No cached deps returned for file with different content");
+ is( @$mod, 0, "cache_cb does not set modules if no deps found");
+
+ eval {$cb->(action => 'foo')};
+ ok ($@ =~ /must be read or write/, "cache_cb dies on wrong action");
+ for my $name (keys %files){
+ unlink $name or die "Could not unlink file $name: $!";
+ }
+}
+
+unlink( $cache_file );
+__END__
Modified: branches/upstream/libmodule-scandeps-perl/current/t/Utils.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmodule-scandeps-perl/current/t/Utils.pm?rev=40186&op=diff
==============================================================================
--- branches/upstream/libmodule-scandeps-perl/current/t/Utils.pm (original)
+++ branches/upstream/libmodule-scandeps-perl/current/t/Utils.pm Sun Jul 19 17:11:36 2009
@@ -157,8 +157,6 @@
}
}
-1;
-
sub generic_abs_path {
my $file = shift @_;
$file = File::Spec->rel2abs($file);
@@ -166,5 +164,7 @@
return $file;
}
+
+1;
# Marks the end of any code. Any symbols after this are ignored. Use for documentation
__END__
More information about the Pkg-perl-cvs-commits
mailing list