view release on metacpan or  search on metacpan

lib/CPAN/Common/Index/Mirror.pm  view on Meta::CPAN

        my $v   = version->parse($arg);
        return sub {
            eval { version->parse( $_[0] ) == $v };
        };
    },
);

my %QUERY_TYPES = (
    # package search
    package => 'regexp',
    version => 'version',
    dist    => 'regexp',

    # author search
    id       => 'regexp_nocase', # XXX need to add "alias " first
    fullname => 'regexp_nocase',
    email    => 'regexp_nocase',
);

sub cached_package {
    my ($self) = @_;
    my $package = File::Spec->catfile( $self->cache,
        File::Basename::basename( $INDICES{packages} ) );
    $package =~ s/\.gz$//;
    $self->refresh_index unless -r $package;
    return $package;
}

sub cached_mailrc {
    my ($self) = @_;
    my $mailrc =
      File::Spec->catfile( $self->cache, File::Basename::basename( $INDICES{mailrc} ) );
    $mailrc =~ s/\.gz$//;
    $self->refresh_index unless -r $mailrc;
    return $mailrc;
}

sub refresh_index {
    my ($self) = @_;
    for my $file ( values %INDICES ) {
        my $remote = URI->new_abs( $file, $self->mirror );
        $remote =~ s/\.gz$//
          unless $HAS_IO_UNCOMPRESS_GUNZIP;
        my $ff = File::Fetch->new( uri => $remote );
        my $where = $ff->fetch( to => $self->cache )
          or Carp::croak( $ff->error );
        if ($HAS_IO_UNCOMPRESS_GUNZIP) {
            ( my $uncompressed = $where ) =~ s/\.gz$//;
            no warnings 'once';
            IO::Uncompress::Gunzip::gunzip( $where, $uncompressed )
              or Carp::croak "gunzip failed: $IO::Uncompress::Gunzip::GunzipError\n";
        }
    }
    return 1;
}

# epoch secs
sub index_age {
    my ($self) = @_;
    my $package = $self->cached_package;
    return ( -r $package ? ( stat($package) )[9] : 0 ); # mtime if readable
}

sub search_packages {
    my ( $self, $args ) = @_;
    Carp::croak("Argument to search_packages must be hash reference")
      unless ref $args eq 'HASH';

    my $index_path = $self->cached_package;
    die "Can't read $index_path" unless -r $index_path;

    my $fh = IO::Handle->new;
    tie *$fh, 'Tie::Handle::SkipHeader', "<", $index_path
      or die "Can't tie $index_path: $!";

    # Convert scalars or regexps to subs
    my $rules;
    while ( my ( $k, $v ) = each %$args ) {
        $rules->{$k} = _rulify( $k, $v );
    }

    my @found;
    if ( $args->{package} and ref $args->{package} eq '' ) {
        # binary search 02packages on package
        my $pos = look $fh, $args->{package}, { xfrm => \&_xform_package, fold => 1 };
        return if $pos == -1;
        # loop over any case-insensitive matching lines
        LINE: while ( my $line = <$fh> ) {
            last unless $line =~ /\A\Q$args->{package}\E\s+/i;
            push @found, _match_package_line( $line, $rules );
        }
    }
    else {
        # iterate all lines looking for match
        LINE: while ( my $line = <$fh> ) {
            push @found, _match_package_line( $line, $rules );
        }
    }
    return wantarray ? @found : $found[0];
}

sub search_authors {
    my ( $self, $args ) = @_;
    Carp::croak("Argument to search_authors must be hash reference")
      unless ref $args eq 'HASH';

    my $index_path = $self->cached_mailrc;
    die "Can't read $index_path" unless -r $index_path;
    open my $fh, $index_path or die "Can't open $index_path: $!";

    # Convert scalars or regexps to subs
    my $rules;
    while ( my ( $k, $v ) = each %$args ) {
        $rules->{$k} = _rulify( $k, $v );
    }

    my @found;
    if ( $args->{id} and ref $args->{id} eq '' ) {
        # binary search mailrec on package
        my $pos = look $fh, $args->{id}, { xfrm => \&_xform_mailrc, fold => 1 };
        return if $pos == -1;