view release on metacpan or  search on metacpan

lib/lib/archive.pm  view on Meta::CPAN

If the archive contains a toplevel directory 'lib' the module search path
will start there. Otherwise it will start from the root of the archive.

If the archive is a gzipped TAR archive with the extension '.tar.gz' and the
archive contains a toplevel directory matching the archive name without the
extension the module search path starts with this directory. The above
rule for the subdirectory 'lib' applies from there. This means that e.g. for
'JSON-PP-2.97001.tar.gz' the modules will only be included from
'JSON-PP-2.97001/lib'.

You can use URLs for loading modules directly from CPAN. Either specify the
complete URL like:

  use lib::archive 'https://www.cpan.org/modules/by-module/JSON/JSON-PP-2.97001.tar.gz';

or use a shortcut like:

  use lib::archive 'CPAN://JSON-PP-2.97001.tar.gz';

which will do exactly the same thing (at least in most cases: there seem to
be modules without an entry under 'modules/by-module/<toplevel>'; in that
case you have to use an URL pointing to the file under 'authors/id').

If the environment variable CPAN_MIRROR is set, it will be used instead of
'https://www.cpan.org'.

For temporary excluding modules from being loaded via lib::archive the
environment variable PERL_LIB_ARCHIVE_IGNORE can be set to a regular expression.
It will be matched against the relative pathname of the modules (e.g. C<JSON/PP.pm>).
A leading C<!> will be split off and invert the match.

=head1 WHY

There are two use cases that motivated the creation of this module:

=over

=item 1. bundling various self written modules as a versioned release

=item 2. quickly switching between different versions of a module for debugging purposes

=back

=head1 AUTHOR

Thomas Kratz E<lt>tomk@cpan.orgE<gt>

=cut

my $cpan   = $ENV{CPAN_MIRROR} || 'https://www.cpan.org';
my $rx_url = qr!^(?:CPAN|https?)://!;
my $tar    = Archive::Tar->new();
my $home   = $ENV{PERL_LIB_ARCHIVE_HOME} // glob('~');


sub import {
    my ( $class, @entries ) = @_;
    my %cache;

    my $caller_file    = (caller)[1];
    my $under_debugger = defined($DB::single);
    my $extract_dir    = $ENV{PERL_LIB_ARCHIVE_EXTRACT} // "$home/.lib_archive_extract";
    my $ignore         = _get_ignore_sub();
    my $under_cover    = defined($Devel::Cover::VERSION) && !$ENV{PERL_LIB_ARCHIVE_TESTING};

    for my $entry (@entries) {
        my $is_url = $entry =~ /$rx_url/;
        my $arcs
            = $is_url                  ? _get_url($entry)
            : ( $entry eq '__DATA__' ) ? _get_data($caller_file)
            :                            _get_files( $entry, $caller_file );
        for my $arc (@$arcs) {
            my $path = $is_url ? $entry : $arc->[0];
            my $base = basename($path);
            my @ver  = $base =~ /(v?\d+\.\d+(?:\.\d+)?)/gi;
            my %tmp;
            my $mod = 0;
            my $lib = 0;
            for my $f ( $tar->read( $arc->[0] ) ) {
                next unless ( my $full = $f->full_path ) =~ /\.pm$/;
                my @parts = split( '/', $full );
                ++$mod && shift @parts if $parts[0] eq $arc->[1];
                ++$lib && shift @parts if $parts[0] eq 'lib';
                my $rel = join( '/', @parts );
                $tmp{$rel}{$full} = $f->get_content_by_ref;
            }
            for my $rel ( keys %tmp ) {
                my $full = join( '/', $mod ? $arc->[1] : (), $lib ? 'lib' : (), $rel );
                $cache{$rel} //= { path => "$path/$full", content => $tmp{$rel}{$full}, arcver => $ver[-1] // '' };
            }
        }
    }

    unshift @INC, sub {
        my ( $cref, $rel ) = @_;
        return if $ignore and $ignore->($rel);
        return unless my $rec = $cache{$rel};
        $INC{$rel} = _expand( $rel, $rec->{content}, $rec->{arcver}, $extract_dir )
            if $ENV{PERL_LIB_ARCHIVE_EXTRACT}
            or ( $under_debugger and not $under_cover );
        $INC{$rel} //= $rec->{path} unless $under_debugger;
        open( my $pfh, '<', $rec->{content} ) or croak $!;
        return $pfh;
    };

    return;
}


sub _get_files {
    my ( $glob, $cfile ) = @_;
    ( my $glob_ux = $glob )                      =~ s!\\!/!g;
    ( my $cdir    = dirname( rel2abs($cfile) ) ) =~ s!\\!/!g;
    $glob_ux = "$cdir/$glob_ux" unless file_name_is_absolute($glob_ux);
    my @files;
    for my $f ( sort glob($glob_ux) ) {
        my ( $module, $dirs, $suffix ) = fileparse( $f, qr/\.tar\.gz/ );
        push @files, [ $f, $module ];
    }
    return \@files;