[p5sagit/p5-mst-13.2.git] / lib / ExtUtils / Packlist.pm

package ExtUtils::Packlist;

use 5.00503;
use strict;
use Carp qw();
use Config;
use vars qw($VERSION $Relocations);
$VERSION = '1.41';
$VERSION = eval $VERSION;

# Used for generating filehandle globs.  IO::File might not be available!
my $fhname = "FH1";

=begin _undocumented

=item mkfh()

Make a filehandle. Same kind of idea as Symbol::gensym().

=cut

sub mkfh()
{
no strict;
my $fh = \*{$fhname++};
use strict;
return($fh);
}

=item __find_relocations

Works out what absolute paths in the configuration have been located at run
time relative to $^X, and generates a regexp that matches them

=end _undocumented

=cut

sub __find_relocations
{
    my %paths;
    while (my ($raw_key, $raw_val) = each %Config) {
	my $exp_key = $raw_key . "exp";
	next unless exists $Config{$exp_key};
	next unless $raw_val =~ m!\.\.\./!;
	$paths{$Config{$exp_key}}++;
    }
    # Longest prefixes go first in the alternatives
    my $alternations = join "|", map {quotemeta $_}
    sort {length $b <=> length $a} keys %paths;
    qr/^($alternations)/o;
}

sub new($$)
{
my ($class, $packfile) = @_;
$class = ref($class) || $class;
my %self;
tie(%self, $class, $packfile);
return(bless(\%self, $class));
}

sub TIEHASH
{
my ($class, $packfile) = @_;
my $self = { packfile => $packfile };
bless($self, $class);
$self->read($packfile) if (defined($packfile) && -f $packfile);
return($self);
}

sub STORE
{
$_[0]->{data}->{$_[1]} = $_[2];
}

sub FETCH
{
return($_[0]->{data}->{$_[1]});
}

sub FIRSTKEY
{
my $reset = scalar(keys(%{$_[0]->{data}}));
return(each(%{$_[0]->{data}}));
}

sub NEXTKEY
{
return(each(%{$_[0]->{data}}));
}

sub EXISTS
{
return(exists($_[0]->{data}->{$_[1]}));
}

sub DELETE
{
return(delete($_[0]->{data}->{$_[1]}));
}

sub CLEAR
{
%{$_[0]->{data}} = ();
}

sub DESTROY
{
}

sub read($;$)
{
my ($self, $packfile) = @_;
$self = tied(%$self) || $self;

if (defined($packfile)) { $self->{packfile} = $packfile; }
else { $packfile = $self->{packfile}; }
Carp::croak("No packlist filename specified") if (! defined($packfile));
my $fh = mkfh();
open($fh, "<$packfile") || Carp::croak("Can't open file $packfile: $!");
$self->{data} = {};
my ($line);
while (defined($line = <$fh>))
   {
   chomp $line;
   my ($key, $data) = $line;
   if ($key =~ /^(.*?)( \w+=.*)$/)
      {
      $key = $1;
      $data = { map { split('=', $_) } split(' ', $2)};

      if ($Config{userelocatableinc} && $data->{relocate_as})
          {
	  require File::Spec;
	  require Cwd;
	  my ($vol, $dir) = File::Spec->splitpath($packfile);
	  my $newpath = File::Spec->catpath($vol, $dir, $data->{relocate_as});
	  $key = Cwd::realpath($newpath);
          }
      }
   $key =~ s!/\./!/!g;   # Some .packlists have spurious '/./' bits in the paths
   $self->{data}->{$key} = $data;
   }
close($fh);
}

