home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _87ac35731a07a7d08400477db716c659 < prev    next >
Encoding:
Text File  |  2004-06-01  |  9.4 KB  |  338 lines
  1. package ExtUtils::Installed;
  2.  
  3. use 5.00503;
  4. use strict;
  5. use Carp qw();
  6. use ExtUtils::Packlist;
  7. use ExtUtils::MakeMaker;
  8. use Config;
  9. use File::Find;
  10. use File::Basename;
  11. use File::Spec;
  12.  
  13. my $Is_VMS = $^O eq 'VMS';
  14. my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);
  15.  
  16. require VMS::Filespec if $Is_VMS;
  17.  
  18. use vars qw($VERSION);
  19. $VERSION = '0.08';
  20.  
  21. sub _is_prefix {
  22.     my ($self, $path, $prefix) = @_;
  23.     return unless defined $prefix && defined $path;
  24.  
  25.     if( $Is_VMS ) {
  26.         $prefix = VMS::Filespec::unixify($prefix);
  27.         $path   = VMS::Filespec::unixify($path);
  28.     }
  29.  
  30.     # Sloppy Unix path normalization.
  31.     $prefix =~ s{/+}{/}g;
  32.     $path   =~ s{/+}{/}g;
  33.  
  34.     return 1 if substr($path, 0, length($prefix)) eq $prefix;
  35.  
  36.     if ($DOSISH) {
  37.         $path =~ s|\\|/|g;
  38.         $prefix =~ s|\\|/|g;
  39.         return 1 if $path =~ m{^\Q$prefix\E}i;
  40.     }
  41.     return(0);
  42. }
  43.  
  44. sub _is_doc { 
  45.     my ($self, $path) = @_;
  46.     my $man1dir = $Config{man1direxp};
  47.     my $man3dir = $Config{man3direxp};
  48.     return(($man1dir && $self->_is_prefix($path, $man1dir))
  49.            ||
  50.            ($man3dir && $self->_is_prefix($path, $man3dir))
  51.            ? 1 : 0)
  52. }
  53.  
  54. sub _is_type {
  55.     my ($self, $path, $type) = @_;
  56.     return 1 if $type eq "all";
  57.  
  58.     return($self->_is_doc($path)) if $type eq "doc";
  59.  
  60.     if ($type eq "prog") {
  61.         return($self->_is_prefix($path, $Config{prefix} || $Config{prefixexp})
  62.                &&
  63.                !($self->_is_doc($path))
  64.                ? 1 : 0);
  65.     }
  66.     return(0);
  67. }
  68.  
  69. sub _is_under {
  70.     my ($self, $path, @under) = @_;
  71.     $under[0] = "" if (! @under);
  72.     foreach my $dir (@under) {
  73.         return(1) if ($self->_is_prefix($path, $dir));
  74.     }
  75.  
  76.     return(0);
  77. }
  78.  
  79. sub new {
  80.     my ($class) = @_;
  81.     $class = ref($class) || $class;
  82.     my $self = {};
  83.  
  84.     my $archlib = $Config{archlibexp};
  85.     my $sitearch = $Config{sitearchexp};
  86.  
  87.     # File::Find does not know how to deal with VMS filepaths.
  88.     if( $Is_VMS ) {
  89.         $archlib  = VMS::Filespec::unixify($archlib);
  90.         $sitearch = VMS::Filespec::unixify($sitearch);
  91.     }
  92.  
  93.     if ($DOSISH) {
  94.         $archlib =~ s|\\|/|g;
  95.         $sitearch =~ s|\\|/|g;
  96.     }
  97.  
  98.     # Read the core packlist
  99.     $self->{Perl}{packlist} =
  100.       ExtUtils::Packlist->new( File::Spec->catfile($archlib, '.packlist') );
  101.     $self->{Perl}{version} = $Config{version};
  102.  
  103.     # Read the module packlists
  104.     my $sub = sub {
  105.         # Only process module .packlists
  106.         return if $_ ne ".packlist" || $File::Find::dir eq $archlib;
  107.  
  108.         # Hack of the leading bits of the paths & convert to a module name
  109.         my $module = $File::Find::name;
  110.  
  111.         $module =~ s!\Q$archlib\E/?auto/(.*)/.packlist!$1!s  or
  112.         $module =~ s!\Q$sitearch\E/?auto/(.*)/.packlist!$1!s;
  113.         my $modfile = "$module.pm";
  114.         $module =~ s!/!::!g;
  115.  
  116.         # Find the top-level module file in @INC
  117.         $self->{$module}{version} = '';
  118.         foreach my $dir (@INC) {
  119.             my $p = File::Spec->catfile($dir, $modfile);
  120.             if (-r $p) {
  121.                 $module = _module_name($p, $module) if $Is_VMS;
  122.  
  123.                 require ExtUtils::MM;
  124.                 $self->{$module}{version} = MM->parse_version($p);
  125.                 last;
  126.             }
  127.         }
  128.  
  129.         # Read the .packlist
  130.         $self->{$module}{packlist} = 
  131.           ExtUtils::Packlist->new($File::Find::name);
  132.     };
  133.  
  134.     my(@dirs) = grep { -e } ($archlib, $sitearch);
  135.     find($sub, @dirs) if @dirs;
  136.  
  137.     return(bless($self, $class));
  138. }
  139.  
  140. # VMS's non-case preserving file-system means the package name can't
  141. # be reconstructed from the filename.
  142. sub _module_name {
  143.     my($file, $orig_module) = @_;
  144.  
  145.     my $module = '';
  146.     if (open PACKFH, $file) {
  147.         while (<PACKFH>) {
  148.             if (/package\s+(\S+)\s*;/) {
  149.                 my $pack = $1;
  150.                 # Make a sanity check, that lower case $module
  151.                 # is identical to lowercase $pack before
  152.                 # accepting it
  153.                 if (lc($pack) eq lc($orig_module)) {
  154.                     $module = $pack;
  155.                     last;
  156.                 }
  157.             }
  158.         }
  159.         close PACKFH;
  160.     }
  161.  
  162.     print STDERR "Couldn't figure out the package name for $file\n"
  163.       unless $module;
  164.  
  165.     return $module;
  166. }
  167.  
  168.  
  169.  
  170. sub modules {
  171.     my ($self) = @_;
  172.  
  173.     # Bug/feature of sort in scalar context requires this.
  174.     return wantarray ? sort keys %$self : keys %$self;
  175. }
  176.  
  177. sub files {
  178.     my ($self, $module, $type, @under) = @_;
  179.  
  180.     # Validate arguments
  181.     Carp::croak("$module is not installed") if (! exists($self->{$module}));
  182.     $type = "all" if (! defined($type));
  183.     Carp::croak('type must be "all", "prog" or "doc"')
  184.         if ($type ne "all" && $type ne "prog" && $type ne "doc");
  185.  
  186.     my (@files);
  187.     foreach my $file (keys(%{$self->{$module}{packlist}})) {
  188.         push(@files, $file)
  189.           if ($self->_is_type($file, $type) && 
  190.               $self->_is_under($file, @under));
  191.     }
  192.     return(@files);
  193. }
  194.  
  195. sub directories {
  196.     my ($self, $module, $type, @under) = @_;
  197.     my (%dirs);
  198.     foreach my $file ($self->files($module, $type, @under)) {
  199.         $dirs{dirname($file)}++;
  200.     }
  201.     return sort keys %dirs;
  202. }
  203.  
  204. sub directory_tree {
  205.     my ($self, $module, $type, @under) = @_;
  206.     my (%dirs);
  207.     foreach my $dir ($self->directories($module, $type, @under)) {
  208.         $dirs{$dir}++;
  209.         my ($last) = ("");
  210.         while ($last ne $dir) {
  211.             $last = $dir;
  212.             $dir = dirname($dir);
  213.             last if !$self->_is_under($dir, @under);
  214.             $dirs{$dir}++;
  215.         }
  216.     }
  217.     return(sort(keys(%dirs)));
  218. }
  219.  
  220. sub validate {
  221.     my ($self, $module, $remove) = @_;
  222.     Carp::croak("$module is not installed") if (! exists($self->{$module}));
  223.     return($self->{$module}{packlist}->validate($remove));
  224. }
  225.  
  226. sub packlist {
  227.     my ($self, $module) = @_;
  228.     Carp::croak("$module is not installed") if (! exists($self->{$module}));
  229.     return($self->{$module}{packlist});
  230. }
  231.  
  232. sub version {
  233.     my ($self, $module) = @_;
  234.     Carp::croak("$module is not installed") if (! exists($self->{$module}));
  235.     return($self->{$module}{version});
  236. }
  237.  
  238.  
  239. 1;
  240.  
  241. __END__
  242.  
  243. =head1 NAME
  244.  
  245. ExtUtils::Installed - Inventory management of installed modules
  246.  
  247. =head1 SYNOPSIS
  248.  
  249.    use ExtUtils::Installed;
  250.    my ($inst) = ExtUtils::Installed->new();
  251.    my (@modules) = $inst->modules();
  252.    my (@missing) = $inst->validate("DBI");
  253.    my $all_files = $inst->files("DBI");
  254.    my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
  255.    my $all_dirs = $inst->directories("DBI");
  256.    my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
  257.    my $packlist = $inst->packlist("DBI");
  258.  
  259. =head1 DESCRIPTION
  260.  
  261. ExtUtils::Installed  provides a standard way to find out what core and module
  262. files have been installed.  It uses the information stored in .packlist files
  263. created during installation to provide this information.  In addition it
  264. provides facilities to classify the installed files and to extract directory
  265. information from the .packlist files.
  266.  
  267. =head1 USAGE
  268.  
  269. The new() function searches for all the installed .packlists on the system, and
  270. stores their contents. The .packlists can be queried with the functions
  271. described below.
  272.  
  273. =head1 FUNCTIONS
  274.  
  275. =over 4
  276.  
  277. =item new()
  278.  
  279. This takes no parameters, and searches for all the installed .packlists on the
  280. system.  The packlists are read using the ExtUtils::packlist module.
  281.  
  282. =item modules()
  283.  
  284. This returns a list of the names of all the installed modules.  The perl 'core'
  285. is given the special name 'Perl'.
  286.  
  287. =item files()
  288.  
  289. This takes one mandatory parameter, the name of a module.  It returns a list of
  290. all the filenames from the package.  To obtain a list of core perl files, use
  291. the module name 'Perl'.  Additional parameters are allowed.  The first is one
  292. of the strings "prog", "doc" or "all", to select either just program files,
  293. just manual files or all files.  The remaining parameters are a list of
  294. directories. The filenames returned will be restricted to those under the
  295. specified directories.
  296.  
  297. =item directories()
  298.  
  299. This takes one mandatory parameter, the name of a module.  It returns a list of
  300. all the directories from the package.  Additional parameters are allowed.  The
  301. first is one of the strings "prog", "doc" or "all", to select either just
  302. program directories, just manual directories or all directories.  The remaining
  303. parameters are a list of directories. The directories returned will be
  304. restricted to those under the specified directories.  This method returns only
  305. the leaf directories that contain files from the specified module.
  306.  
  307. =item directory_tree()
  308.  
  309. This is identical in operation to directories(), except that it includes all the
  310. intermediate directories back up to the specified directories.
  311.  
  312. =item validate()
  313.  
  314. This takes one mandatory parameter, the name of a module.  It checks that all
  315. the files listed in the modules .packlist actually exist, and returns a list of
  316. any missing files.  If an optional second argument which evaluates to true is
  317. given any missing files will be removed from the .packlist
  318.  
  319. =item packlist()
  320.  
  321. This returns the ExtUtils::Packlist object for the specified module.
  322.  
  323. =item version()
  324.  
  325. This returns the version number for the specified module.
  326.  
  327. =back
  328.  
  329. =head1 EXAMPLE
  330.  
  331. See the example in L<ExtUtils::Packlist>.
  332.  
  333. =head1 AUTHOR
  334.  
  335. Alan Burlison <Alan.Burlison@uk.sun.com>
  336.  
  337. =cut
  338.