misc/162016: BSDPAN::ExtUtils::Packlist-> get_dir_list can go into an infinite loop

[Michael G Schwern]

The following reply was made to PR misc/162016; it has been noted by GNATS.

From: Michael G Schwern <schwern at pobox.com>
To: bug-followup at FreeBSD.org
Cc:  
Subject: Re: misc/162016: BSDPAN::ExtUtils::Packlist-&gt;get_dir_list can go
 into an infinite loop
Date: Tue, 25 Oct 2011 17:04:39 -0700

 This is a multi-part message in MIME format.
 --------------010506050404040500090003
 Content-Type: text/plain; charset=ISO-8859-1
 Content-Transfer-Encoding: 7bit
 
 Attached is a test and a fix for BSDPAN::ExtUtils::Packlist::get_dir_list().
 I patched the version from BSDPAN-5.12.1_20100713.tar.bz2.
 
 
 --------------010506050404040500090003
 Content-Type: text/plain;
  name="get_dir_list.patch"
 Content-Transfer-Encoding: 7bit
 Content-Disposition: attachment;
  filename="get_dir_list.patch"
 
 diff --git a/BSDPAN/ExtUtils/Packlist.pm b/BSDPAN/ExtUtils/Packlist.pm
 index 19f764e..b659513 100644
 --- a/BSDPAN/ExtUtils/Packlist.pm
 +++ b/BSDPAN/ExtUtils/Packlist.pm
 @@ -17,6 +17,7 @@ use Config;
  use Fcntl;
  use BSDPAN;
  use BSDPAN::Override;
 +use File::Basename qw(dirname basename);
  
  sub write {
  	my $orig = shift;	# original ExtUtils::Packlist::write
 @@ -210,18 +211,20 @@ sub get_dir_list {
  	my %alldirs;
  
  	for my $file (@files) {
 -		$file =~ s|/[^/]+$||;
 -		while (-d $file) {
 -			$file =~ s|/([^/]+)$||;
 -			my $last = $1;
 -			last if $last eq "bin";
 -			last if $last eq "auto";
 -			last if $last eq "man1";
 -			last if $last eq "man3";
 -			last if $last eq "site_perl";
 -			last if $last eq "mach";
 +		my $dir = dirname($file);
 +
 +		while( -d $dir ) {
 +			my $last = basename($dir);
 +			last if grep { $last eq $_ } qw(bin auto man1 man3 site_perl mach);
 +
  			last if $last =~ /^[\d.]+$/;
 -			$alldirs{"$file/$last"}++;
 +
 +			$alldirs{$dir}++;
 +
 +			my $parent = dirname($dir);
 +			last if $parent eq $dir;
 +			last if $parent eq '/';
 +			$dir = $parent;
  		}
  	}
  
 diff --git a/t/get_dir_list.t b/t/get_dir_list.t
 new file mode 100644
 index 0000000..703a78e
 --- /dev/null
 +++ b/t/get_dir_list.t
 @@ -0,0 +1,79 @@
 +#!/usr/bin/env perl -w
 +
 +use strict;
 +use warnings;
 +
 +use autodie;
 +use BSDPAN::ExtUtils::Packlist;
 +use ExtUtils::Packlist;
 +use File::Temp;
 +use File::Spec;
 +use File::Path;
 +use Cwd qw(abs_path);
 +
 +use Test::More;
 +
 +my $Orig_Cwd = abs_path;
 +
 +my $get_dir_list = \&BSDPAN::ExtUtils::Packlist::get_dir_list;
 +
 +my $packlist = ExtUtils::Packlist->new;
 +
 +
 +note "get_dir_list"; {
 +    my $tempdir = File::Temp->newdir;
 +
 +    my @tempdir = grep { length $_ } File::Spec->splitdir($tempdir);
 +    my %want;
 +    for my $depth (0..$#tempdir) {
 +        $want{File::Spec->catdir("", @tempdir[0..$depth])}++;
 +    }
 +
 +    is_deeply
 +      [sort $get_dir_list->($packlist, "$tempdir/.packlist", "$tempdir/lib/perl5/Foo/Bar.pm")],
 +      [sort keys %want];
 +
 +    # Now do it again with the lib directory existing
 +    mkpath "$tempdir/lib/perl5/Foo";
 +
 +    $want{"$tempdir/lib/perl5/Foo"} = 1;
 +    $want{"$tempdir/lib/perl5"} = 1;
 +    $want{"$tempdir/lib"} = 1;
 +
 +    is_deeply
 +      [sort $get_dir_list->($packlist, "$tempdir/.packlist", "$tempdir/lib/perl5/Foo/Bar.pm")],
 +      [sort keys %want];
 +
 +    # Does it ignore bin?
 +    mkpath "$tempdir/bin";
 +
 +    is_deeply
 +      [sort $get_dir_list->(
 +          $packlist,
 +          "$tempdir/.packlist",
 +          "$tempdir/lib/perl5/Foo/Bar.pm",
 +          "$tempdir/bin/foo",
 +      )],
 +      [sort keys %want];
 +}
 +
 +
 +note "With .. and ."; {
 +    my $tempdir = File::Temp->newdir;
 +    mkdir "$tempdir/foo";
 +    chdir "$tempdir/foo";
 +
 +    is_deeply
 +      [sort $get_dir_list->($packlist, "../foo/.packlist")],
 +      ["../foo"];
 +
 +    chdir $tempdir;
 +
 +    is_deeply
 +      [sort $get_dir_list->($packlist, "./foo/.packlist")],
 +      ["./foo"];
 +
 +    chdir $Orig_Cwd;
 +}
 +
 +done_testing;
 
 --------------010506050404040500090003--