sub write($;$)
{
my ($self, $packfile) = @_;
$self = tied(%$self) || $self;
if (defined($packfile)) { $self->{packfile} = $packfile; }
else { $packfile = $self->{packfile}; }
Carp::croak("No packlist filename specified") if (! defined($packfile));
my $fh = mkfh();
open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!");
foreach my $key (sort(keys(%{$self->{data}})))
   {
       my $data = $self->{data}->{$key};
       if ($Config{userelocatableinc}) {
	   $Relocations ||= __find_relocations();
	   if ($packfile =~ $Relocations) {
	       # We are writing into a subdirectory of a run-time relocated
	       # path. Figure out if the this file is also within a subdir.
	       my $prefix = $1;
	       if (File::Spec->no_upwards(File::Spec->abs2rel($key, $prefix)))
	       {
		   # The relocated path is within the found prefix
		   my $packfile_prefix;
		   (undef, $packfile_prefix)
		       = File::Spec->splitpath($packfile);

		   my $relocate_as
		       = File::Spec->abs2rel($key, $packfile_prefix);

		   if (!ref $data) {
		       $data = {};
		   }
		   $data->{relocate_as} = $relocate_as;
	       }
	   }
       }
   print $fh ("$key");
   if (ref($data))
      {
      foreach my $k (sort(keys(%$data)))
         {
         print $fh (" $k=$data->{$k}");
         }
      }
   print $fh ("\n");
   }
close($fh);
}

sub validate($;$)
{
my ($self, $remove) = @_;
$self = tied(%$self) || $self;
my @missing;
foreach my $key (sort(keys(%{$self->{data}})))
   {
   if (! -e $key)
      {
      push(@missing, $key);
      delete($self->{data}{$key}) if ($remove);
      }
   }
return(@missing);
}

sub packlist_file($)
{
my ($self) = @_;
$self = tied(%$self) || $self;
return($self->{packfile});
}

1;

__END__

=head1 NAME

ExtUtils::Packlist - manage .packlist files

=head1 SYNOPSIS

   use ExtUtils::Packlist;
   my ($pl) = ExtUtils::Packlist->new('.packlist');
   $pl->read('/an/old/.packlist');
   my @missing_files = $pl->validate();
   $pl->write('/a/new/.packlist');

   $pl->{'/some/file/name'}++;
      or
   $pl->{'/some/other/file/name'} = { type => 'file',
                                      from => '/some/file' };

=head1 DESCRIPTION

ExtUtils::Packlist provides a standard way to manage .packlist files.
Functions are provided to read and write .packlist files.  The original
.packlist format is a simple list of absolute pathnames, one per line.  In
addition, this package supports an extended format, where as well as a filename
each line may contain a list of attributes in the form of a space separated
list of key=value pairs.  This is used by the installperl script to
differentiate between files and links, for example.

=head1 USAGE

The hash reference returned by the new() function can be used to examine and
modify the contents of the .packlist.  Items may be added/deleted from the
.packlist by modifying the hash.  If the value associated with a hash key is a
scalar, the entry written to the .packlist by any subsequent write() will be a
simple filename.  If the value is a hash, the entry written will be the
filename followed by the key=value pairs from the hash.  Reading back the
.packlist will recreate the original entries.

=head1 FUNCTIONS

=over 4

=item new()

This takes an optional parameter, the name of a .packlist.  If the file exists,
it will be opened and the contents of the file will be read.  The new() method
returns a reference to a hash.  This hash holds an entry for each line in the
.packlist.  In the case of old-style .packlists, the value associated with each
key is undef.  In the case of new-style .packlists, the value associated with
each key is a hash containing the key=value pairs following the filename in the
.packlist.

=item read()

This takes an optional parameter, the name of the .packlist to be read.  If
no file is specified, the .packlist specified to new() will be read.  If the
.packlist does not exist, Carp::croak will be called.

=item write()

This takes an optional parameter, the name of the .packlist to be written.  If
no file is specified, the .packlist specified to new() will be overwritten.

=item validate()

This checks that every file listed in the .packlist actually exists.  If an
argument which evaluates to true is given, any missing files will be removed
from the internal hash.  The return value is a list of the missing files, which
will be empty if they all exist.

=item packlist_file()

This returns the name of the associated .packlist file

=back

=head1 EXAMPLE

Here's C<modrm>, a little utility to cleanly remove an installed module.

    #!/usr/local/bin/perl -w

    use strict;
    use IO::Dir;
    use ExtUtils::Packlist;
    use ExtUtils::Installed;

    sub emptydir($) {
	my ($dir) = @_;
	my $dh = IO::Dir->new($dir) || return(0);
	my @count = $dh->read();
	$dh->close();
	return(@count == 2 ? 1 : 0);
    }

    # Find all the installed packages
    print("Finding all installed modules...\n");
    my $installed = ExtUtils::Installed->new();

    foreach my $module (grep(!/^Perl$/, $installed->modules())) {
       my $version = $installed->version($module) || "???";
       print("Found module $module Version $version\n");
       print("Do you want to delete $module? [n] ");
       my $r = <STDIN>; chomp($r);
       if ($r && $r =~ /^y/i) {
	  # Remove all the files
	  foreach my $file (sort($installed->files($module))) {
	     print("rm $file\n");
	     unlink($file);
	  }
	  my $pf = $installed->packlist($module)->packlist_file();
	  print("rm $pf\n");
	  unlink($pf);
	  foreach my $dir (sort($installed->directory_tree($module))) {
	     if (emptydir($dir)) {
		print("rmdir $dir\n");
		rmdir($dir);
	     }
	  }
       }
    }

