1756 lines
49 KiB
Perl
1756 lines
49 KiB
Perl
#!/usr/bin/perl -w
|
|
|
|
use strict;
|
|
use ActivePerl::PPM::limited_inc;
|
|
|
|
use ActivePerl::PPM::Client;
|
|
use ActivePerl::PPM::Web qw(web_ua);
|
|
use ActivePerl::PPM::Logger qw(ppm_log);
|
|
use ActivePerl::PPM::Util qw(is_cpan_package clean_err join_with update_html_toc);
|
|
|
|
Win32::SetChildShowWindow(0) if defined &Win32::SetChildShowWindow;
|
|
|
|
$SIG{__WARN__} = sub { ppm_log("WARNING", $_[0]) };
|
|
|
|
(my $PROGNAME = $0) =~ s,.*[\\/],,;
|
|
|
|
my $CMD = shift || 'gui';
|
|
$CMD = "version" if $CMD eq "--version";
|
|
|
|
my $BOX_CHARS;
|
|
if ($ENV{ACTIVEPERL_PPM_BOX_CHARS}) {
|
|
$BOX_CHARS = $ENV{ACTIVEPERL_PPM_BOX_CHARS};
|
|
}
|
|
elsif ($^O eq "MSWin32") {
|
|
$BOX_CHARS = "dos";
|
|
}
|
|
elsif (($ENV{LC_ALL} || $ENV{LC_CTYPE} || $ENV{LANG} || "") =~ /\bUTF-8\b/) {
|
|
$BOX_CHARS = "unicode";
|
|
}
|
|
|
|
binmode(STDOUT, ":utf8") if ($BOX_CHARS || "") eq "unicode";
|
|
|
|
if (@ARGV == 1 && ($ARGV[0] =~ /^--?help/ || $ARGV[0] eq "-?")) {
|
|
$ARGV[0] = $CMD;
|
|
$CMD = "help";
|
|
}
|
|
|
|
my $do_cmd = "do_$CMD";
|
|
unless (defined &$do_cmd) {
|
|
require Text::Abbrev;
|
|
my @cmds;
|
|
for my $name (keys %main::) {
|
|
push(@cmds, $name) if $name =~ s/^do_//;
|
|
}
|
|
my $abbrev = Text::Abbrev::abbrev(@cmds);
|
|
if (my $cmd = $abbrev->{$CMD}) {
|
|
$do_cmd = "do_$cmd";
|
|
}
|
|
else {
|
|
require Text::Wrap;
|
|
usage(Text::Wrap::wrap("", " ",
|
|
"Unrecognized ppm command '$CMD'; try one of " .
|
|
join_with("or", sort @cmds)
|
|
)
|
|
);
|
|
}
|
|
}
|
|
|
|
# This must be initialized before PPM::GUI is used
|
|
our $ppm = ActivePerl::PPM::Client->new;
|
|
|
|
our $bad_proxy;
|
|
if (my $proxy = $ENV{http_proxy}) {
|
|
if ($proxy =~ m,^[^?:/@]+(:\d+)?$,) {
|
|
# forgiving; allow http_proxy="<host>:<port>"
|
|
$proxy = $ENV{http_proxy} = "http://$proxy";
|
|
}
|
|
require URI;
|
|
$proxy = URI->new($proxy);
|
|
my $scheme = $proxy->scheme;
|
|
unless ($scheme && $scheme =~ /^https?$/ && $proxy->host) {
|
|
$bad_proxy = qq(Unrecognized proxy setting "$ENV{http_proxy}" ignored.\nThe http_proxy environment variable should be of the form "http://proxy.example.com".);
|
|
print STDERR "$bad_proxy\n";
|
|
ppm_log("WARN", $bad_proxy);
|
|
delete $ENV{http_proxy};
|
|
}
|
|
}
|
|
|
|
eval {
|
|
no strict 'refs';
|
|
ppm_log("INFO", "$PROGNAME $CMD" . (@ARGV ? " @ARGV" : ""));
|
|
&$do_cmd;
|
|
};
|
|
if ($@) {
|
|
ppm_log("ERR", "$PROGNAME $CMD: $@");
|
|
print STDERR "$PROGNAME $CMD failed: " . clean_err($@) . "\n";
|
|
exit 1;
|
|
}
|
|
else {
|
|
exit;
|
|
}
|
|
|
|
my $USAGE;
|
|
sub usage {
|
|
my $msg = shift;
|
|
if ($msg) {
|
|
$msg .= "\n" unless $msg =~ /\n$/;
|
|
print STDERR $msg;
|
|
}
|
|
$USAGE ||= "<cmd> <arg>...";
|
|
print STDERR "Usage:\t$PROGNAME $USAGE\n";
|
|
print STDERR "\tRun '$PROGNAME help" . ($USAGE =~ /^(\w+)/ ? " $1" : "") . "' to learn more.\n";
|
|
exit 1;
|
|
}
|
|
|
|
sub do_gui {
|
|
if ($^O eq "darwin") {
|
|
unless (@ARGV && $ARGV[0] eq "--from-app") {
|
|
require Config;
|
|
system("/usr/bin/open", "$Config::Config{binexp}/PPM.app");
|
|
die "Failed to open PPM.app" if $? != 0;
|
|
exit;
|
|
}
|
|
}
|
|
eval { require ActivePerl::PPM::GUI; };
|
|
if ($@) {
|
|
my $err = $@;
|
|
if ($err =~ /^no display name/) {
|
|
ppm_log("ERR", "$PROGNAME $CMD: $err");
|
|
$err = clean_err($err);
|
|
|
|
print STDERR <<EOT;
|
|
ppm gui failed: $err
|
|
|
|
The PPM graphical interface can't be used unless the DISPLAY environment
|
|
variable is set up. Either set it to the name of the X server to connect
|
|
to or use $PROGNAME as a command line tool.
|
|
|
|
Run '$PROGNAME help' to learn how to use this program as a command line tool.
|
|
EOT
|
|
exit 1;
|
|
}
|
|
if ($err =~ /^Can't locate (Tkx|Tcl)\.pm\b/) {
|
|
ppm_log("ERR", "$PROGNAME $CMD: $err");
|
|
$err = clean_err($err);
|
|
print STDERR <<EOT;
|
|
The PPM graphical interface is not available for this Perl installation.
|
|
Run '$PROGNAME help' to learn how to use this program as a command line tool.
|
|
EOT
|
|
exit 1;
|
|
}
|
|
die $err;
|
|
}
|
|
}
|
|
|
|
sub do_log {
|
|
$USAGE = "log [--errors] [<minutes>]";
|
|
my $errors;
|
|
if (@ARGV) {
|
|
require Getopt::Long;
|
|
Getopt::Long::GetOptions(
|
|
'errors' => \$errors,
|
|
) || usage();
|
|
}
|
|
usage() if @ARGV > 1 || (@ARGV && $ARGV[0] !~ /^[1-9]\d*\z/);
|
|
my $min = shift(@ARGV) || 1;
|
|
|
|
my $logfile = ActivePerl::PPM::Logger::ppm_logger()->logfile;
|
|
open(my $fh, "<", $logfile) || die "Can't open $logfile: $!";
|
|
|
|
print "Last ", ($min == 1 ? "minute" : "$min minutes"), " of $logfile";
|
|
print " errors" if $errors;
|
|
print ":\n\n";
|
|
|
|
my @t = (localtime time - $min * 60)[reverse 0..5];
|
|
$t[0] += 1900; # year
|
|
$t[1] ++; # month
|
|
my $ts = sprintf "%04d-%02d-%02dT%02d:%02d:%02d", @t;
|
|
|
|
my $count;
|
|
while (<$fh>) {
|
|
if ($_ gt $ts .. 1) {
|
|
if (!$errors || (/^\S+ <(\d+)>/ && $1 <= 3)) {
|
|
print;
|
|
$count++;
|
|
}
|
|
}
|
|
}
|
|
unless ($count) {
|
|
print "*** No logged events ***\n";
|
|
}
|
|
}
|
|
|
|
sub do_version {
|
|
if (@ARGV) {
|
|
$USAGE = "version";
|
|
usage("The $CMD command does not take arguments.");
|
|
}
|
|
require ActivePerl::PPM;
|
|
print "ppm $ActivePerl::PPM::VERSION\n";
|
|
print "Copyright (C) 2007 ActiveState Software Inc. All rights reserved.\n";
|
|
}
|
|
|
|
sub do_help {
|
|
if (@ARGV > 1) {
|
|
$USAGE = "help [<subcommand>]";
|
|
usage();
|
|
}
|
|
my $pod2text = qq("$^X" -MPod::Text -e "Pod::Text->new->parse_from_filehandle");
|
|
my $pager = $ENV{PAGER} || "more";
|
|
open(my $fh, "<", __FILE__) || die "Can't open " . __FILE__ . ": $!";
|
|
if (@ARGV) {
|
|
my $cmd = shift(@ARGV);
|
|
my $foundit;
|
|
while (<$fh>) {
|
|
if (/^=item B<ppm \Q$cmd\E\b/o) {
|
|
$foundit++;
|
|
last;
|
|
}
|
|
}
|
|
if ($foundit) {
|
|
open(my $out, "| $pod2text | $pager");
|
|
print $out "=over\n\n";
|
|
print $out $_;
|
|
my $over_depth = 0;
|
|
while (<$fh>) {
|
|
last if /^=item B<ppm (?!\Q$cmd\E\b)/o;
|
|
if (/^=back\b/) {
|
|
last if $over_depth == 0;
|
|
$over_depth--;
|
|
}
|
|
elsif (/^=over\b/) {
|
|
$over_depth++;
|
|
}
|
|
print $out $_;
|
|
}
|
|
print $out "\n\n=back\n";
|
|
close($out);
|
|
}
|
|
else {
|
|
print "Sorry, no help for '$cmd'\n";
|
|
}
|
|
}
|
|
else {
|
|
use ActivePerl::PPM;
|
|
open(my $out, qq(| $pod2text | $pager));
|
|
while (<$fh>) {
|
|
s/version \d+\S*/version $ActivePerl::PPM::VERSION/ if /^ppm -/;
|
|
print $out $_;
|
|
}
|
|
close($out);
|
|
}
|
|
}
|
|
|
|
sub do_config {
|
|
$USAGE = "config <name> [<val>]";
|
|
usage() unless @ARGV;
|
|
if (@ARGV == 1) {
|
|
my $key = shift(@ARGV);
|
|
$key = '*' if $key eq "list";
|
|
if ($key =~ /[*?]/) {
|
|
my @kv = $ppm->config_list($key);
|
|
unless (@kv) {
|
|
print "*** no configuration options matching '$key' found ***\n";
|
|
return;
|
|
}
|
|
while (@kv) {
|
|
my($k, $v) = splice(@kv, 0, 2);
|
|
$v = "<undef>" unless defined $v;
|
|
printf "$k = $v\n";
|
|
}
|
|
return;
|
|
}
|
|
my $v = $ppm->config_get($key);
|
|
$v = "<undef>" unless defined $v;
|
|
print "$v\n";
|
|
}
|
|
elsif (@ARGV == 2) {
|
|
usage() unless $ARGV[0] =~ /^\w+(\.\w+)*$/;
|
|
$ppm->config_save(@ARGV);
|
|
}
|
|
else {
|
|
usage();
|
|
}
|
|
}
|
|
|
|
sub do_area {
|
|
my $cmd = shift(@ARGV) || "list";
|
|
AGAIN:
|
|
if ($cmd eq "list") {
|
|
$USAGE = "area list [--csv [ <sep> ]] [--no-header]";
|
|
my $show_header = 1;
|
|
my $csv;
|
|
if (@ARGV) {
|
|
require Getopt::Long;
|
|
Getopt::Long::GetOptions(
|
|
'header!' => \$show_header,
|
|
'csv:s' => \$csv,
|
|
) || usage();
|
|
usage() if @ARGV;
|
|
}
|
|
require ActiveState::Table;
|
|
my $tab = ActiveState::Table->new;
|
|
$tab->add_field("name");
|
|
$tab->add_field("pkgs");
|
|
$tab->add_field("lib");
|
|
my $default = $ppm->default_install_area;
|
|
for my $area ($ppm->areas) {
|
|
my $o = $ppm->area($area);
|
|
my $name = $area;
|
|
$name = "$name*" if defined($default) && $name eq $default;
|
|
$name = "($name)" if $o->readonly;
|
|
my $pkgs = $o->packages;
|
|
$pkgs = "n/a" unless defined $pkgs;
|
|
$tab->add_row({
|
|
name => $name,
|
|
pkgs => $pkgs,
|
|
lib => $o->lib,
|
|
});
|
|
}
|
|
if (defined($csv)) {
|
|
$csv = "," if $csv eq "";
|
|
print $tab->as_csv(null => "", field_separator => $csv, show_header => $show_header);
|
|
}
|
|
else {
|
|
print $tab->as_box(null => "", show_header => $show_header, show_trailer => 0, align => {pkgs => "right"}, box_chars => $BOX_CHARS, max_width => terminal_width());
|
|
}
|
|
}
|
|
elsif ($cmd eq "init") {
|
|
$USAGE = "area init <area>";
|
|
usage() unless @ARGV == 1;
|
|
my $name = shift(@ARGV);
|
|
$ppm->area($name)->initialize;
|
|
}
|
|
elsif ($cmd eq "sync") {
|
|
$USAGE = "area sync [<area>...]";
|
|
for my $area (map $ppm->area($_), @ARGV ? @ARGV : $ppm->areas) {
|
|
$area->sync_db;
|
|
}
|
|
}
|
|
else {
|
|
$cmd = _try_abbrev("area", $cmd, qw(list sync init));
|
|
goto AGAIN;
|
|
}
|
|
}
|
|
|
|
sub _try_abbrev {
|
|
my $cmd = shift;
|
|
my $subcmd = shift;
|
|
require Text::Abbrev;
|
|
if (my $full_cmd = Text::Abbrev::abbrev(@_)->{$subcmd}) {
|
|
return $full_cmd;
|
|
}
|
|
$USAGE = "$cmd <cmd> <args>";
|
|
require Text::Wrap;
|
|
usage(Text::Wrap::wrap("", " ",
|
|
"The $cmd command '$subcmd' isn't recognized; try one of " .
|
|
join_with("or", sort @_)
|
|
)
|
|
);
|
|
}
|
|
|
|
sub do_list {
|
|
my $area_name;
|
|
my $matching;
|
|
my $show_header = 1;
|
|
my $csv;
|
|
my @fields;
|
|
if (@ARGV) {
|
|
$USAGE = "list [<area>] [--field <field>] [--matching <pattern>] [--csv]";
|
|
require Getopt::Long;
|
|
Getopt::Long::GetOptions(
|
|
'matching=s' => \$matching,
|
|
'header!' => \$show_header,
|
|
'fields:s' => sub { push(@fields, split(/\s*,\s*/, $_[1])) },
|
|
'csv:s' => \$csv,
|
|
) || usage();
|
|
$area_name = shift(@ARGV) if @ARGV;
|
|
usage() if @ARGV;
|
|
}
|
|
|
|
my $matching_re = glob2re($matching) if defined($matching);
|
|
$matching = (defined $matching) ? " matching '$matching'" : "";
|
|
|
|
unless (@fields) {
|
|
# fields to show by default
|
|
push(@fields, "version", "files", "size");
|
|
push(@fields, "area") unless $area_name;
|
|
}
|
|
unshift(@fields, "name") unless grep $_ eq "name", @fields;
|
|
|
|
my @areas = ($area_name ? ($area_name) : $ppm->areas);
|
|
my $in = $area_name ? " in '$area_name' area" : "";
|
|
|
|
if (@fields == 1) {
|
|
# just list the names
|
|
my @pkgs = map $_->packages, map $ppm->area($_), @areas;
|
|
@pkgs = grep $_ =~ $matching_re, @pkgs if $matching_re;
|
|
goto NO_PKG_INSTALLED unless @pkgs;
|
|
print "$_\n" for sort @pkgs;
|
|
}
|
|
else {
|
|
require ActiveState::Table;
|
|
my $tab = ActiveState::Table->new;
|
|
$tab->add_field($_) for @fields;
|
|
|
|
my %field = map { $_ => 1 } @fields;
|
|
my %db_column = map { $_ => 1 } qw(id name version release_date abstract author ppd_uri);
|
|
my @db_fields = grep $db_column{$_}, @fields;
|
|
unshift(@db_fields, "id") if !$field{id} && $field{files} || $field{size};
|
|
|
|
for my $area (map $ppm->area($_), @areas) {
|
|
for my $pkg ($area->packages(@db_fields)) {
|
|
my %row = map {$_ => shift(@$pkg)} @db_fields;
|
|
next if $matching_re && $row{name} !~ $matching_re;
|
|
if ($row{release_date}) {
|
|
$row{release_date} =~ s/[T ].*//; # drop time
|
|
}
|
|
if ($field{files} || $field{size}) {
|
|
if ($field{size}) {
|
|
my @files = $area->package_files($row{id});
|
|
$row{files} = @files if $field{files};
|
|
|
|
require ActiveState::DiskUsage;
|
|
my $size = 0;
|
|
$size += ActiveState::DiskUsage::du($_) for @files;
|
|
$size = sprintf "%.0f KB", $size / 1024 unless defined($csv);
|
|
$row{size} = $size
|
|
}
|
|
else {
|
|
$row{files} = $area->package_files($row{id});
|
|
}
|
|
}
|
|
$row{area} = $area->name if $field{area};
|
|
delete $row{id} unless $field{id};
|
|
$tab->add_row(\%row);
|
|
}
|
|
}
|
|
$tab->sort(sub ($$) { my($a, $b) = @_; $a->[0] cmp $b->[0]})
|
|
if @areas > 1 && $tab->can("sort");
|
|
|
|
if (defined $csv) {
|
|
$csv = "," if $csv eq "";
|
|
print $tab->as_csv(null => "", field_separator => $csv, show_header => $show_header);
|
|
}
|
|
elsif (my $rows = $tab->rows) {
|
|
print $tab->as_box(null => "", show_trailer => 0, show_header => $show_header, align => {files => "right", size => "right"}, box_chars => $BOX_CHARS, max_width => terminal_width());
|
|
if (1) {
|
|
my $s = ($rows == 1) ? "" : "s";
|
|
print " ($rows package$s installed$in$matching)\n";
|
|
}
|
|
}
|
|
else {
|
|
NO_PKG_INSTALLED:
|
|
print STDERR "*** no packages installed$in$matching ***\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
sub glob2re {
|
|
my $glob = shift;
|
|
$glob = "*$glob*" unless $glob =~ /[*?]/;
|
|
my $re = quotemeta($glob);
|
|
$re =~ s/\\\?/./g;
|
|
$re =~ s/\\\*/.*/g;
|
|
$re = "^$re\\z";
|
|
$re =~ s/^\^\.\*//;
|
|
$re =~ s/\.\*\\z\z//;
|
|
return "(?i:$re)";
|
|
}
|
|
|
|
sub terminal_width {
|
|
require Term::ReadKey;
|
|
my($w) = Term::ReadKey::GetTerminalSize();
|
|
$w ||= 80;
|
|
$w-- if $^O eq "MSWin32"; # can't print on last column
|
|
$w;
|
|
}
|
|
|
|
sub do_query {
|
|
$USAGE = "query <pattern>";
|
|
usage() unless @ARGV == 1;
|
|
@ARGV = ("--matching", @ARGV, "--fields", "name,version,abstract,area");
|
|
return do_list();
|
|
}
|
|
|
|
sub do_files {
|
|
$USAGE = "files <pkg>";
|
|
usage() unless @ARGV == 1;
|
|
my $pkg = shift(@ARGV);
|
|
my $foundit;
|
|
for my $area (map $ppm->area($_), $ppm->areas) {
|
|
next unless $area->initialized;
|
|
my $id = $area->package_id($pkg, sloppy => 1);
|
|
next unless defined($id);
|
|
$foundit++;
|
|
print "$_\n" for $area->package_files($id);
|
|
}
|
|
not_installed($pkg) unless $foundit;
|
|
}
|
|
|
|
sub not_installed {
|
|
my $pkg = shift;
|
|
die "Package '$pkg' is not installed";
|
|
}
|
|
|
|
sub do_verify {
|
|
my %opt;
|
|
if (@ARGV) {
|
|
$USAGE = "verify [--verbose] [<package>]";
|
|
require Getopt::Long;
|
|
Getopt::Long::GetOptions(\%opt,
|
|
'verbose',
|
|
) || usage();
|
|
$opt{package} = shift(@ARGV) if @ARGV;
|
|
usage() if @ARGV;
|
|
}
|
|
my @areas = grep $_->initialized, map $ppm->area($_), $ppm->areas;
|
|
if ($opt{package}) {
|
|
@areas = grep $_->package_id($opt{package}), @areas;
|
|
not_installed($opt{package}) unless @areas;
|
|
}
|
|
my %status;
|
|
for my $area (@areas) {
|
|
my %s = $area->verify(
|
|
package => $opt{package},
|
|
badfile_cb => sub {
|
|
my $what = shift;
|
|
my $file = shift;
|
|
print "$file: ";
|
|
if ($what eq "wrong_mode") {
|
|
printf "wrong mode %03o expected %03o\n", @_;
|
|
}
|
|
else {
|
|
print "$what\n";
|
|
}
|
|
},
|
|
file_cb => !$opt{verbose} ? undef : sub {
|
|
my($file, $md5, $mode) = @_;
|
|
printf "V %s %s %03o\n", $file, $md5, $mode;
|
|
},
|
|
);
|
|
while (my($k,$v) = each %s) {
|
|
$status{$k} += $v;
|
|
}
|
|
}
|
|
for my $v (qw(verified missing modified)) {
|
|
next if $v ne "verified" && !$status{$v};
|
|
my $s = $status{$v} == 1 ? "" : "s";
|
|
print "$status{$v} file$s $v.\n";
|
|
}
|
|
}
|
|
|
|
sub uri_hide_passwd {
|
|
my $url = shift;
|
|
return $url unless $url =~ /\@/;
|
|
$url = URI->new($url);
|
|
if (my $ui = $url->userinfo) {
|
|
if ($ui =~ s/:.*/:***/) {
|
|
$url->userinfo($ui);
|
|
}
|
|
}
|
|
return $url->as_string;
|
|
}
|
|
|
|
sub do_repo {
|
|
my $cmd = shift(@ARGV) || "list";
|
|
AGAIN:
|
|
if ($cmd eq "list") {
|
|
$USAGE = "repo list [--csv [ <sep> ]] [--no-header]";
|
|
my $show_header = 1;
|
|
my $csv;
|
|
if (@ARGV) {
|
|
require Getopt::Long;
|
|
Getopt::Long::GetOptions(
|
|
'header!' => \$show_header,
|
|
'csv:s' => \$csv,
|
|
) || usage();
|
|
usage() if @ARGV;
|
|
}
|
|
require ActiveState::Table;
|
|
my $tab = ActiveState::Table->new;
|
|
$tab->add_field("id");
|
|
$tab->add_field("pkgs");
|
|
$tab->add_field("name");
|
|
my $count = 0;
|
|
for my $repo_id ($ppm->repos) {
|
|
my $repo = $ppm->repo($repo_id);
|
|
$tab->add_row({
|
|
id => $repo_id,
|
|
pkgs => $repo->{enabled} ? $repo->{pkgs} : "n/a",
|
|
name => $repo->{name},
|
|
});
|
|
$count++ if $repo->{enabled};
|
|
}
|
|
if (defined($csv)) {
|
|
$csv = "," if $csv eq "";
|
|
print $tab->as_csv(null => "", field_separator => $csv, show_header => $show_header);
|
|
}
|
|
else {
|
|
print $tab->as_box(null => "", show_trailer => 0, show_header => $show_header, align => {id => "right", pkgs => "right"}, box_chars => $BOX_CHARS, max_width => terminal_width());
|
|
my $s = ($count == 1) ? "y" : "ies";
|
|
$count ||= "no";
|
|
print " ($count enabled repositor$s)\n";
|
|
}
|
|
}
|
|
elsif ($cmd eq "search") {
|
|
do_search();
|
|
}
|
|
elsif ($cmd eq "sync") {
|
|
$USAGE = "repo sync [--force] [<num>]";
|
|
my $force;
|
|
my $max_ppd;
|
|
if (@ARGV) {
|
|
require Getopt::Long;
|
|
Getopt::Long::GetOptions(
|
|
force => \$force,
|
|
'max-ppd=n' => \$max_ppd,
|
|
) || usage();
|
|
usage() if @ARGV > 1 || (@ARGV && $ARGV[0] !~ /^\d+$/);
|
|
}
|
|
$ppm->repo_sync(
|
|
validate => 1,
|
|
force => $force,
|
|
max_ppd => $max_ppd,
|
|
(@ARGV ? ("repo" => $ARGV[0]) : ()),
|
|
);
|
|
}
|
|
elsif ($cmd eq "on" || $cmd eq "off" || $cmd eq "delete" || $cmd eq "describe") {
|
|
$USAGE = "repo $cmd <num>";
|
|
usage() if @ARGV != 1;
|
|
my $repo = $ppm->repo($ARGV[0]);
|
|
die "No such repo; 'ppm repo list' will print what's available" unless $repo;
|
|
if ($cmd eq "delete") {
|
|
$ppm->repo_delete($ARGV[0]);
|
|
print "Repo $ARGV[0] deleted.\n";
|
|
}
|
|
elsif ($cmd eq "describe") {
|
|
require ActiveState::Duration;
|
|
print "Id: $repo->{id}\n";
|
|
print "Name: $repo->{name}\n";
|
|
print "URL: " . uri_hide_passwd($repo->{packlist_uri}) . "\n";
|
|
print "Enabled: ", ($repo->{enabled} ? "yes" : "no"), "\n";
|
|
if (my $last_status = $repo->{packlist_last_status_code}) {
|
|
print "Last-Status: $last_status " . HTTP::Status::status_message($last_status) . "\n";
|
|
}
|
|
else {
|
|
print "Last-Status: - (never accessed)\n";
|
|
}
|
|
if (my $last_access = $repo->{packlist_last_access}) {
|
|
print "Last-Access: ", ActiveState::Duration::ago_eng(time - $last_access), "\n";
|
|
}
|
|
if (my $fresh_until = $repo->{packlist_fresh_until}) {
|
|
my $refresh_in = $fresh_until - time;
|
|
if ($refresh_in >= 0) {
|
|
print "Refresh-In: ", ActiveState::Duration::dur_format_eng($refresh_in), "\n";
|
|
}
|
|
else {
|
|
print "Refresh-In: overdue\n";
|
|
}
|
|
}
|
|
if (my $lastmod = $repo->{packlist_lastmod}) {
|
|
require HTTP::Date;
|
|
print "Last-Modified: ", ActiveState::Duration::ago_eng(time - HTTP::Date::str2time($lastmod)), "\n";
|
|
}
|
|
}
|
|
else {
|
|
$ppm->repo_enable($ARGV[0], $cmd eq "on");
|
|
}
|
|
}
|
|
elsif ($cmd eq "add") {
|
|
$USAGE = "repo add <url> [<name>] [--username <user> [--password <password>]]";
|
|
my $user;
|
|
my $pass;
|
|
require Getopt::Long;
|
|
Getopt::Long::GetOptions(
|
|
'username=s' => \$user,
|
|
'password=s' => \$pass,
|
|
) || usage();
|
|
my $url = shift(@ARGV) || usage();
|
|
my $name;
|
|
if (@ARGV) {
|
|
$name = shift(@ARGV);
|
|
usage() if @ARGV;
|
|
if ($url !~ /^[a-z][+\w]+:/ && $name =~ /^[a-z][+\w]+:/) {
|
|
# ppm3 had the arguments reversed, so try that
|
|
($url, $name) = ($name, $url);
|
|
}
|
|
}
|
|
else {
|
|
$name = eval { URI->new($url)->host } || $url;
|
|
}
|
|
if ($url =~ /^[a-z][+\w]+:/) {
|
|
die "PPM3 SOAP repositories are not supported"
|
|
if $url =~ m,\?urn:/,;
|
|
}
|
|
else {
|
|
if (-d $url) {
|
|
require URI::file;
|
|
$url = URI::file->new_abs($url);
|
|
}
|
|
elsif ($url eq "activestate") {
|
|
($name, $url) = $ppm->activestate_repo;
|
|
die "No ActiveState repo for this platform" unless $url;
|
|
}
|
|
elsif (eval {require PPM::Repositories} and
|
|
my $repo = $PPM::Repositories::Repositories{$url})
|
|
{
|
|
$name ||= $url;
|
|
$url = $repo->{location};
|
|
}
|
|
else {
|
|
die "The repository URL must be absolute or a local directory";
|
|
}
|
|
}
|
|
if ($user) {
|
|
$user .= ":$pass" if defined $pass;
|
|
$url = URI->new($url);
|
|
$url->userinfo($user);
|
|
$url = $url->as_string;
|
|
}
|
|
else {
|
|
usage() if defined $pass;
|
|
}
|
|
my $id = $ppm->repo_add(name => $name, packlist_uri => $url);
|
|
print "Repo $id added.\n";
|
|
}
|
|
elsif ($cmd eq "rename") {
|
|
$USAGE = "repo rename <num> <name>";
|
|
usage() if @ARGV < 2;
|
|
my $repo = $ppm->repo(shift(@ARGV));
|
|
die "No such repo; 'ppm repo list' will print what's available" unless $repo;
|
|
$ppm->repo_set_name($repo->{id}, join(" ", @ARGV));
|
|
}
|
|
elsif ($cmd eq "location") {
|
|
$USAGE = "repo location <num> <url>";
|
|
warn "[@ARGV]";
|
|
usage() if @ARGV != 2;
|
|
my($id, $uri) = @ARGV;
|
|
my $repo = $ppm->repo($id);
|
|
die "No such repo; 'ppm repo list' will print what's available" unless $repo;
|
|
$ppm->repo_set_packlist_uri($repo->{id}, $uri);
|
|
$ppm->repo_sync(repo => $repo->{id});
|
|
}
|
|
elsif ($cmd =~ /^\d+$/) {
|
|
@ARGV = ("describe") unless @ARGV;
|
|
if ($ARGV[0] =~ /^\d+$/) {
|
|
# avoids infinite recursion
|
|
$USAGE = "repo <num> <cmd> ...";
|
|
usage();
|
|
}
|
|
splice(@ARGV, 1, 0, $cmd);
|
|
do_repo();
|
|
}
|
|
elsif ($cmd eq "suggest") {
|
|
my $ppm_repo_ok;
|
|
eval {
|
|
require PPM::Repositories;
|
|
$ppm_repo_ok++;
|
|
};
|
|
require ActivePerl;
|
|
my $count = 0;
|
|
if (my($as_name, $as_url) = $ppm->activestate_repo) {
|
|
$PPM::Repositories::Repositories{activestate} = {
|
|
Active => 1,
|
|
Type => "PPM4",
|
|
Notes => $as_name,
|
|
location => $as_url,
|
|
};
|
|
}
|
|
for my $id (sort keys %PPM::Repositories::Repositories) {
|
|
my $repo = $PPM::Repositories::Repositories{$id};
|
|
next unless $repo->{Active};
|
|
next if $repo->{Type} eq "PPMServer";
|
|
my $o = $repo->{PerlO} || [];
|
|
next if @$o && !grep $_ eq $^O, @$o;
|
|
my $v = $repo->{PerlV} || [];
|
|
my $my_v = ActivePerl::perl_version;
|
|
next if @$v && !grep $my_v =~ /^\Q$_\E\b/, @$v;
|
|
print "\n" if $count;
|
|
print "$PROGNAME repo add $id\n";
|
|
print " $repo->{Notes}\n";
|
|
print " $repo->{location}\n";
|
|
$count++;
|
|
}
|
|
if ($count) {
|
|
unless ($ppm_repo_ok) {
|
|
print "\n*** Install PPM-Repositories for more suggestions ***\n";
|
|
}
|
|
}
|
|
else {
|
|
my $msg = "No suggested repository for this perl";
|
|
$msg .= "\nInstalling PPM-Repositories might provide some suggestions"
|
|
unless $ppm_repo_ok;
|
|
die $msg;
|
|
}
|
|
}
|
|
else {
|
|
$cmd = _try_abbrev("repo", $cmd, qw(list location search sync on off delete describe add rename suggest));
|
|
goto AGAIN;
|
|
}
|
|
}
|
|
|
|
sub do_search {
|
|
$USAGE = "search <pattern>";
|
|
my $sync = 1;
|
|
require Getopt::Long;
|
|
Getopt::Long::GetOptions(
|
|
'sync!' => \$sync,
|
|
) || usage();
|
|
usage() unless @ARGV == 1;
|
|
my $pattern = shift(@ARGV);
|
|
$ppm->repo_sync if $sync;
|
|
my @fields = ("name", "version", "release_date", "abstract", "repo_id");
|
|
my @res = $ppm->search($pattern, @fields);
|
|
if (@res) {
|
|
if (@res == 1) {
|
|
@ARGV = (1);
|
|
return do_describe();
|
|
}
|
|
|
|
my %repo_name;
|
|
for my $id ($ppm->repos) {
|
|
my $o = $ppm->repo($id);
|
|
next unless $o->{enabled};
|
|
$repo_name{$id} = $o->{name} || $id;
|
|
}
|
|
|
|
if (@res < 10) {
|
|
my $count = 0;
|
|
for (@res) {
|
|
my($name, $version, $date, $abstract, $repo_id) = @$_;
|
|
$count++;
|
|
print "\n" unless $count == 1;
|
|
print "$count: $name\n";
|
|
print " $abstract\n" if $abstract;
|
|
print " Version: $version\n";
|
|
if ($date) {
|
|
$date =~ s/[T ].*//;
|
|
print " Released: ", $date, "\n";
|
|
}
|
|
print " Repo: ", ($repo_name{$repo_id} || $repo_id), "\n"
|
|
if keys %repo_name > 1;
|
|
}
|
|
}
|
|
else {
|
|
my $count = 0;
|
|
my $count_width = length(@res);
|
|
for (@res) {
|
|
$count++;
|
|
printf "%*d: %s v%s\n", $count_width, $count, $_->[0], $_->[1];
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
print "*** no packages matching '$pattern' found ***\n";
|
|
}
|
|
}
|
|
|
|
sub do_describe {
|
|
$USAGE = "describe <num>";
|
|
usage() unless @ARGV == 1;
|
|
my $num = shift(@ARGV);
|
|
$num =~ s/:$//;
|
|
usage unless $num =~ /^\d+$/;
|
|
my $pkg = $ppm->search_lookup($num) ||
|
|
die "*** no package #$num, do a '$PROGNAME search' first ***\n";
|
|
my $pad = " " x (length($num) + 2);
|
|
print "$num: $pkg->{name}\n";
|
|
print "${pad}$pkg->{abstract}\n" if $pkg->{abstract};
|
|
print "${pad}Version: $pkg->{version}\n";
|
|
if (my $date = $pkg->{release_date}) {
|
|
$date =~ s/[T ].*//;
|
|
print "${pad}Released: ", $date, "\n";
|
|
}
|
|
print "${pad}Author: $pkg->{author}\n" if $pkg->{author};
|
|
for my $role (qw(provide require)) {
|
|
for my $feature (sort keys %{$pkg->{$role} || {}}) {
|
|
next if $feature eq $pkg->{name};
|
|
(my $pretty_feature = $feature) =~ s/::$//;
|
|
print "${pad}\u$role: $pretty_feature";
|
|
if (my $vers = $pkg->{$role}{$feature}) {
|
|
print " version $vers";
|
|
print " or better" if $role eq "require";
|
|
}
|
|
print "\n";
|
|
}
|
|
}
|
|
my $repo = $ppm->repo($pkg->{repo_id});
|
|
print "${pad}Repo: $repo->{name}\n";
|
|
if (my $name = is_cpan_package($pkg->{name})) {
|
|
print "${pad}CPAN: http://search.cpan.org/dist/$name-$pkg->{version}/\n";
|
|
}
|
|
for my $area ($ppm->areas) {
|
|
my $area_pkg = eval { $ppm->area($area)->package($pkg->{name}) };
|
|
next unless $area_pkg;
|
|
print "${pad}Installed: $area_pkg->{version} ($area)\n";
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub do_tree {
|
|
$USAGE = "tree [<num> | <package>]";
|
|
usage unless @ARGV == 1;
|
|
my $pkg = shift(@ARGV);
|
|
if ($pkg =~ /^\d+$/) {
|
|
my $tmp = $ppm->search_lookup($pkg) ||
|
|
die "*** no package #$pkg, do a '$PROGNAME search' first ***\n";
|
|
$pkg = $tmp;
|
|
}
|
|
else {
|
|
my $tmp = $ppm->package_best($pkg, 0) ||
|
|
die "*** no package called $pkg ***\n";
|
|
$pkg = $tmp;
|
|
}
|
|
_tree($pkg);
|
|
}
|
|
|
|
sub _tree {
|
|
my($pkg, $reason, $depth) = @_;
|
|
$depth ||= 0;
|
|
print " " x $depth, "package ", $pkg->name_version;
|
|
print " provide $reason" if $reason && $reason ne $pkg->{name};
|
|
print "\n";
|
|
my $require = $pkg->{require};
|
|
if ($require && %$require) {
|
|
for my $feature (sort keys %$require) {
|
|
print " " x $depth, " needs $feature";
|
|
my $vers = $require->{$feature};
|
|
if ($vers) {
|
|
print " v$vers or better";
|
|
}
|
|
|
|
my @facts;
|
|
my $found;
|
|
for my $area_name ($ppm->areas) {
|
|
my $area = $ppm->area($area_name);
|
|
if (my $have = $area->feature_have($feature)) {
|
|
$have = 0 if $have eq "0E0";
|
|
push(@facts, ($have || $vers ? "v$have " : "") . "installed in $area_name area");
|
|
$found++ if $have >= $vers;
|
|
}
|
|
}
|
|
push(@facts, "not installed") unless $found;
|
|
|
|
my $subpkg = $ppm->package_best($feature, $vers);
|
|
push(@facts, "not provided by any repo") unless $subpkg;
|
|
print " (", join_with("and", @facts), ")" if @facts;
|
|
print "\n";
|
|
_tree($subpkg, $feature, $depth + 1) if $subpkg;
|
|
}
|
|
}
|
|
else {
|
|
print " " x $depth , " (no dependencies)\n";
|
|
}
|
|
}
|
|
|
|
sub do_install {
|
|
$USAGE = "install [--force] [--nodeps] [--area <area>] <module> | <url> | <file> | <num>";
|
|
my $force;
|
|
my $nodeps;
|
|
my $area;
|
|
my $sync = 1;
|
|
require Getopt::Long;
|
|
Getopt::Long::GetOptions(
|
|
force => \$force,
|
|
'area=s' => \$area,
|
|
nodeps => \$nodeps,
|
|
'sync!' => \$sync,
|
|
) || usage();
|
|
usage() unless @ARGV == 1;
|
|
my @args;
|
|
push(@args, force => 1) if $force;
|
|
push(@args, follow_deps => "none") if $nodeps;
|
|
|
|
my $feature = shift(@ARGV);
|
|
eval {
|
|
if ($feature =~ m,^[a-z][+\w]+:[^:],) {
|
|
# looks like an absolute URL
|
|
_install_uri($area, $force, $feature, @args);
|
|
}
|
|
elsif ($feature =~ /\.ppd$/) {
|
|
require URI::file;
|
|
_install_uri($area, $force, URI::file->new_abs($feature), @args);
|
|
}
|
|
elsif ($feature =~ /^\d+$/) {
|
|
my $pkg = $ppm->search_lookup($feature) ||
|
|
die "*** no package #$feature, do a '$PROGNAME search' first ***\n";
|
|
my @deps = $ppm->packages_missing(want_deps => [$pkg], @args);
|
|
_install($area, $force, $pkg, @deps);
|
|
}
|
|
else {
|
|
# seach for feature in repos
|
|
$ppm->repo_sync if $sync;
|
|
$feature = $ppm->feature_fixup_case($feature);
|
|
_install($area, $force, $ppm->packages_missing(want => [$feature], @args));
|
|
}
|
|
};
|
|
if ($@) {
|
|
if ($@ =~ /\bwould downgrade\b/) {
|
|
$@ =~ s/( at )/; use --force to install regardless$1/;
|
|
}
|
|
|
|
if ($@ =~ /File conflict/ && $@ =~ /The package (\S+) has already/) {
|
|
my $pkg = $1;
|
|
$@ =~ s/( at )/ Uninstall $pkg, or use --force to allow files\n to be overwritten.$1/;
|
|
}
|
|
die;
|
|
}
|
|
}
|
|
|
|
sub do_upgrade {
|
|
$USAGE = "upgrade [<pkg> | --install]";
|
|
my $install;
|
|
my $sync = 1;
|
|
if (@ARGV) {
|
|
require Getopt::Long;
|
|
Getopt::Long::GetOptions(
|
|
'install' => \$install,
|
|
'sync!' => \$sync,
|
|
) || usage();
|
|
usage() if @ARGV > 1;
|
|
}
|
|
if (@ARGV && $ARGV[0] =~ /::/) {
|
|
$ppm->repo_sync if $sync;
|
|
my $mod = $ppm->feature_fixup_case($ARGV[0]);
|
|
return _install(undef, 0, $ppm->packages_missing(want => [[$mod, undef]]));
|
|
}
|
|
|
|
$install++ if @ARGV;
|
|
my $pkg_count = 0;
|
|
my $upgrade_count = 0;
|
|
my %shaddow;
|
|
$ppm->repo_sync if $sync;
|
|
for my $area_name ($ppm->areas) {
|
|
my $area = $ppm->area($area_name);
|
|
for ($area->packages("id", "name", "version")) {
|
|
my($pkg_id, $pkg_name, $pkg_version) = @$_;
|
|
next if @ARGV && lc($ARGV[0]) ne lc($pkg_name);
|
|
$pkg_count++;
|
|
next if $shaddow{$pkg_name}++;
|
|
if (my $best = $ppm->package_best($pkg_name, 0)) {
|
|
if ($best->{name} eq $pkg_name && $best->{version} ne $pkg_version) {
|
|
my $pkg = $area->package($pkg_id);
|
|
if ($best->better_than($pkg)) {
|
|
print "$pkg_name $best->{version} (have v$pkg_version)\n";
|
|
$upgrade_count++;
|
|
if ($install) {
|
|
my $install_area = $area_name;
|
|
if ($install_area eq "perl" || $area->readonly) {
|
|
$install_area = $ppm->default_install_area;
|
|
unless ($install_area) {
|
|
die "No writable install area for the upgrade";
|
|
}
|
|
}
|
|
_install($install_area, 0, $best);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
if (@ARGV && !$pkg_count) {
|
|
print STDERR "*** package $ARGV[0] not installed ***\n";
|
|
}
|
|
elsif (!$upgrade_count) {
|
|
my $for = @ARGV ? " for $ARGV[0]" : "";
|
|
print STDERR "*** no upgrades available$for ***\n";
|
|
}
|
|
}
|
|
|
|
sub _install_uri {
|
|
my($area, $force, $uri, @args) = @_;
|
|
|
|
my $res = web_ua->get($uri);
|
|
unless ($res->is_success) {
|
|
die $res->status_line;
|
|
}
|
|
require ActivePerl::PPM::PPD;
|
|
my $cref = $res->decoded_content(ref => 1, default_charset => "none");
|
|
my $pkg = ActivePerl::PPM::Package->new_ppd($$cref,
|
|
arch => $ppm->arch,
|
|
base => $res->base,
|
|
rel_base => $uri,
|
|
);
|
|
unless ($pkg) {
|
|
die "No PPD found _at $uri";
|
|
}
|
|
if (my $codebase = $pkg->{codebase}) {
|
|
$pkg->{ppd_uri} = $uri;
|
|
$pkg->{ppd_etag} = $res->header("ETag");
|
|
$pkg->{ppd_lastmod} = $res->header("Last-Modified");
|
|
}
|
|
else {
|
|
die "The PPD does not provide code to install for this platform";
|
|
}
|
|
|
|
# XXX follow dependencies with the "directory" of $pkg $uri as the
|
|
# first repo to look for additional packages. This only works for
|
|
# package features.
|
|
|
|
_install($area, $force, $pkg, $ppm->packages_missing(want_deps => [$pkg], @args));
|
|
}
|
|
|
|
sub _install {
|
|
my $area = shift;
|
|
my $force = shift;
|
|
unless (@_) {
|
|
print "No missing packages to install\n";
|
|
return;
|
|
}
|
|
|
|
unless ($area) {
|
|
$area = $ppm->default_install_area;
|
|
unless ($area) {
|
|
my $msg = "All available install areas are readonly.
|
|
Run 'ppm help area' to learn how to set up private areas.";
|
|
require ActiveState::Path;
|
|
if (ActiveState::Path::find_prog("sudo")) {
|
|
$msg .= "\nYou might also try 'sudo ppm' to raise your privileges.";
|
|
}
|
|
die $msg;
|
|
}
|
|
ppm_log("NOTICE", "Installing into $area");
|
|
}
|
|
$area = $ppm->area($area);
|
|
|
|
$| = 1;
|
|
|
|
my $summary = $ppm->install(packages => \@_, area => $area, force => $force);
|
|
if (my $count = $summary->{count}) {
|
|
for my $what (sort keys %$count) {
|
|
my $n = $count->{$what} || 0;
|
|
printf "%4d file%s %s\n", $n, ($n == 1 ? "" : "s"), $what;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub do_remove {
|
|
$USAGE = "remove [--area <area>] [--force] <package> ...";
|
|
my $opt_area;
|
|
my $opt_force;
|
|
require Getopt::Long;
|
|
Getopt::Long::GetOptions(
|
|
'area=s' => \$opt_area,
|
|
'force' => \$opt_force,
|
|
) || usage();
|
|
usage() unless @ARGV;
|
|
|
|
my $removed_count = 0;
|
|
for my $pkg (@ARGV) {
|
|
my $area; ($opt_area ? $ppm->area($opt_area) : ());
|
|
my $pkg_o;
|
|
if ($opt_area) {
|
|
$area = $ppm->area($opt_area);
|
|
$pkg_o = $area->package($pkg, sloppy => 1);
|
|
}
|
|
else {
|
|
for my $a ($ppm->areas) {
|
|
$area = $ppm->area($a);
|
|
next unless $area->initialized;
|
|
$pkg_o = $area->package($pkg, sloppy => 1);
|
|
if ($pkg_o) {
|
|
die "Can't remove from 'perl' area without explicit area specification"
|
|
if $a eq "perl";
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
unless ($pkg_o) {
|
|
print "$pkg: not installed\n";
|
|
next;
|
|
}
|
|
if (lc($pkg_o->{name}) ne lc(do{my $p = $pkg; $p =~ s/::/-/g; $p})) {
|
|
die "'ppm remove $pkg_o->{name}' will uninstall package providing $pkg";
|
|
}
|
|
unless ($opt_force) {
|
|
my @d = map $_->name, $ppm->packages_depending_on($pkg_o, $area->name);
|
|
if (@d) {
|
|
my %args = map { $_ => 1 } @ARGV;
|
|
@d = grep !$args{$_}, @d;
|
|
if (@d) {
|
|
print "$pkg: required by ", join_with("and", sort @d), "\n";
|
|
next;
|
|
}
|
|
}
|
|
}
|
|
eval {
|
|
$pkg_o->run_script("uninstall", $area, undef, {
|
|
old_version => $pkg_o->{version},
|
|
packlist => $area->package_packlist($pkg_o->{id}),
|
|
});
|
|
print "$pkg_o->{name}: ";
|
|
$area->uninstall($pkg_o->{name});
|
|
};
|
|
if ($@) {
|
|
print clean_err($@) . "\n";
|
|
}
|
|
else {
|
|
print "uninstalled\n";
|
|
$removed_count++;
|
|
}
|
|
}
|
|
if ($removed_count) {
|
|
update_html_toc();
|
|
}
|
|
else {
|
|
die "No packages uninstalled";
|
|
}
|
|
}
|
|
|
|
BEGIN {
|
|
# aliases for PPM3 compatibility (mostly)
|
|
*do_update = \&do_upgrade;
|
|
*do_uninstall = \&do_remove;
|
|
}
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
ppm - Perl Package Manager, version 4
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
Invoke the graphical user interface:
|
|
|
|
ppm
|
|
ppm gui
|
|
|
|
Install, upgrade and remove packages:
|
|
|
|
ppm install [--area <area>] [--force] <pkg>
|
|
ppm install [--area <area>] [--force] <module>
|
|
ppm install [--area <area>] <url>
|
|
ppm install [--area <area>] <file>.ppd
|
|
ppm install [--area <area>] <num>
|
|
ppm upgrade [--install]
|
|
ppm upgrade <pkg>
|
|
ppm upgrade <module>
|
|
ppm remove [--area <area>] [--force] <pkg>
|
|
|
|
Manage and search install areas:
|
|
|
|
ppm area list [--csv] [--no-header]
|
|
ppm area sync
|
|
ppm list [--fields <fieldnames>] [--csv]
|
|
ppm list <area> [--fields <fieldnames>] [--csv]
|
|
ppm files <pkg>
|
|
ppm verify [<pkg>]
|
|
|
|
Manage and search repositories:
|
|
|
|
ppm repo list [--csv] [--no-header]
|
|
ppm repo sync [--force] [<num>]
|
|
ppm repo on <num>
|
|
ppm repo off <num>
|
|
ppm repo describe <num>
|
|
ppm repo add <url> [<name>] [--username <user> [--password <passwd>]]
|
|
ppm repo rename <num> <name>
|
|
ppm repo location <num> <url>
|
|
ppm repo suggest
|
|
ppm search <pattern>
|
|
ppm describe <num>
|
|
ppm tree <package>
|
|
ppm tree <num>
|
|
|
|
Obtain version and copyright information about this program:
|
|
|
|
ppm --version
|
|
ppm version
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
The C<ppm> program is the package manager for ActivePerl. It
|
|
simplifies the task of locating, installing, upgrading and removing
|
|
Perl packages.
|
|
|
|
Invoking C<ppm> without arguments brings up the graphical user interface,
|
|
but ppm can also be used as a command line tool where the first argument
|
|
provide the name of the sub-command to invoke. The following sub-commands
|
|
are recognized:
|
|
|
|
=over
|
|
|
|
=item B<ppm area init> I<area>
|
|
|
|
Will initialize the given area so that PPM starts tracking the
|
|
packages it contains.
|
|
|
|
PPM allows for the addition of new install areas, which is useful for
|
|
shared ActivePerl installations where the user does not have write
|
|
permissions for the I<site> and I<perl> areas. New install areas are
|
|
added by simply setting up new library directories for perl to search,
|
|
and PPM will set up install areas to match. The easiest way to add
|
|
library directories for perl is to specify them in the C<PERL5LIB>
|
|
environment variable, see L<perlrun> for details. PPM will create
|
|
F<etc>, F<bin>, F<html> directories as needed when installing
|
|
packages. If the last segment of the library directory path is F<lib>
|
|
then the other directories will be created as siblings of the F<lib>
|
|
directory, otherwise they will be subdirectories.
|
|
|
|
=item B<ppm area list> [ B<--csv> [ I<sep> ] ] [ B<--no-header> ]
|
|
|
|
Lists the available install areas. The list displays the name, number
|
|
of installed packages and C<lib> directory location for each install
|
|
area. If that area is read-only, the name appears in parenthesis. You
|
|
will not be able to install packages or remove packages in these areas.
|
|
The default install area is marked with a C<*> after its name.
|
|
|
|
The order of the listed install areas is the order perl uses when
|
|
searching for modules. Modules installed in earlier areas override
|
|
modules installed in later ones.
|
|
|
|
The B<--csv> option selects CSV (comma-separated values) format for the
|
|
output. The default field separator can be overridden by the argument
|
|
following B<--csv>.
|
|
|
|
The B<--no-header> option suppresses column headings.
|
|
|
|
=item B<ppm area sync> [ I<area> ... ]
|
|
|
|
Synchronizes installed packages, including those installed by means
|
|
other than PPM (e.g. the CPAN shell), with the ppm database. PPM
|
|
searches the install area(s) for packages, making PPM database entries
|
|
if they do not already exist, or dropping entries for packages that no
|
|
longer exist. When used without an I<area> argument, all install areas
|
|
are synced.
|
|
|
|
=item B<ppm config> I<name> [ I<value> ]
|
|
|
|
Get or set various PPM configuration values.
|
|
|
|
=item B<ppm config list>
|
|
|
|
List all configuration options currently set.
|
|
|
|
=item B<ppm describe> I<num>
|
|
|
|
Shows all properties for a particular package from the last search
|
|
result.
|
|
|
|
=item B<ppm files> I<pkg>
|
|
|
|
Lists the full path name of the files belonging to the given package,
|
|
one line per file.
|
|
|
|
=item B<ppm help> [ I<subcommand> ]
|
|
|
|
Prints the documentation for ppm (this file).
|
|
|
|
=item B<ppm install> I<pkg> [ B<--area> I<area> ] [ B<--force> ] [ B<--nodeps> ]
|
|
|
|
=item B<ppm install> I<module> [ B<--area> I<area> ] [ B<--force> ] [ B<--nodeps> ]
|
|
|
|
=item B<ppm install> I<file>.ppd [ B<--area> I<area> ] [ B<--nodeps> ]
|
|
|
|
=item B<ppm install> I<url> [ B<--area> I<area> ] [ B<--nodeps> ]
|
|
|
|
=item B<ppm install> I<num> [ B<--area> I<area> ] [ B<--nodeps> ]
|
|
|
|
Install a package and its dependencies.
|
|
|
|
The argument to B<ppm install> can be the name of a package, the name of
|
|
a module provided by the package, the file name or the URL of a PPD file,
|
|
or the associated number for the package returned by the last C<ppm
|
|
search> command.
|
|
|
|
If the package or module requested is already installed, PPM installs
|
|
nothing. The B<--force> option can be used to make PPM install a
|
|
package even if it's already present. With B<--force> PPM resolves
|
|
file conflicts during package installation or upgrade by allowing
|
|
files already installed by other packages to be overwritten and
|
|
ownership transferred to the new package. This may break the package
|
|
that originally owned the file.
|
|
|
|
By default, new packages are installed in the C<site> area, but if the
|
|
C<site> area is read only, and there are user-defined areas set up, the
|
|
first user-defined area is used as the default instead. Use the
|
|
B<--area> option to install the package into an alternative location.
|
|
|
|
The B<--nodeps> option makes PPM attempt to install the package
|
|
without resolving any dependencies the package might have.
|
|
|
|
=item B<ppm list> [ I<area> ] [ B<--matching> I<pattern> ] [ B<--csv> [ I<sep> ] ] [ B<--no-header> ] [ ---fields B<fieldlist> ]
|
|
|
|
List installed packages. If the I<area> argument is not provided, list
|
|
the content of all install areas.
|
|
|
|
The B<--matching> option limits the output to only include packages
|
|
matching the given I<pattern>. See B<ppm search> for I<pattern> syntax.
|
|
|
|
The B<--csv> option selects CSV (comma-separated values) format for the
|
|
output. The default field separator can be overridden by the argument
|
|
following B<--csv>.
|
|
|
|
The B<--no-header> option suppress printing of the column headings.
|
|
|
|
The B<--fields> argument can be used to select what fields to show.
|
|
The argument is a comma separated list of the following field names:
|
|
|
|
=over
|
|
|
|
=item B<name>
|
|
|
|
The package name. This field is always shown, but if specified
|
|
alone get rid of the decorative box.
|
|
|
|
=item B<version>
|
|
|
|
The version number of the package.
|
|
|
|
=item B<release_date>
|
|
|
|
The release date of the package.
|
|
|
|
=item B<abstract>
|
|
|
|
A one sentence description of the purpose of the package.
|
|
|
|
=item B<author>
|
|
|
|
The package author or maintainer.
|
|
|
|
=item B<area>
|
|
|
|
Where the package is installed.
|
|
|
|
=item B<files>
|
|
|
|
The number of files installed for the package.
|
|
|
|
=item B<size>
|
|
|
|
The combined disk space used for the package.
|
|
|
|
=item B<ppd_uri>
|
|
|
|
The location of the package description file.
|
|
|
|
=back
|
|
|
|
=item B<ppm log> [ B<--errors> ] [ I<minutes> ]
|
|
|
|
Print entries from the log for the last few minutes. By default print
|
|
log lines for the last minute. With B<--errors> option suppress
|
|
warnings, trace and debug events.
|
|
|
|
=item B<ppm query> I<pattern>
|
|
|
|
Alias for B<ppm list --matching> I<pattern>. Provided for PPM version
|
|
3 compatibility.
|
|
|
|
=item B<ppm remove> [ B<--area> I<area> ] [ B<--force> ] I<pkg> ...
|
|
|
|
Uninstalls the specified package. If I<area> is provided unininstall
|
|
from the specified area only. With B<--force> uninstall even if there
|
|
are other packages that depend on features provided by the given
|
|
package.
|
|
|
|
=item B<ppm rep> ...
|
|
|
|
Alias for B<ppm repo>. Provided for PPM version 3 compatibility.
|
|
|
|
=item B<ppm repo>
|
|
|
|
Alias for B<ppm repo list>.
|
|
|
|
=item B<ppm repo add> I<url> [ I<name> ] [ B<--username> I<user> [ B<--password> I<password> ]
|
|
|
|
Set up a new repository for PPM to fetch packages from.
|
|
|
|
=item B<ppm repo delete> I<num>
|
|
|
|
Remove repository number I<num>.
|
|
|
|
=item B<ppm repo describe> I<num>
|
|
|
|
Show all properties for repository number I<num>.
|
|
|
|
=item B<ppm repo list> [ B<--csv> [ I<sep> ] ] [ B<--no-header> ]
|
|
|
|
List the repositories that PPM is currently configured to use. Use this
|
|
to identify which number specifies a particular repository.
|
|
|
|
The B<--csv> option selects comma-separated values format for the
|
|
output. The default field separator can be overridden by the argument
|
|
following B<--csv>.
|
|
|
|
The B<--no-header> option suppress printing of the column headings.
|
|
|
|
|
|
=item B<ppm repo> I<num>
|
|
|
|
Alias for B<ppm repo describe> I<num>.
|
|
|
|
=item B<ppm repo> I<num> I<cmd>
|
|
|
|
Alias for B<ppm repo> I<cmd> I<num>.
|
|
|
|
=item B<ppm repo off> I<num>
|
|
|
|
Disable repository number I<num> for B<ppm install> or B<ppm search>.
|
|
|
|
=item B<ppm repo on> I<num>
|
|
|
|
Enable repository number I<num> if it has been previously disabled with
|
|
B<ppm repo off>.
|
|
|
|
=item B<ppm repo rename> I<num> I<name>
|
|
|
|
Change name by which the given repo is known.
|
|
|
|
=item B<ppm repo location> I<num> I<url>
|
|
|
|
Change the location of the given repo. This will make PPM
|
|
forget all cached data from the old repository and try to refetch it
|
|
from the new location.
|
|
|
|
=item B<ppm repo search> ...
|
|
|
|
Alias for B<ppm seach>.
|
|
|
|
=item B<ppm repo suggest>
|
|
|
|
List some known repositories that can be added with B<ppm add>. PPM
|
|
needs the C<PPM-Repositories> package to be installed for this option
|
|
to work. To install it:
|
|
|
|
ppm install PPM-Repositories
|
|
|
|
This package supplies PPM with a list of repositories maintained by
|
|
third parties (not by ActiveState). For example, to add the theoryx5
|
|
repository:
|
|
|
|
ppm repo add theory58S
|
|
|
|
=item B<ppm repo sync> [ B<--force> ] [ B<--max-ppd> I<max> ] [ I<num> ]
|
|
|
|
Synchronize local cache of packages found in the enabled repositories.
|
|
With the B<--force> option, download state from remote repositories even
|
|
if the local state has not expired yet. If I<num> is provided, only sync
|
|
the given repository.
|
|
|
|
PPM will need to download every PPD file for repositories that don't
|
|
provide a summary file (F<package.xml>). This can be very slow for
|
|
large repositories. Thus PPM refuses to start the downloads with
|
|
repositores linking to more that 100 PPD files unless the B<--max-ppd>
|
|
option provides a higher limit.
|
|
|
|
=item B<ppm search> I<pattern>
|
|
|
|
Search for packages matching I<pattern> in all enabled repositories.
|
|
|
|
For I<pattern>, use the wildcard C<*> to match any number of characters
|
|
and the wildcard C<?> to match a single character. For example, to find
|
|
packages starting with the string "List" search for C<list*>. Searches
|
|
are case insensitive.
|
|
|
|
If I<pattern> contains C<::>, PPM will search for packages that provide
|
|
modules matching the pattern.
|
|
|
|
If I<pattern> matches the name of a package exactly (case-sensitively),
|
|
only that package is shown. A I<pattern> without wildcards that does
|
|
not match any package names exactly is used for a substring search
|
|
against available package names (i.e. treated the same as
|
|
"B<*>I<pattern>B<*>").
|
|
|
|
The output format depends on how many packages match. If there is only
|
|
one match, the B<ppm describe> format is used. If only a few packages
|
|
match, limited information is displayed. If many packages match, only
|
|
the package names and version numbers are displayed, one per line.
|
|
|
|
The number prefixing each entry in search output can be used to look
|
|
up full information with B<ppm describe> I<num>, dependencies with
|
|
B<ppm tree> I<num> or to install the package with B<ppm install>
|
|
I<num>.
|
|
|
|
=item B<ppm tree> I<package>
|
|
|
|
=item B<ppm tree> I<num>
|
|
|
|
Shows all the dependencies (recusively) for a particular package. The
|
|
package can be identified by a package name or the associated number
|
|
for the package returned by the last C<ppm search> command.
|
|
|
|
=item B<ppm uninstall> ...
|
|
|
|
Alias for B<ppm remove>.
|
|
|
|
=item B<ppm update> ...
|
|
|
|
Alias for B<ppm upgrade>.
|
|
|
|
=item B<ppm upgrade> [ B<--install> ]
|
|
|
|
List packages that there are upgrades available for. With
|
|
B<--install> option install the upgrades as well.
|
|
|
|
=item B<ppm upgrade> I<pkg>
|
|
|
|
=item B<ppm upgrade> I<module>
|
|
|
|
Upgrades the specified package or module if an upgrade is available in
|
|
one of the currently enabled repositories.
|
|
|
|
=item B<ppm verify> [ I<pkg> ]
|
|
|
|
Checks that the installed files are still present and unmodified. If
|
|
the package name is given, only that packages is verified.
|
|
|
|
=item B<ppm version>
|
|
|
|
Will print the version of PPM and a copyright notice.
|
|
|
|
=back
|
|
|
|
=head1 FILES
|
|
|
|
The following lists files and directories that PPM uses and creates:
|
|
|
|
=over
|
|
|
|
=item F<$HOME/.ActivePerl/$VERSION/>
|
|
|
|
Directory where PPM keeps its state. On Windows this directory is
|
|
F<$LOCAL_APPDATA/ActiveState/ActivePerl/$VERSION>. The $VERSION is a string
|
|
like "818".
|
|
|
|
=item F<$HOME/.ActivePerl/$VERSION/ppm-$ARCH.db>
|
|
|
|
SQLite database where ppm keeps its configuration and caches meta
|
|
information about the content of the enabled repositories.
|
|
|
|
=item F<$HOME/ppm4.log>
|
|
|
|
Log file created to record actions that PPM takes. On Windows this is
|
|
logged to F<$TEMPDIR/ppm4.log>.
|
|
|
|
=item F<$PREFIX/etc/ppm-$NAME-area.db>
|
|
|
|
SQLite database where PPM tracks packages installed in the install area
|
|
under C<$PREFIX>.
|
|
|
|
=item F<$TEMPDIR/ppm-XXXXXX/>
|
|
|
|
Temporary directories used during install. Packages to be installed
|
|
are unpacked here.
|
|
|
|
=item F<*.ppd>
|
|
|
|
XML files containing meta information about packages. Each package has
|
|
its own .ppd file. See L<ActivePerl::PPM::PPD> for additional
|
|
information.
|
|
|
|
=item F<package.xml>
|
|
|
|
Meta information about repositories. When a repository is added, PPM
|
|
looks for this file and if present, monitors it too stay in sync with
|
|
the state of the repository.
|
|
|
|
=item F<package.lst>
|
|
|
|
Same as F<package.xml> but PPM 3 compatible. PPM will use this file
|
|
if F<package.xml> is not available.
|
|
|
|
=back
|
|
|
|
=head1 ENVIRONMENT
|
|
|
|
The following environment variables affect how PPM behaves:
|
|
|
|
=over
|
|
|
|
=item C<ACTIVEPERL_PPM_DEBUG>
|
|
|
|
If set to a TRUE value, makes PPM print more internal diagnostics.
|
|
|
|
=item C<ACTIVEPERL_PPM_BOX_CHARS>
|
|
|
|
Select what kind of box drawing characters to use for the C<ppm *
|
|
list> outputs. Valid values are C<ascii>, C<dos> and C<unicode>. The
|
|
default varies.
|
|
|
|
=item C<ACTIVEPERL_PPM_HOME>
|
|
|
|
If set, use this directory to store state and configuration
|
|
information for PPM. This defaults to
|
|
F<$LOCAL_APPDATA/ActiveState/ActivePerl/$VERSION> on Windows and
|
|
F<$HOME/.ActivePerl/$VERSION/> on Unix systems.
|
|
|
|
=item C<ACTIVEPERL_PPM_LOG_CONS>
|
|
|
|
If set to a TRUE value, make PPM print any log output to the console as
|
|
well.
|
|
|
|
=item C<DBI_TRACE>
|
|
|
|
PPM uses L<DBI> to access the internal SQLite databases. Setting
|
|
DBI_TRACE allow you to see what queries are performed. Output goes to
|
|
STDERR. See L<DBI> for further details.
|
|
|
|
=back
|
|
|
|
=head1 WHAT'S NEW IN VERSION 4
|
|
|
|
PPM version 4 is a complete rewrite. The main changes since PPM version 3 are:
|
|
|
|
=over
|
|
|
|
=item *
|
|
|
|
The command line shell has been replaced with a graphical user interface.
|
|
|
|
=item *
|
|
|
|
PPM can now manage different installation areas.
|
|
|
|
=item *
|
|
|
|
No more 'precious' packages. PPM can upgrade itself as well other
|
|
bundled and core modules.
|
|
|
|
=item *
|
|
|
|
Installation of packages and their dependencies happen as atomic
|
|
transactions.
|
|
|
|
=item *
|
|
|
|
PPM tracks what files it has installed and can notice if files have been
|
|
modified or deleted. The command 'ppm verify' will report on
|
|
mismatches.
|
|
|
|
=item *
|
|
|
|
State is kept in local SQLite databases. All repository state is kept
|
|
local which makes searching much faster.
|
|
|
|
=item *
|
|
|
|
PPM will pick up and manage packages installed by other means (e.g.
|
|
manually or with the CPAN shell).
|
|
|
|
=item *
|
|
|
|
No more SOAP.
|
|
|
|
=item *
|
|
|
|
Underlying modules moved to the C<ActivePerl::PPM::> namespace.
|
|
|
|
=back
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<activeperl>
|
|
|
|
L<http://search.cpan.org/dist/PPM-Repositories/>
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (C) 2007 ActiveState Software Inc. All rights reserved.
|
|
|
|
=cut
|