On Sun, Feb 19, 2006 at 11:20:23AM -0800, Yitzchak Scott-Thoennes wrote:
> Has anyone familiar with DistGen looked at what Craig is doing?
> Can anyone offer any assistance?
>
> More comments inline.
>
> On Sun, Feb 05, 2006 at 06:10:58PM -0600, Craig A. Berry wrote:
> > At 3:39 PM -0800 2/5/06, Yitzchak Scott-Thoennes wrote:
> >
> > >Any progress on this front? Given that this is just for purposes of
> > >running tests, maybe here the hash keys should always be lowercased?
> > >
> > >The previous patch to add Module::Build no longer applies cleanly;
> > >
> > >http://zipcon.net/~sthoenna/mbaddfull270701.patch
> > >
> > >is updated to match bleadperl and what's currently in cvs for MB.
> >
> > I'll try to look at that again soon -- too many projects in progress
> > at once. I did some hacking with Tie:CPHash from CPAN and got a bit
> > farther. A still not fully working diff of DistGen.pm is at the end
> > of this message. I'm now getting, for example:
> >
> > $ perl -"I[-.lib]" [-.lib.module.build.t]tilde.t
> > 1..11
> > Warning: Removing existing directory 'D0:[CRAIG.perl.t._tmp.Simple]'
> > Changed file 't/basic.t'.
> > Changed file 'lib/Simple.pm'.
> > Changed file 'Build.PL'.
> > Splitting '[]'
> > Setting directory name '[]' in %names
> > Splitting '[.t]'
> > Setting directory name '[.t]' in %names
> > Setting directory name '[.t]' in %names
> > Splitting '[.lib]'
> > Setting directory name '[.lib]' in %names
> > Setting directory name '[.lib]' in %names
> > Splitting '[]'
> > Setting directory name '[]' in %names
> > Removing 'lib'
> > Removing 't'
> > Can't call method "install_base" on an undefined value at
> > [-.lib.module.build.t]tilde.t line 44.
> > # No tests run!
> >
> > I think the next hurdle is that File::Find is returning directory
> > names with no attached distinguishing punctuation (C<lib> or C<t>)
> > but the names that we've cached do have that punctuation (C<[.lib]>
> > or C<[.t]>). File::Spec->canonpath does not normalize that:
> >
> > $ perl -"MFile::Spec" -e "print File::Spec->canonpath('[.lib]');"
> > [.lib]
> > $ perl -"MFile::Spec" -e "print File::Spec->canonpath('lib');"
> > lib
> >
> > So on VMS we'll have to get more aggressive about caching directory
> > names in the same form that we'll be looking them up. Otherwise we
> > don't recognize directories that we want to keep and we end up
> > deleting before they are even used.
> >
> > --- DistGen.pm;2 Thu Jan 26 18:48:29 2006
> > +++ DistGen.pm Sun Jan 29 15:58:55 2006
> > @@ -5,7 +5,7 @@
> > use vars qw( $VERSION $VERBOSE );
> >
> > $VERSION = '0.01';
> > -$VERBOSE = 0;
> > +$VERBOSE = 1;
> >
> >
> > use Cwd ();
> > @@ -14,6 +14,7 @@
> > use File::Path ();
> > use File::Spec ();
> > use IO::File ();
> > +use Tie::CPHash;
> >
> > sub new {
> > my $package = shift;
> > @@ -29,6 +30,10 @@
> > );
> > my $self = bless( \%data, $package );
> >
> > + tie %{$self->{filedata}}, 'Tie::CPHash';
> > +
> > + tie %{$self->{pending}{change}}, 'Tie::CPHash';
> > +
> > if ( -d $self->dirname ) {
> > warn "Warning: Removing existing directory '@{[$self->dirname]}'\n";
> > $self->remove;
> > @@ -280,6 +285,7 @@
> > }
> >
> > my %names;
> > + tie %names, 'Tie::CPHash';
> > foreach my $file ( keys %{$self->{filedata}} ) {
> > my $filename = $self->_real_filename( $file );
> > my ($vol, $dirname, $f) = File::Spec->splitpath( $filename );
> > @@ -288,10 +294,16 @@
> >
> > $names{$filename} = 0;
> >
> > + print "Splitting '$dirname'\n" if $VERBOSE;
> > my @dirs = File::Spec->splitdir( $dirname );
> > while ( @dirs ) {
> > - my $dir = File::Spec->catdir( @dirs );
> > - $names{$dir} = 0;
> > + my $dir = ( scalar(@dirs) == 1
> > + ? $dirname
> > + : File::Spec->catdir( @dirs ) );
> > + if (length $dir) {
> > + print "Setting directory name '$dir' in \%names\n" if $VERBOSE;
> > + $names{$dir} = 0;
> > + }
> > pop( @dirs );
> > }
> > }
> > @@ -299,11 +311,13 @@
> > File::Find::finddepth( sub {
> > my $name = File::Spec->canonpath( $File::Find::name );
> >
> > + $name =~ s/\.\z// if $^O eq 'VMS';
> > +
> > if ( not exists $names{$name} ) {
>
> Wild stab in the dark:
>
> if (! ( exists $names{$name} ||
> $^O eq 'VMS' && -d $name && exists $names{"[.$name]"} ) ) {
>
> It doesn't have to be pretty, it just has to work.
>
> > print "Removing '$name'\n" if $VERBOSE;
> > File::Path::rmtree( $_ );
> > }
> > - }, File::Spec->curdir );
> > + }, './' );
>
> Why not curdir?
>
> >
> > chdir( $here );
> > }
In case it helps move things further along, here's Craig's stuff as a
patch to CVS, with Tie::CPHash added. Passes all tests using cygwin
and windows ActivePerl 5.8.7. I don't see any reason not to apply it.
(I made the last change be for VMS only.)
diff -ruN Module-Build-0.27_0702-orig/MANIFEST Module-Build-0.27_0702/MANIFEST
--- Module-Build-0.27_0702-orig/MANIFEST 2006-02-19 21:11:45.000000000
+0000
+++ Module-Build-0.27_0702/MANIFEST 2006-02-19 21:34:24.921875000 +0000
@@ -33,6 +33,7 @@
t/bundled/Test/Builder.pm
t/bundled/Test/More.pm
t/bundled/Test/Simple.pm
+t/bundled/Tie/CPHash.pm
t/compat.t
t/destinations.t
t/ext.t
diff -ruN Module-Build-0.27_0702-orig/t/bundled/Tie/CPHash.pm
Module-Build-0.27_0702/t/bundled/Tie/CPHash.pm
--- Module-Build-0.27_0702-orig/t/bundled/Tie/CPHash.pm 1970-01-01
00:00:00.000000000 +0000
+++ Module-Build-0.27_0702/t/bundled/Tie/CPHash.pm 2006-02-19
21:33:50.562500000 +0000
@@ -0,0 +1,189 @@
+#---------------------------------------------------------------------
+package Tie::CPHash;
+#
+# Copyright 1997 Christopher J. Madsen
+#
+# Author: Christopher J. Madsen <[EMAIL PROTECTED]>
+# Created: 08 Nov 1997
+# Version: 1.001 (25-Oct-1998)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as Perl itself.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the
+# GNU General Public License or the Artistic License for more details.
+#
+# Case preserving but case insensitive hash
+#---------------------------------------------------------------------
+
+require 5.000;
+use strict;
+use vars qw(@ISA $VERSION);
+
[EMAIL PROTECTED] = qw();
+
+#=====================================================================
+# Package Global Variables:
+
+BEGIN
+{
+ # Convert RCS revision number to d.ddd format:
+ $VERSION = sprintf('%d.%03d', '1.001 ' =~ /(\d+)\.(\d+)/);
+} # end BEGIN
+
+#=====================================================================
+# Tied Methods:
+#---------------------------------------------------------------------
+# TIEHASH classname
+# The method invoked by the command `tie %hash, classname'.
+# Associates a new hash instance with the specified class.
+
+sub TIEHASH
+{
+ bless {}, $_[0];
+} # end TIEHASH
+
+#---------------------------------------------------------------------
+# STORE this, key, value
+# Store datum *value* into *key* for the tied hash *this*.
+
+sub STORE
+{
+ $_[0]->{lc $_[1]} = [ $_[1], $_[2] ];
+} # end STORE
+
+#---------------------------------------------------------------------
+# FETCH this, key
+# Retrieve the datum in *key* for the tied hash *this*.
+
+sub FETCH
+{
+ my $v = $_[0]->{lc $_[1]};
+ ($v ? $v->[1] : undef);
+} # end FETCH
+
+#---------------------------------------------------------------------
+# FIRSTKEY this
+# Return the (key, value) pair for the first key in the hash.
+
+sub FIRSTKEY
+{
+ my $a = scalar keys %{$_[0]};
+ &NEXTKEY;
+} # end FIRSTKEY
+
+#---------------------------------------------------------------------
+# NEXTKEY this, lastkey
+# Return the next (key, value) pair for the hash.
+
+sub NEXTKEY
+{
+ my $v = (each %{$_[0]})[1];
+ ($v ? $v->[0] : undef );
+} # end NEXTKEY
+
+#---------------------------------------------------------------------
+# EXISTS this, key
+# Verify that *key* exists with the tied hash *this*.
+
+sub EXISTS
+{
+ exists $_[0]->{lc $_[1]};
+} # end EXISTS
+
+#---------------------------------------------------------------------
+# DELETE this, key
+# Delete the key *key* from the tied hash *this*.
+# Returns the old value, or undef if it didn't exist.
+
+sub DELETE
+{
+ my $v = delete $_[0]->{lc $_[1]};
+ ($v ? $v->[1] : undef);
+} # end DELETE
+
+#---------------------------------------------------------------------
+# CLEAR this
+# Clear all values from the tied hash *this*.
+
+sub CLEAR
+{
+ %{$_[0]} = ();
+} # end CLEAR
+
+#=====================================================================
+# Other Methods:
+#---------------------------------------------------------------------
+# Return the case of KEY.
+
+sub key
+{
+ my $v = $_[0]->{lc $_[1]};
+ ($v ? $v->[0] : undef);
+}
+
+#=====================================================================
+# Package Return Value:
+
+1;
+
+__END__
+
+=head1 NAME
+
+Tie::CPHash - Case preserving but case insensitive hash table
+
+=head1 SYNOPSIS
+
+ require Tie::CPHash;
+ tie %cphash, 'Tie::CPHash';
+
+ $cphash{'Hello World'} = 'Hi there!';
+ printf("The key `%s' was used to store `%s'.\n",
+ tied(%cphash)->key('HELLO WORLD'),
+ $cphash{'HELLO world'});
+
+=head1 DESCRIPTION
+
+The B<Tie::CPHash> provides a hash table that is case preserving but
+case insensitive. This means that
+
+ $cphash{KEY} $cphash{key}
+ $cphash{Key} $cphash{keY}
+
+all refer to the same entry. Also, the hash remembers which form of
+the key was last used to store the entry. The C<keys> and C<each>
+functions will return the key that was used to set the value.
+
+An example should make this clear:
+
+ tie %h, 'Tie::CPHash';
+ $h{Hello} = 'World';
+ print $h{HELLO}; # Prints 'World'
+ print keys(%h); # Prints 'Hello'
+ $h{HELLO} = 'WORLD';
+ print $h{hello}; # Prints 'WORLD'
+ print keys(%h); # Prints 'HELLO'
+
+The additional C<key> method lets you fetch the case of a specific key:
+
+ # When run after the previous example, this prints 'HELLO':
+ print tied(%h)->key('Hello');
+
+(The C<tied> function returns the object that C<%h> is tied to.)
+
+If you need a case insensitive hash, but don't need to preserve case,
+just use C<$hash{lc $key}> instead of C<$hash{$key}>. This has a lot
+less overhead than B<Tie::CPHash>.
+
+=head1 AUTHOR
+
+Christopher J. Madsen E<lt>F<[EMAIL PROTECTED]>E<gt>
+
+=cut
+
+# Local Variables:
+# tmtrack-file-task: "Tie::CPHash.pm"
+# End:
diff -ruN Module-Build-0.27_0702-orig/t/lib/DistGen.pm
Module-Build-0.27_0702/t/lib/DistGen.pm
--- Module-Build-0.27_0702-orig/t/lib/DistGen.pm 2006-02-19
21:11:45.000000000 +0000
+++ Module-Build-0.27_0702/t/lib/DistGen.pm 2006-02-20 05:29:32.093750000
+0000
@@ -14,6 +14,7 @@
use File::Path ();
use File::Spec ();
use IO::File ();
+use Tie::CPHash;
sub new {
my $package = shift;
@@ -29,6 +30,10 @@
);
my $self = bless( \%data, $package );
+ tie %{$self->{filedata}}, 'Tie::CPHash';
+
+ tie %{$self->{pending}{change}}, 'Tie::CPHash';
+
if ( -d $self->dirname ) {
warn "Warning: Removing existing directory '@{[$self->dirname]}'\n";
$self->remove;
@@ -280,16 +285,23 @@
}
my %names;
+ tie %names, 'Tie::CPHash';
foreach my $file ( keys %{$self->{filedata}} ) {
my $filename = $self->_real_filename( $file );
my $dirname = File::Basename::dirname( $filename );
$names{$filename} = 0;
+ print "Splitting '$dirname'\n" if $VERBOSE;
my @dirs = File::Spec->splitdir( $dirname );
while ( @dirs ) {
- my $dir = File::Spec->catdir( @dirs );
- $names{$dir} = 0;
+ my $dir = ( scalar(@dirs) == 1
+ ? $dirname
+ : File::Spec->catdir( @dirs ) );
+ if (length $dir) {
+ print "Setting directory name '$dir' in \%names\n" if $VERBOSE;
+ $names{$dir} = 0;
+ }
pop( @dirs );
}
}
@@ -297,11 +309,13 @@
File::Find::finddepth( sub {
my $name = File::Spec->canonpath( $File::Find::name );
+ $name =~ s/\.\z// if $^O eq 'VMS';
+
if ( not exists $names{$name} ) {
print "Removing '$name'\n" if $VERBOSE;
File::Path::rmtree( $_ );
}
- }, File::Spec->curdir );
+ }, ($^O eq "VMS" ? './' : File::Spec->curdir) );
chdir( $here );
}