=head1 AUTHOR

Alan Burlison <Alan.Burlison@uk.sun.com>

=cut
Commit	Line	Data
93cd2f30	1	package ExtUtils::Packlist;
17f410f9	2
57b1a898	3	use 5.00503;
93cd2f30	4	use strict;
93cd2f30	5	use Carp qw();
2670f2fb	6	use Config;
c776f839	7	use vars qw($VERSION $Relocations);
f62a57de	8	$VERSION = '1.41';
3a465856	9	$VERSION = eval $VERSION;
93cd2f30	10
	11	# Used for generating filehandle globs. IO::File might not be available!
	12	my $fhname = "FH1";
	13
3a465856	14	=begin _undocumented
	15
	16	=item mkfh()
	17
	18	Make a filehandle. Same kind of idea as Symbol::gensym().
	19
3a465856	20	=cut
3a465856	21
93cd2f30	22	sub mkfh()
	23	{
	24	no strict;
	25	my $fh = \*{$fhname++};
	26	use strict;
	27	return($fh);
	28	}
	29
c776f839	30	=item __find_relocations
	31
	32	Works out what absolute paths in the configuration have been located at run
	33	time relative to $^X, and generates a regexp that matches them
	34
	35	=end _undocumented
	36
	37	=cut
	38
	39	sub __find_relocations
	40	{
	41	my %paths;
	42	while (my ($raw_key, $raw_val) = each %Config) {
	43	my $exp_key = $raw_key . "exp";
	44	next unless exists $Config{$exp_key};
	45	next unless $raw_val =~ m!\.\.\./!;
	46	$paths{$Config{$exp_key}}++;
	47	}
	48	# Longest prefixes go first in the alternatives
	49	my $alternations = join "\|", map {quotemeta $_}
	50	sort {length $b <=> length $a} keys %paths;
	51	qr/^($alternations)/o;
	52	}
	53
