summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/ExtUtils/Installed.pm
blob: 8327a95a3dbe410d192208180dec797f3289b5a9 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
package ExtUtils::Installed;

use 5.00503;
use strict;
#use warnings; # XXX requires 5.6
use Carp qw();
use ExtUtils::Packlist;
use ExtUtils::MakeMaker;
use Config;
use File::Find;
use File::Basename;
use File::Spec;

my $Is_VMS = $^O eq 'VMS';
my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);

require VMS::Filespec if $Is_VMS;

use vars qw($VERSION);
$VERSION = '2.14';
$VERSION = eval $VERSION;

sub _is_prefix {
    my ($self, $path, $prefix) = @_;
    return unless defined $prefix && defined $path;

    if( $Is_VMS ) {
        $prefix = VMS::Filespec::unixify($prefix);
        $path   = VMS::Filespec::unixify($path);
    }

    # Unix path normalization.
    $prefix = File::Spec->canonpath($prefix);

    return 1 if substr($path, 0, length($prefix)) eq $prefix;

    if ($DOSISH) {
        $path =~ s|\\|/|g;
        $prefix =~ s|\\|/|g;
        return 1 if $path =~ m{^\Q$prefix\E}i;
    }
    return(0);
}

sub _is_doc {
    my ($self, $path) = @_;

    my $man1dir = $self->{':private:'}{Config}{man1direxp};
    my $man3dir = $self->{':private:'}{Config}{man3direxp};
    return(($man1dir && $self->_is_prefix($path, $man1dir))
           ||
           ($man3dir && $self->_is_prefix($path, $man3dir))
           ? 1 : 0)
}

sub _is_type {
    my ($self, $path, $type) = @_;
    return 1 if $type eq "all";

    return($self->_is_doc($path)) if $type eq "doc";
    my $conf= $self->{':private:'}{Config};
    if ($type eq "prog") {
        return($self->_is_prefix($path, $conf->{prefix} || $conf->{prefixexp})
               && !($self->_is_doc($path)) ? 1 : 0);
    }
    return(0);
}

sub _is_under {
    my ($self, $path, @under) = @_;
    $under[0] = "" if (! @under);
    foreach my $dir (@under) {
        return(1) if ($self->_is_prefix($path, $dir));
    }

    return(0);
}

sub _fix_dirs {
    my ($self, @dirs)= @_;
    # File::Find does not know how to deal with VMS filepaths.
    if( $Is_VMS ) {
        $_ = VMS::Filespec::unixify($_)
            for @dirs;
    }

    if ($DOSISH) {
        s|\\|/|g for @dirs;
    }
    return wantarray ? @dirs : $dirs[0];
}

sub _make_entry {
    my ($self, $module, $packlist_file, $modfile)= @_;

    my $data= {
        module => $module,
        packlist => scalar(ExtUtils::Packlist->new($packlist_file)),
        packlist_file => $packlist_file,
    };

    if (!$modfile) {
        $data->{version} = $self->{':private:'}{Config}{version};
    } else {
        $data->{modfile} = $modfile;
        # Find the top-level module file in @INC
        $data->{version} = '';
        foreach my $dir (@{$self->{':private:'}{INC}}) {
            my $p = File::Spec->catfile($dir, $modfile);
            if (-r $p) {
                $module = _module_name($p, $module) if $Is_VMS;

                $data->{version} = MM->parse_version($p);
                $data->{version_from} = $p;
                $data->{packlist_valid} = exists $data->{packlist}{$p};
                last;
            }
        }
    }
    $self->{$module}= $data;
}

