view release on metacpan or  search on metacpan

lib/App/lcpan.pm  view on Meta::CPAN

our %argspec0opt_dists_with_optional_vers = (
    dists => {
        summary => 'Distribution names (with optional version suffix, e.g. Foo-Bar@1.23)',
        schema => ['array*', of=>'perl::distname_with_optional_ver*', min_len=>1],
        'x.name.is_plural' => 1,
        pos => 0,
        slurpy => 1,
        cmdline_src => 'stdin_or_args',
        element_completion => \&_complete_dist,
    },
);

our %rel_args = (
    release => {
        schema => 'str*', # XXX perl::relname
        req => 1,
        pos => 0,
        completion => \&_complete_rel,
    },
);

our %dist_or_rel_args = (
    dist_or_release => {
        schema => 'str*', # XXX [any, of=>[perl::relname, perl::distname]]
        req => 1,
        pos => 0,
        completion => \&_complete_dist, # XXX dist/release
    },
);

our %sort_args_for_rels = (
    sort => {
        schema => ['array*', of=>['str*', in=>[qw/author -author size -size name -name mtime -mtime/]]],
        default => ['name'],
        tags => ['category:sorting'],
    },
    %random_args,
);

our %overwrite_args = (
    overwrite => {
        summary => 'Whether to overwrite existing file',
        schema => ['bool*', is=>1],
        cmdline_aliases => {o=>{}},
    },
);

$SPEC{':package'} = {
    v => 1.1,
    summary => 'Manage local CPAN mirror',
};

sub _set_args_default {
    my $args = shift;
    if (!$args->{cpan}) {
        require File::HomeDir;
        $args->{cpan} = File::HomeDir->my_home . '/cpan';
    }
    $args->{index_name} //= 'index.db';
    if (!defined($args->{num_backups})) {
        $args->{num_backups} = 7;
    }
    $args->{use_bootstrap} //= 1;
    $args->{update_db_schema} //= 1;
}

