[perl5.git] / cpan / ExtUtils-Install / lib / ExtUtils / Packlist.pm

package ExtUtils::Packlist;

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

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

=begin _undocumented

=over

=item mkfh()

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

=cut

sub mkfh()
{
no strict;
local $^W;
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

=back

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