93cd2f30	54	sub new($$)
	55	{
	56	my ($class, $packfile) = @_;
	57	$class = ref($class) \|\| $class;
	58	my %self;
	59	tie(%self, $class, $packfile);
	60	return(bless(\%self, $class));
	61	}
	62
	63	sub TIEHASH
	64	{
	65	my ($class, $packfile) = @_;
	66	my $self = { packfile => $packfile };
	67	bless($self, $class);
	68	$self->read($packfile) if (defined($packfile) && -f $packfile);
	69	return($self);
	70	}
	71
	72	sub STORE
	73	{
	74	$_[0]->{data}->{$_[1]} = $_[2];
	75	}
	76
	77	sub FETCH
	78	{
	79	return($_[0]->{data}->{$_[1]});
	80	}
	81
	82	sub FIRSTKEY
	83	{
	84	my $reset = scalar(keys(%{$_[0]->{data}}));
	85	return(each(%{$_[0]->{data}}));
	86	}
	87
	88	sub NEXTKEY
	89	{
	90	return(each(%{$_[0]->{data}}));
	91	}
	92
	93	sub EXISTS
	94	{
	95	return(exists($_[0]->{data}->{$_[1]}));
	96	}
	97
	98	sub DELETE
	99	{
	100	return(delete($_[0]->{data}->{$_[1]}));
	101	}
	102
	103	sub CLEAR
	104	{
	105	%{$_[0]->{data}} = ();
	106	}
	107
	108	sub DESTROY
	109	{
	110	}
	111
	112	sub read($;$)
	113	{
	114	my ($self, $packfile) = @_;
	115	$self = tied(%$self) \|\| $self;
	116
	117	if (defined($packfile)) { $self->{packfile} = $packfile; }
118	else { $packfile = $self->{packfile}; }
119	Carp::croak("No packlist filename specified") if (! defined($packfile));
120	my $fh = mkfh();
121	open($fh, "<$packfile") \|\| Carp::croak("Can't open file $packfile: $!");
122	$self->{data} = {};
123	my ($line);
124	while (defined($line = <$fh>))
125	{
126	chomp $line;
2670f2fb	127	my ($key, $data) = $line;
411cc70a	128	if ($key =~ /^(.?)( \w+=.)$/)
	129	{
	130	$key = $1;
2670f2fb	131	$data = { map { split('=', $_) } split(' ', $2)};
c776f839	132
	133	if ($Config{userelocatableinc} && $data->{relocate_as})
	134	{
	135	require File::Spec;
	136	require Cwd;
	137	my ($vol, $dir) = File::Spec->splitpath($packfile);
	138	my $newpath = File::Spec->catpath($vol, $dir, $data->{relocate_as});
	139	$key = Cwd::realpath($newpath);
	140	}
411cc70a	141	}
9b604809	142	$key =~ s!/\./!/!g; # Some .packlists have spurious '/./' bits in the paths
2670f2fb	143	$self->{data}->{$key} = $data;
93cd2f30	144	}
	145	close($fh);
	146	}
	147
	148	sub write($;$)
	149	{
	150	my ($self, $packfile) = @_;
	151	$self = tied(%$self) \|\| $self;
	152	if (defined($packfile)) { $self->{packfile} = $packfile; }
	153	else { $packfile = $self->{packfile}; }
	154	Carp::croak("No packlist filename specified") if (! defined($packfile));
	155	my $fh = mkfh();
	156	open($fh, ">$packfile") \|\| Carp::croak("Can't open file $packfile: $!");
	157	foreach my $key (sort(keys(%{$self->{data}})))
	158	{
c776f839	159	my $data = $self->{data}->{$key};
	160	if ($Config{userelocatableinc}) {
	161	$Relocations \|\|= __find_relocations();
	162	if ($packfile =~ $Relocations) {
	163	# We are writing into a subdirectory of a run-time relocated
	164	# path. Figure out if the this file is also within a subdir.
	165	my $prefix = $1;
	166	if (File::Spec->no_upwards(File::Spec->abs2rel($key, $prefix)))
	167	{
	168	# The relocated path is within the found prefix
	169	my $packfile_prefix;
	170	(undef, $packfile_prefix)
	171	= File::Spec->splitpath($packfile);
	172
	173	my $relocate_as
	174	= File::Spec->abs2rel($key, $packfile_prefix);
	175
	176	if (!ref $data) {
	177	$data = {};
	178	}
	179	$data->{relocate_as} = $relocate_as;
	180	}
	181	}
	182	}
93cd2f30	183	print $fh ("$key");
c776f839	184	if (ref($data))
93cd2f30	185	{
93cd2f30	186	foreach my $k (sort(keys(%$data)))
	187	{
	188	print $fh (" $k=$data->{$k}");
	189	}
	190	}
	191	print $fh ("\n");
	192	}
	193	close($fh);
	194	}
	195
	196	sub validate($;$)
	197	{
	198	my ($self, $remove) = @_;
	199	$self = tied(%$self) \|\| $self;
	200	my @missing;
	201	foreach my $key (sort(keys(%{$self->{data}})))
	202	{
	203	if (! -e $key)
	204	{
	205	push(@missing, $key);
	206	delete($self->{data}{$key}) if ($remove);
	207	}
	208	}
	209	return(@missing);
	210	}
	211
9b604809	212	sub packlist_file($)
	213	{
	214	my ($self) = @_;
	215	$self = tied(%$self) \|\| $self;
	216	return($self->{packfile});
	217	}
	218