# set {added_,updated_,added_or_udpated_}since from
# {added_,updated_,added_or_updated_}since_last_{index_update,n_index_updates},
# set, since SQL query will usually use the former
sub _set_since {
    my ($args, $dbh) = @_;

    my $num_sinces = 0;
    if (defined $args->{added_since}) { $num_sinces++ }
    if (defined $args->{updated_since}) { $num_sinces++ }
    if (defined $args->{added_or_updated_since}) { $num_sinces++ }
    if (defined $args->{added_since_last_index_update} || defined $args->{updated_since_last_index_update} || defined $args->{added_or_updated_since_last_index_update}) {
        my ($time) = $dbh->selectrow_array("SELECT date FROM log WHERE category='update_index' AND summary LIKE 'Begin%' ORDER BY date DESC");
        die "Index has not been updated at all, cannot use {added_,updated_,added_or_updated_}since_last_index_update option" unless $time;
        if (delete $args->{added_since_last_index_update})            { $args->{added_since}            //= $time; log_trace "Setting added_since=%s", $time; $num_sinces++ }
        if (delete $args->{updated_since_last_index_update})          { $args->{updated_since}          //= $time; log_trace "Setting updated_since=%s", $time; $num_sinces++ }
        if (delete $args->{added_or_updated_since_last_index_update}) { $args->{added_or_updated_since} //= $time; log_trace "Setting added_or_updated_since=%s", $time; $num_sinces++ }
    }
    if (defined $args->{added_since_last_n_index_updates} || defined $args->{updated_since_last_n_index_updates} || defined $args->{added_or_updated_since_last_n_index_updates}) {
        my $n = int($args->{added_since_last_n_index_updates} // $args->{updated_since_last_n_index_updates} // $args->{added_or_updated_since_last_n_index_updates});
        $n = 1 if $n < 1;
        my $sth = $dbh->prepare("SELECT date FROM log WHERE category='update_index' AND summary LIKE 'Begin%' ORDER BY date DESC");
        $sth->execute;
        my $i = 0;
        my $time;
        1 while ++$i <= $n && (($time) = $sth->fetchrow_array);
        die "Index has not been updated that many times, please set a lower number for {,added_,updated_}since_last_n_index_updates option" if $i < $n;
        if (delete $args->{added_since_last_n_index_updates})            { $args->{added_since}            //= $time; log_trace "Setting added_since=%s", $time; $num_sinces++ }
        if (delete $args->{updated_since_last_n_index_updates})          { $args->{updated_since}          //= $time; log_trace "Setting updated_since=%s", $time; $num_sinces++ }
        if (delete $args->{added_or_updated_since_last_n_index_updates}) { $args->{added_or_updated_since} //= $time; log_trace "Setting added_or_updated_since=%s", $time; $num_sinces++ }
    }

    die "Multiple {added_,updated_,added_or_updated_}since options set, please set only one to avoid confusion" if $num_sinces > 1;
}

sub _add_since_where_clause {
    my ($args, $where, $table) = @_;
    if (defined $args->{added_since}  )          { push @$where, "$table.rec_ctime >= ". (0+$args->{added_since}) }
    if (defined $args->{updated_since})          { push @$where, "($table.rec_mtime >= ". (0+$args->{updated_since}). " AND $table.rec_ctime < ".(0+$args->{updated_since}). ")" }
    if (defined $args->{added_or_updated_since}) { push @$where, "($table.rec_ctime >= ". (0+$args->{added_or_updated_since}). " OR $table.rec_mtime >= ". (0+$args->{added_or_updated_since}). ")" }
}

sub _fmt_time {
    require POSIX;

    my $epoch = shift;
    return '' unless defined($epoch);
    POSIX::strftime("%Y-%m-%dT%H:%M:%SZ", gmtime($epoch));
}

sub _numify_ver {
    my $v;
    eval { $v = version->parse($_[0]) };
    $v ? $v->numify : undef;
}

lib/App/lcpan.pm  view on Meta::CPAN

    [200, "OK", \@members, {'func.zip' => $zip, 'func.tar' => $tar}];
}

sub _get_meta {
    my ($la_res) = @_;
    my @members = _sort_prefer_metajson_over_metayml(@{$la_res->[2]});

    my $zip = $la_res->[3]{'func.zip'};
    my $tar = $la_res->[3]{'func.tar'};
    my $meta;

    if ($zip) {
        for my $member (@members) {
            if ($member->fileName =~ m!(?:/|\\)?(META\.yml|META\.json)$!) {
                log_trace("  found META: %s", $member->fileName);
                my $type = $1;
                #log_trace("content=[[%s]]", $content);
                my $content = $zip->contents($member);
                if ($type eq 'META.yml') {
                    (my $metaerr, $meta) = _parse_meta_yml($content);
                    return [500, $metaerr] if $metaerr;
                } elsif ($type eq 'META.json') {
                    (my $metaerr, $meta) = _parse_meta_json($content);
                    return [500, $metaerr] if $metaerr;
                }
                last;
            }
        }
    } else {
        for my $member (@members) {
            if ($member->{full_path} =~ m!/?(META\.yml|META\.json)$!) {
                log_trace("  found META %s", $member->{full_path});
                my $type = $1;
                my ($obj) = $tar->get_files($member->{full_path});
                my $content = $obj->get_content;
                if ($type eq 'META.yml') {
                    (my $metaerr, $meta) = _parse_meta_yml($content);
                    return [500, $metaerr] if $metaerr;
                } elsif ($type eq 'META.json') {
                    (my $metaerr, $meta) = _parse_meta_json($content);
                    return [500, $metaerr] if $metaerr;
                }
                last;
            }
        }
    }
    [200, "OK", $meta];
}

sub _update_index {
    require DBI;
    require File::Temp;
    require IO::Compress::Gzip;

    my %args = @_;
    _set_args_default(\%args);
    my $cpan = $args{cpan};
    my $index_name = $args{index_name};

    my $db_path = _db_path($cpan, $index_name);
    if ($args{num_backups} > 0 && (-f $db_path)) {
        require File::Copy;
        require Logfile::Rotate;
        log_info("Rotating old indexes ...");
        my $rotate = Logfile::Rotate->new(
            File  => $db_path,
            Count => $args{num_backups},
            Gzip  => 'no',
        );
        $rotate->rotate;
        File::Copy::copy("$db_path.1", $db_path)
              or return [500, "Copy $db_path.1 -> $db_path failed: $!"];
    }

    my $dbh  = _connect_db('rw', $cpan, $index_name, $args{use_bootstrap}, $args{update_db_schema});

    # check whether we need to reindex if a sufficiently old (and possibly
    # incorrect) version of us did the reindexing
    {
        no strict 'refs'; ## no critic: TestingAndDebugging::ProhibitNoStrict
        my $our_version = ${__PACKAGE__.'::VERSION'};

        my ($indexer_version) = $dbh->selectrow_array("SELECT value FROM meta WHERE name='indexer_version'");
        last unless $indexer_version;
        if ($our_version && version->parse($indexer_version) > version->parse($our_version)) {
            return [412, "Database is indexed by version ($indexer_version) newer than current software's version ($our_version), bailing out"];
        }
        if (version->parse($indexer_version) <= version->parse("0.35")) {
            log_info("Reindexing from scratch, deleting previous index content ...");
            _reset($dbh);
        }
    }

    _dblog($dbh, 40, "update_index", "Begin updating index");

    # parse 01mailrc.txt.gz and insert the parse result to 'author' table
  PARSE_MAILRC:
    {
        require DBIx::UpdateTable::FromHoH;

        my $path = "$cpan/authors/01mailrc.txt.gz";
        log_info("Parsing %s ...", $path);
        open my($fh), "<:gzip", $path or do {
            log_info("%s does not exist, skipped", $path);
            last PARSE_MAILRC;
        };

        my $hoh = {};
        my $line = 0;
        while (<$fh>) {
            $line++;
            my ($cpanid, $fullname, $email) = /^alias (\S+)\s+"(.*) <(.+)>"/ or do {
                log_warn("  line %d: syntax error, skipped: %s", $line, $_);
                next;
            };
            $hoh->{$cpanid} = {fullname=>$fullname, email=>$email};
        }
        my $now = time();
        my $res = DBIx::UpdateTable::FromHoH::update_table_from_hoh(
            dbh => $dbh,
            table => 'author',
            hoh => $hoh,
            key_column => 'cpanid',
            data_columns => [qw/fullname email/],
            extra_insert_columns => {rec_ctime=>$now, rec_mtime=>$now},
            extra_update_columns => {rec_mtime=>$now},
        );