our $INSTALLED;
sub new {
    my ($class) = shift(@_);
    $class = ref($class) || $class;

    my %args = @_;

    return $INSTALLED if $INSTALLED and ($args{default_get} || $args{default});

    my $self = bless {}, $class;

    $INSTALLED= $self if $args{default_set} || $args{default};


    if ($args{config_override}) {
        eval {
            $self->{':private:'}{Config} = { %{$args{config_override}} };
        } or Carp::croak(
            "The 'config_override' parameter must be a hash reference."
        );
    }
    else {
        $self->{':private:'}{Config} = \%Config;
    }

    for my $tuple ([inc_override => INC => [ @INC ] ],
                   [ extra_libs => EXTRA => [] ])
    {
        my ($arg,$key,$val)=@$tuple;
        if ( $args{$arg} ) {
            eval {
                $self->{':private:'}{$key} = [ @{$args{$arg}} ];
            } or Carp::croak(
                "The '$arg' parameter must be an array reference."
            );
        }
        elsif ($val) {
            $self->{':private:'}{$key} = $val;
        }
    }
    {
        my %dupe;
        @{$self->{':private:'}{LIBDIRS}} =
            grep { $_ ne '.' || ! $args{skip_cwd} }
            grep { -e $_ && !$dupe{$_}++ }
            @{$self->{':private:'}{EXTRA}}, @{$self->{':private:'}{INC}};
    }

    my @dirs= $self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}});

    # Read the core packlist
    my $archlib = $self->_fix_dirs($self->{':private:'}{Config}{archlibexp});
    $self->_make_entry("Perl",File::Spec->catfile($archlib, '.packlist'));

    my $root;
    # Read the module packlists
    my $sub = sub {
        # Only process module .packlists
        return if $_ ne ".packlist" || $File::Find::dir eq $archlib;

        # Hack of the leading bits of the paths & convert to a module name
        my $module = $File::Find::name;
        my $found = $module =~ s!^.*?/auto/(.*)/.packlist!$1!s
            or do {
            # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n",
            #    join ("\n",@dirs);
            return;
        };

        my $modfile = "$module.pm";
        $module =~ s!/!::!g;

        return if $self->{$module}; #shadowing?
        $self->_make_entry($module,$File::Find::name,$modfile);
    };
    while (@dirs) {
        $root= shift @dirs;
        next if !-d $root;
        find($sub,$root);
    }

    return $self;
}

# VMS's non-case preserving file-system means the package name can't
# be reconstructed from the filename.
sub _module_name {
    my($file, $orig_module) = @_;

    my $module = '';
    if (open PACKFH, $file) {
        while (<PACKFH>) {
            if (/package\s+(\S+)\s*;/) {
                my $pack = $1;
                # Make a sanity check, that lower case $module
                # is identical to lowercase $pack before
                # accepting it
                if (lc($pack) eq lc($orig_module)) {
                    $module = $pack;
                    last;
                }
            }
        }
        close PACKFH;
    }

    print STDERR "Couldn't figure out the package name for $file\n"
      unless $module;

    return $module;
}

sub modules {
    my ($self) = @_;
    $self= $self->new(default=>1) if !ref $self;

    # Bug/feature of sort in scalar context requires this.
    return wantarray
        ? sort grep { not /^:private:$/ } keys %$self
        : grep { not /^:private:$/ } keys %$self;
}

sub files {
    my ($self, $module, $type, @under) = @_;
    $self= $self->new(default=>1) if !ref $self;

    # Validate arguments
    Carp::croak("$module is not installed") if (! exists($self->{$module}));
    $type = "all" if (! defined($type));
    Carp::croak('type must be "all", "prog" or "doc"')
        if ($type ne "all" && $type ne "prog" && $type ne "doc");

    my (@files);
    foreach my $file (keys(%{$self->{$module}{packlist}})) {
        push(@files, $file)
          if ($self->_is_type($file, $type) &&
              $self->_is_under($file, @under));
    }
    return(@files);
}

sub directories {
    my ($self, $module, $type, @under) = @_;
    $self= $self->new(default=>1) if !ref $self;
    my (%dirs);
    foreach my $file ($self->files($module, $type, @under)) {
        $dirs{dirname($file)}++;
    }
    return sort keys %dirs;
}

sub directory_tree {
    my ($self, $module, $type, @under) = @_;
    $self= $self->new(default=>1) if !ref $self;
    my (%dirs);
    foreach my $dir ($self->directories($module, $type, @under)) {
        $dirs{$dir}++;
        my ($last) = ("");
        while ($last ne $dir) {
            $last = $dir;
            $dir = dirname($dir);
            last if !$self->_is_under($dir, @under);
            $dirs{$dir}++;
        }
    }
    return(sort(keys(%dirs)));
}

sub validate {
    my ($self, $module, $remove) = @_;
    $self= $self->new(default=>1) if !ref $self;
    Carp::croak("$module is not installed") if (! exists($self->{$module}));
    return($self->{$module}{packlist}->validate($remove));
}

sub packlist {
    my ($self, $module) = @_;
    $self= $self->new(default=>1) if !ref $self;
    Carp::croak("$module is not installed") if (! exists($self->{$module}));
    return($self->{$module}{packlist});
}

sub version {
    my ($self, $module) = @_;
    $self= $self->new(default=>1) if !ref $self;
    Carp::croak("$module is not installed") if (! exists($self->{$module}));
    return($self->{$module}{version});
}

