view release on metacpan or  search on metacpan

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

sub update_from_modules {
    require Module::List;
    require Module::Path::More;
    require Package::Util::Lite;

    my %args = @_;

    my ($res, $dbh) = _connect_db(\%args);
    return $res unless $res->[0] == 200;

    my $exc = $args{exclude} // [];

    my @pkgs;
    for my $entry (@{ $args{module_or_package} }) {
        if ($entry =~ /\A\+(.+)::\z/) {
            # package prefix
            log_debug("Listing all packages under $1 ...");
            for my $p (Package::Util::Lite::list_subpackages($1, 1)) {
                next if (grep { $_ eq $p } @pkgs) || _is_excluded($_, $exc);
                push @pkgs, $_;
            }
        } elsif ($entry =~ /\A\+(.+)/) {
            # package name
            my $pkg = $1;
            next if (grep { $_ eq $pkg } @pkgs) || _is_excluded($pkg, $exc);
            push @pkgs, $pkg;
        } elsif ($entry =~ /(.+::)\z/) {
            # module prefix
            log_debug("Listing all modules under $1 ...");
            my $res = Module::List::list_modules(
                $1, {list_modules=>1, recurse=>1});
            for my $mod (sort keys %$res) {
                next if (grep { $_ eq $mod } @pkgs) || _is_excluded($mod, $exc);
                log_debug("Loading module $mod ...");
                load $mod;
                push @pkgs, $mod;
            }
        } else {
            # module name
            next if (grep { $_ eq $entry } @pkgs) || _is_excluded($entry, $exc);
            log_debug("Loading module $entry ...");
            load $entry;
            push @pkgs, $entry;
        }
    }

    my @excluded_pkgs;
    my $progress = $args{-progress};
    $progress->pos(0) if $progress;
    $progress->target(scalar @pkgs) if $progress;
    my $i = 0;
  PKG:
    for my $pkg (@pkgs) {
        $i++;
        $progress->update(pos=>$i, message => "Processing package $pkg ...") if $progress;
        log_debug("Processing package $pkg ...");
        #sleep 1;
        my $rec = $dbh->selectrow_hashref("SELECT * FROM package WHERE name=?",
                                          {}, $pkg);
        my $mp = Module::Path::More::module_path(module=>$pkg);
        my @st; @st = stat($mp) if $mp;

        unless ($args{force} || !$rec || !$rec->{mtime} || !@st || $rec->{mtime} < $st[9]) {
            log_debug("$pkg ($mp) hasn't changed since last recorded, skipped");
            next;
        }

        next if $args{-dry_run};

        my $uri = $pkg; $uri =~ s!::!/!g; $uri = "pl:/$uri/";

        $res = _pa->request(meta => "$uri");
        die "Can't meta $uri: $res->[0] - $res->[1]" unless $res->[0] == 200;
        _cleanser->clean_in_place(my $pkgmeta = $res->[2]);

        if ($pkgmeta->{'x.app.rimetadb.exclude'}) {
            log_debug("Package $pkg has x.app.rimetadb.exclude set to true, excluding ...");
            push @excluded_pkgs, $pkg;
            if ($rec) {
                log_debug("Deleting package $pkg from the database ...");
                $dbh->do("DELETE FROM package  WHERE name=?"   , {}, $pkg);
                $dbh->do("DELETE FROM function WHERE package=?", {}, $pkg);
            }
            next PKG;
        }

        $res = _pa->request(list => $uri, {type=>'function'});
        die "Can't list $uri: $res->[0] - $res->[1]" unless $res->[0] == 200;
        my $numf = @{ $res->[2] };

        $dbh->do("INSERT INTO package (name, summary, metadata, mtime) VALUES (?,?,?,0)", {}, $pkg, $pkgmeta->{summary}, _json->encode($pkgmeta), $st[9]) unless $rec;
        $dbh->do("UPDATE package set mtime=? WHERE name=?", {}, $st[9], $pkg);
        $dbh->do("DELETE FROM function WHERE package=?", {}, $pkg);
        my $j = 0;
      FUNC:
        for my $e (@{ $res->[2] }) {
            my $func = $e; $func =~ s!.+/!!;
            $j++;
            log_debug("Processing function $pkg\::$func ...");
            $progress->update(pos => $i + $j/$numf, message => "Processing function $pkg\::$func ...") if $progress;
            $res = _pa->request(meta => "$uri$e");
            die "Can't meta $e: $res->[0] - $res->[1]" unless $res->[0] == 200;
            _cleanser->clean_in_place(my $funcmeta = $res->[2]);

            if ($funcmeta->{'x.app.rimetadb.exclude'}) {
                log_debug("Function $pkg\::$func has x.app.rimetadb.exclude set to true, excluding ...");
                next FUNC;
            }

            for my $argname (sort keys %{ $funcmeta->{args} // {} }) {
                my $argspec = $funcmeta->{args}{$argname};
                if ($argspec->{'x.app.rimetadb.exclude'}) {
                    log_debug("Function argument $argname (of function $pkg\::$func) has x.app.rimetadb.exclude set to true, excluding ...");
                    delete $funcmeta->{args}{$argname};
                }
            }

            $dbh->do("INSERT INTO function (package, name, summary, metadata) VALUES (?,?,?,?)", {}, $pkg, $func, $funcmeta->{summary}, _json->encode($funcmeta));
        }
    }
    $progress->finish if $progress;