93cd2f30	219	1;
	220
	221	__END__
	222
	223	=head1 NAME
	224
	225	ExtUtils::Packlist - manage .packlist files
	226
	227	=head1 SYNOPSIS
	228
	229	use ExtUtils::Packlist;
	230	my ($pl) = ExtUtils::Packlist->new('.packlist');
	231	$pl->read('/an/old/.packlist');
	232	my @missing_files = $pl->validate();
	233	$pl->write('/a/new/.packlist');
	234
	235	$pl->{'/some/file/name'}++;
	236	or
	237	$pl->{'/some/other/file/name'} = { type => 'file',
	238	from => '/some/file' };
	239
	240	=head1 DESCRIPTION
	241
	242	ExtUtils::Packlist provides a standard way to manage .packlist files.
	243	Functions are provided to read and write .packlist files. The original
	244	.packlist format is a simple list of absolute pathnames, one per line. In
	245	addition, this package supports an extended format, where as well as a filename
	246	each line may contain a list of attributes in the form of a space separated
	247	list of key=value pairs. This is used by the installperl script to
	248	differentiate between files and links, for example.
	249
	250	=head1 USAGE
	251
	252	The hash reference returned by the new() function can be used to examine and
	253	modify the contents of the .packlist. Items may be added/deleted from the
	254	.packlist by modifying the hash. If the value associated with a hash key is a
	255	scalar, the entry written to the .packlist by any subsequent write() will be a
	256	simple filename. If the value is a hash, the entry written will be the
	257	filename followed by the key=value pairs from the hash. Reading back the
	258	.packlist will recreate the original entries.
	259
	260	=head1 FUNCTIONS
	261
bbc7dcd2	262	=over 4
93cd2f30	263
	264	=item new()
	265
	266	This takes an optional parameter, the name of a .packlist. If the file exists,
	267	it will be opened and the contents of the file will be read. The new() method
	268	returns a reference to a hash. This hash holds an entry for each line in the
	269	.packlist. In the case of old-style .packlists, the value associated with each
	270	key is undef. In the case of new-style .packlists, the value associated with
	271	each key is a hash containing the key=value pairs following the filename in the
	272	.packlist.
	273
	274	=item read()
	275
	276	This takes an optional parameter, the name of the .packlist to be read. If
	277	no file is specified, the .packlist specified to new() will be read. If the
	278	.packlist does not exist, Carp::croak will be called.
	279
	280	=item write()
	281
	282	This takes an optional parameter, the name of the .packlist to be written. If
	283	no file is specified, the .packlist specified to new() will be overwritten.
	284
	285	=item validate()
	286
	287	This checks that every file listed in the .packlist actually exists. If an
	288	argument which evaluates to true is given, any missing files will be removed
	289	from the internal hash. The return value is a list of the missing files, which
	290	will be empty if they all exist.
	291
9b604809	292	=item packlist_file()
	293
	294	This returns the name of the associated .packlist file
	295
93cd2f30	296	=back
93cd2f30	297
ddf41153	298	=head1 EXAMPLE
	299
	300	Here's C<modrm>, a little utility to cleanly remove an installed module.
	301
	302	#!/usr/local/bin/perl -w
	303
	304	use strict;
	305	use IO::Dir;
	306	use ExtUtils::Packlist;
	307	use ExtUtils::Installed;
	308
	309	sub emptydir($) {
	310	my ($dir) = @_;
	311	my $dh = IO::Dir->new($dir) \|\| return(0);
	312	my @count = $dh->read();
	313	$dh->close();
	314	return(@count == 2 ? 1 : 0);
	315	}
	316
	317	# Find all the installed packages
	318	print("Finding all installed modules...\n");
	319	my $installed = ExtUtils::Installed->new();
	320
	321	foreach my $module (grep(!/^Perl$/, $installed->modules())) {
	322	my $version = $installed->version($module) \|\| "???";
	323	print("Found module $module Version $version\n");
	324	print("Do you want to delete $module? [n] ");
	325	my $r = <STDIN>; chomp($r);
	326	if ($r && $r =~ /^y/i) {
	327	# Remove all the files
	328	foreach my $file (sort($installed->files($module))) {
	329	print("rm $file\n");
	330	unlink($file);
	331	}
	332	my $pf = $installed->packlist($module)->packlist_file();
	333	print("rm $pf\n");
	334	unlink($pf);
	335	foreach my $dir (sort($installed->directory_tree($module))) {
	336	if (emptydir($dir)) {
	337	print("rmdir $dir\n");
	338	rmdir($dir);
	339	}
	340	}
	341	}
	342	}
	343
93cd2f30	344	=head1 AUTHOR
	345
	346	Alan Burlison <Alan.Burlison@uk.sun.com>
	347
	348	=cut