sub debug_dump {
    my ($self, $module) = @_;
    $self= $self->new(default=>1) if !ref $self;
    local $self->{":private:"}{Config};
    require Data::Dumper;
    print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump();
}


1;

__END__

=head1 NAME

ExtUtils::Installed - Inventory management of installed modules

=head1 SYNOPSIS

   use ExtUtils::Installed;
   my ($inst) = ExtUtils::Installed->new( skip_cwd => 1 );
   my (@modules) = $inst->modules();
   my (@missing) = $inst->validate("DBI");
   my $all_files = $inst->files("DBI");
   my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
   my $all_dirs = $inst->directories("DBI");
   my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
   my $packlist = $inst->packlist("DBI");

=head1 DESCRIPTION

ExtUtils::Installed  provides a standard way to find out what core and module
files have been installed.  It uses the information stored in .packlist files
created during installation to provide this information.  In addition it
provides facilities to classify the installed files and to extract directory
information from the .packlist files.

=head1 USAGE

The new() function searches for all the installed .packlists on the system, and
stores their contents. The .packlists can be queried with the functions
described below. Where it searches by default is determined by the settings found
in C<%Config::Config>, and what the value is of the PERL5LIB environment variable.

=head1 METHODS

Unless specified otherwise all method can be called as class methods, or as object
methods. If called as class methods then the "default" object will be used, and if
necessary created using the current processes %Config and @INC.  See the
'default' option to new() for details.


=over 4

=item new()

This takes optional named parameters. Without parameters, this
searches for all the installed .packlists on the system using
information from C<%Config::Config> and the default module search
paths C<@INC>. The packlists are read using the
L<ExtUtils::Packlist> module.

If the named parameter C<skip_cwd> is true, the current directory C<.> will
be stripped from C<@INC> before searching for .packlists.  This keeps
ExtUtils::Installed from finding modules installed in other perls that
happen to be located below the current directory.

If the named parameter C<config_override> is specified,
it should be a reference to a hash which contains all information
usually found in C<%Config::Config>. For example, you can obtain
the configuration information for a separate perl installation and
pass that in.

    my $yoda_cfg  = get_fake_config('yoda');
    my $yoda_inst =
               ExtUtils::Installed->new(config_override=>$yoda_cfg);

Similarly, the parameter C<inc_override> may be a reference to an
array which is used in place of the default module search paths
from C<@INC>.

    use Config;
    my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB});
    my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs);

B<Note>: You probably do not want to use these options alone, almost always
you will want to set both together.

The parameter C<extra_libs> can be used to specify B<additional> paths to
search for installed modules. For instance

    my $installed =
             ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]);

This should only be necessary if F</my/lib/path> is not in PERL5LIB.

Finally there is the 'default', and the related 'default_get' and 'default_set'
options. These options control the "default" object which is provided by the
class interface to the methods. Setting C<default_get> to true tells the constructor
to return the default object if it is defined. Setting C<default_set> to true tells
the constructor to make the default object the constructed object. Setting the
C<default> option is like setting both to true. This is used primarily internally
and probably isn't interesting to any real user.

=item modules()

This returns a list of the names of all the installed modules.  The perl 'core'
is given the special name 'Perl'.

=item files()

This takes one mandatory parameter, the name of a module.  It returns a list of
all the filenames from the package.  To obtain a list of core perl files, use
the module name 'Perl'.  Additional parameters are allowed.  The first is one
of the strings "prog", "doc" or "all", to select either just program files,
just manual files or all files.  The remaining parameters are a list of
directories. The filenames returned will be restricted to those under the
specified directories.

=item directories()

This takes one mandatory parameter, the name of a module.  It returns a list of
all the directories from the package.  Additional parameters are allowed.  The
first is one of the strings "prog", "doc" or "all", to select either just
program directories, just manual directories or all directories.  The remaining
parameters are a list of directories. The directories returned will be
restricted to those under the specified directories.  This method returns only
the leaf directories that contain files from the specified module.

=item directory_tree()

This is identical in operation to directories(), except that it includes all the
intermediate directories back up to the specified directories.

=item validate()

This takes one mandatory parameter, the name of a module.  It checks that all
the files listed in the modules .packlist actually exist, and returns a list of
any missing files.  If an optional second argument which evaluates to true is
given any missing files will be removed from the .packlist

=item packlist()

This returns the ExtUtils::Packlist object for the specified module.

=item version()

This returns the version number for the specified module.

=back

=head1 EXAMPLE

See the example in L<ExtUtils::Packlist>.

=head1 AUTHOR

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

=cut