package ActivePerl::PPM::Client; use strict; use Config qw(%Config); use ActivePerl (); use ActivePerl::PPM::InstallArea (); use ActivePerl::PPM::Package (); use ActivePerl::PPM::RepoPackage (); use ActivePerl::PPM::PPD (); use ActivePerl::PPM::Logger qw(ppm_log ppm_debug ppm_status); use ActivePerl::PPM::Web qw(web_ua); use ActivePerl::PPM::Util qw(join_with update_html_toc); use ActiveState::Path qw(is_abs_path join_path); use File::Basename; use base 'ActivePerl::PPM::DBH'; sub new { my($class, $dir, $arch) = @_; $dir ||= $ENV{ACTIVEPERL_PPM_HOME} || do { if ($^O eq "MSWin32") { require Win32; my $appdata = Win32::GetFolderPath(Win32::CSIDL_LOCAL_APPDATA()) || Win32::GetFolderPath(Win32::CSIDL_APPDATA()) || $ENV{APPDATA} || $ENV{HOME}; die "No valid setting for APPDATA\n" unless $appdata; $appdata = Win32::GetShortPathName($appdata) || $appdata; "$appdata/ActiveState/ActivePerl/$ActivePerl::VERSION"; } else { "$ENV{HOME}/.ActivePerl/$ActivePerl::VERSION"; } }; unless ($arch) { $arch = $Config{archname}; if ($] >= 5.008) { my $vstring = sprintf "%vd", $^V; $vstring =~ s/\.\d+$//; $arch .= "-$vstring"; } } my $etc = $dir; # XXX or "$dir/etc"; my @inc = defined(*main::INC_ORIG) ? @main::INC_ORIG : @INC; # determine what install areas exists from @INC my @area; my %area; my @tmp = @inc; while (@tmp) { my $dir = shift(@tmp); next unless is_abs_path($dir); if (my $name = _known_area($dir)) { push(@area, $name) unless grep $_ eq $name, @area; next; } my $base = File::Basename::basename($dir); my $archlib; if ($base eq $Config{archname} || $base eq "arch") { $archlib = $dir; $dir = File::Basename::dirname($dir); $dir = join_path($dir, "lib") if $base eq "arch"; shift(@tmp) if $tmp[0] eq $dir; } my $lib = $dir; $base = File::Basename::basename($dir); $dir = File::Basename::dirname($dir) if $base eq "lib"; my $name = _area_name($dir); while (grep $_ eq $name, @area) { # make name unique my $num = ($name =~ s/_(\d+)//) ? $1 : 1; $name .= "_" . ++$num; } push(@area, $name); my $autoinit = 0; $autoinit = 1 if $^O eq "darwin" && $dir eq "$ENV{HOME}/Library/ActivePerl"; $area{$name} = ActivePerl::PPM::InstallArea->new( name => $name, prefix => $dir, lib => $lib, archlib => $archlib, autoinit => $autoinit, ); } # make sure these install areas always show up for my $a (qw(site perl)) { push(@area, $a) unless grep $_ eq $a, @area; } my $self = bless { dir => $dir, etc => $etc, arch => $arch, area => \%area, area_seq => \@area, inc => \@inc, }, $class; return $self; } sub _known_area { my $path = shift; return "perl" if _path_eq($path, $Config{privlib}, $Config{archlib}); return "site" if _path_eq($path, $Config{sitelib}, $Config{sitearch}); return "vendor" if $Config{vendorlib} && _path_eq($path, $Config{vendorlib}, $Config{vendorarch}); return undef; } sub _path_eq { my @paths = @_; for (@paths) { s,/,\\,g if $^O eq "MSWin32"; $_ = lc($_) if $^O eq "MSWin32" || $^O eq "darwin"; } my $first = shift(@paths); for my $p (@paths) { return 1 if $first eq $p; } return 0; } sub _area_name { my $path = shift; # obtain name from the ppm-*-area.db file if present if (opendir(my $dh, "$path/etc")) { while (defined(my $f = readdir($dh))) { if ($f =~ /^ppm-(\w+)-area.db$/) { if ($1 eq "perl" || $1 eq "site" || $1 eq "vendor") { ppm_log("WARN", "Found $f in $path/etc"); last; } return $1; } } closedir($dh); } # try to find a usable name from the $path my @path = split(/[\/\\]/, $path); while (@path) { my $segment = pop(@path); my $lc_segment = lc($segment); next if $segment eq "lib" || $segment eq "arch" || $segment eq $Config{archname}; next if $lc_segment eq "perl" || $lc_segment eq "site" || $lc_segment eq "vendor"; return "pdk" if $segment =~ /\bPerl Dev Kit\b/; next unless $segment =~ /^[\w\-.]{1,12}$/; return $segment; } # last resort return "user"; } sub arch { my $self = shift; return $self->{arch}; } sub areas { my $self = shift; return @{$self->{area_seq}}; } sub area { my($self, $name) = @_; return undef unless $name; return $self->{area}{$name} ||= do { die "Install area '$name' does not exist" unless grep $_ eq $name, @{$self->{area_seq}}; ActivePerl::PPM::InstallArea->new(name => $name, autoinit => 1); } } sub default_install_area { my $self = shift; my $area = "site"; if ($self->area($area)->readonly) { my @areas = $self->areas; while (defined($area = shift(@areas))) { next if $area eq "perl" || $area eq "site" || $area eq "vendor"; next if $area eq "pdk"; last unless $self->area($area)->readonly; } } return $area; } sub _init_db { my $self = shift; my $etc = $self->{etc}; unless (-d $etc) { require File::Path; File::Path::mkpath($etc) || die "Can't mkpath($etc): $!"; } require DBI; my $file_arch = $self->{arch}; $file_arch =~ s/\./_/g; # don't confuse version number dots with file extension my $db_file = "$etc/ppm-$file_arch.db"; my $dbh = DBI->connect("dbi:SQLite:dbname=$db_file", "", "", { AutoCommit => 1, RaiseError => 1, }); die "$db_file: $DBI::errstr" unless $dbh; local $dbh->{AutoCommit} = 0; my $v = $dbh->selectrow_array("PRAGMA user_version"); die "Assert" unless defined $v; if ($v == 0) { ppm_log("WARN", "Setting up schema for $db_file"); _init_ppm_schema($dbh, $self->{arch}); $dbh->do("PRAGMA user_version = 1"); $dbh->commit; } elsif ($v != 1) { die "Unrecognized database schema $v for $db_file"; } $self->{dbh} = $dbh; } sub _init_ppm_schema { my($dbh, $arch) = @_; $dbh->do(<<'EOT'); CREATE TABLE config ( key text primary key, value text ) EOT $dbh->do(<<'EOT'); CREATE TABLE repo ( id integer primary key, name text not null, prio integer not null default 1, enabled bit not null default 1, packlist_uri text not null unique, packlist_version text, packlist_last_status_code int, packlist_last_access integer, packlist_etag text, packlist_size integer, packlist_lastmod text, packlist_fresh_until integer ) EOT for my $create (ActivePerl::PPM::RepoPackage->sql_create_tables()) { $dbh->do($create) || die "Can't create database table"; } $dbh->do("CREATE TABLE search ( id integer )"); # initial values $dbh->do("INSERT INTO config(key, value) VALUES ('arch', ?)", undef, $arch); if (my @repo = activestate_repo()) { $dbh->do(qq(INSERT INTO repo(name,packlist_uri) VALUES (?, ?)), undef, @repo); } } sub config_get { my $self = shift; my $dbh = $self->dbh; my @res; for (@_) { my $v = $dbh->selectrow_array("SELECT value FROM config WHERE key = ?", undef, $_); push(@res, $v); } return wantarray ? @res : $res[0]; } sub config_list { my $self = shift; my $dbh = $self->dbh; my $sth = $dbh->prepare( "SELECT key, value FROM config" . (@_ ? " WHERE key GLOB ?" : "") . " ORDER BY key", ); $sth->execute(@_); my @kv; while (my($k, $v) = $sth->fetchrow_array) { push(@kv, $k, $v); } return @kv; } sub config_save { my $self = shift; my $dbh = $self->dbh; local $dbh->{AutoCommit} = 0; while (@_) { my $k = shift; my $v = shift; $dbh->do("INSERT OR REPLACE INTO config (key,value) VALUES (?, ?)", undef, $k, $v); } $dbh->commit; } sub activestate_repo { my $arch = $Config{archname}; 1 while $arch =~ s/-(thread|multi|2level)//; my $v = ActivePerl::perl_version(); $v =~ s,^(\d+\.\d+)\.\d+\.,$1/,; my $repo_uri = "http://ppm4.activestate.com/$arch/$v/package.xml"; if ($^O =~ /^(MSWin32|linux|darwin|hpux|solaris)$/ || web_ua()->head($repo_uri)->is_success) { return $repo_uri unless wantarray; return ("ActiveState Package Repository", $repo_uri); } return; } sub repos { my $self = shift; @{$self->dbh->selectcol_arrayref("SELECT id FROM repo ORDER BY id")}; } sub repo { my($self, $id) = @_; my $dbh = $self->dbh; my $hash = $dbh->selectrow_hashref("SELECT * FROM repo WHERE id = ?", undef, $id); if ($hash) { my $pkgs = $dbh->selectrow_array("SELECT count(*) FROM package WHERE repo_id = ?", undef, $id); $hash->{pkgs} = $pkgs; } return $hash; } sub repo_enable { my $self = shift; my $id = shift; my $enabled = @_ ? (shift(@_) ? 1 : 0) : 1; my $dbh = $self->dbh; if ($self->dbh->do("UPDATE repo SET enabled = ?, packlist_etag = NULL, packlist_lastmod = NULL, packlist_size = NULL, packlist_fresh_until = NULL WHERE id = ?", undef, $enabled, $id)) { if ($enabled) { $self->repo_sync; } else { local $dbh->{AutoCommit} = 0; _repo_delete_packages($dbh, $id); $dbh->commit; } } } sub repo_add { my($self, %attr) = @_; my $dbh = $self->dbh; local $dbh->{RaiseError} = 0; if ($dbh->do("INSERT INTO repo (name, packlist_uri, prio) VALUES (?, ?, ?)", undef, $attr{name}, $attr{packlist_uri}, ($attr{prio} || 0))) { my $id = $dbh->func('last_insert_rowid'); $self->repo_sync; return $id; } my $err = $DBI::errstr; if (my $repo = $self->dbh->selectrow_hashref("SELECT * FROM repo WHERE packlist_uri = ?", undef, $attr{packlist_uri})) { die "Repo ", $repo->{name} || $repo->{id}, " already set up with URL $attr{packlist_uri}"; } die $err; } sub repo_delete { my($self, $id) = @_; my $dbh = $self->dbh; local $dbh->{AutoCommit} = 0; _repo_delete_packages($dbh, $id); $dbh->do("DELETE FROM repo WHERE id = ?", undef, $id); $dbh->commit; } sub _repo_delete_packages { my($dbh, $id) = @_; $dbh->do("DELETE FROM feature WHERE package_id IN (SELECT id FROM package WHERE repo_id = ?)", undef, $id); $dbh->do("DELETE FROM script WHERE package_id IN (SELECT id FROM package WHERE repo_id = ?)", undef, $id); $dbh->do("DELETE FROM package WHERE repo_id = ?", undef, $id); } sub repo_set_name { my($self, $id, $name) = @_; my $dbh = $self->dbh; $dbh->do("UPDATE repo SET name = ? WHERE id = ?", undef, $name, $id); } sub repo_set_packlist_uri { my($self, $id, $uri) = @_; my $dbh = $self->dbh; $dbh->{AutoCommit} = 0; $dbh->do("UPDATE repo SET packlist_uri = ?, packlist_last_status_code = NULL, packlist_last_access = NULL, packlist_etag = NULL, packlist_size = NULL, packlist_lastmod = NULL, packlist_fresh_until = NULL WHERE id = ?", undef, $uri, $id); _repo_delete_packages($dbh, $id); $dbh->commit; } sub repo_sync { my($self, %opt) = @_; # force implies validate $opt{validate} ||= $opt{force}; my @repos; my $dbh = $self->dbh; local $dbh->{AutoCommit} = 0; my $sth = $dbh->prepare("SELECT * FROM repo WHERE enabled == 1" . ($opt{repo} ? " AND id = $opt{repo}" : "") . " ORDER BY id"); $sth->execute(); while (my $h = $sth->fetchrow_hashref) { push(@repos, $h); } if ($opt{repo} && !@repos) { if ($dbh->selectrow_array("SELECT count(*) FROM repo WHERE id = $opt{repo}")) { die "Repo $opt{repo} is not enabled"; } else { die "Repo $opt{repo} does not exist"; } } for my $repo (@repos) { my @check_ppd; my %delete_package; if (!$opt{validate} && $repo->{packlist_fresh_until} && $repo->{packlist_fresh_until} >= time) { @check_ppd = (); # XXX should we still check them? ppm_log("DEBUG", "$repo->{packlist_uri} is still fresh"); } else { my $ua = web_ua(); local $ua->{progress_what} = "Downloading $repo->{name} packlist"; my $res; if ($repo->{packlist_last_status_code}) { # if we continue to get errors from repo, only hit it occasionally if (!$opt{validate} && HTTP::Status::is_error($repo->{packlist_last_status_code}) && (time - $repo->{packlist_last_access} < 5 * 60)) { ppm_log("WARN", "$repo->{packlist_uri} is known to err, skipping sync"); next; } } else { # first time, try to find the package.xml or package.lst file my $uri = $repo->{packlist_uri}; unless ($uri =~ m,/package\.(xml|lst)$,) { $uri = URI->new($uri); my @try; my $uri_slash = $uri; unless ($uri_slash->path =~ m,/$,) { $uri_slash = $uri->clone; $uri_slash->path( $uri->path . "/"); } push(@try, URI->new_abs("package.xml", $uri_slash)); push(@try, URI->new_abs("package.lst", $uri_slash)); my $try; for $try (@try) { my $try_res = $ua->get($try); if ($try_res->is_success && $try_res->decoded_content(default_charset => "none") =~ /{packlist_uri} = $try->as_string; $dbh->do("UPDATE repo SET packlist_uri = ? WHERE id = ?", undef, $repo->{packlist_uri}, $repo->{id}); $res = $try_res; ppm_log("WARN", "Will use $repo->{packlist_uri} instead"); last; } } } } unless ($res) { my @h; if (!$opt{force}) { push(@h, "If-None-Match", $repo->{packlist_etag}) if $repo->{packlist_etag}; push(@h, "If-Modified-Since", $repo->{packlist_lastmod}) if $repo->{packlist_lastmod}; } $res = $ua->get($repo->{packlist_uri}, @h); } $dbh->do("UPDATE repo SET packlist_last_status_code = ?, packlist_last_access = ? WHERE id = ?", undef, $res->code, time, $repo->{id}); #print $res->status_line, "\n"; if ($res->code == 304) { # not modified @check_ppd = @{$dbh->selectcol_arrayref("SELECT ppd_uri FROM package WHERE ppd_uri NOTNULL AND repo_id = ?", undef, $repo->{id})}; $dbh->do("UPDATE repo SET packlist_fresh_until=? WHERE id=?", undef, $res->fresh_until, $repo->{id}); } elsif ($res->is_success) { $dbh->do("UPDATE repo SET packlist_etag=?, packlist_lastmod=?, packlist_size=?, packlist_fresh_until=? WHERE id=?", undef, scalar($res->header("ETag")), scalar($res->header("Last-Modified")), scalar($res->header("Content-Length")), $res->fresh_until, $repo->{id}); # parse document eval { my $cref = $res->decoded_content(ref => 1, default_charset => "none", raise_error => 1); if ($res->content_type eq "text/html") { my $base = $res->base; require HTML::Parser; my $p = HTML::Parser->new( report_tags => [qw(a)], start_h => [sub { my $href = shift->{href} || return; push(@check_ppd, URI->new_abs($href,$base)->rel($repo->{packlist_uri})) if $href =~ /\.ppd$/; }, "attr"], ); $p->parse($$cref)->eof; ppm_log("WARN", "No ppds found in $repo->{packlist_uri}") unless @check_ppd; %delete_package = map { $_ => 1 } @{$dbh->selectcol_arrayref("SELECT id FROM package WHERE repo_id = ?", undef, $repo->{id})}; my $max_ppd = $opt{max_ppd} || 100; if (@check_ppd > $max_ppd) { my $num_ppd = @check_ppd; ppm_log("ERR", "PPD downloads blocked. The repo $repo->{packlist_uri} links to $num_ppd PPD files. Current download limit is $max_ppd."); @check_ppd = (); %delete_package = (); } } elsif ($$cref =~ /begin("Updating $repo->{name} database"); _repo_delete_packages($dbh, $repo->{id}); $status->tick; require ActivePerl::PPM::ParsePPD; my $p = ActivePerl::PPM::ParsePPD->new(sub { my $pkg = shift; $pkg = ActivePerl::PPM::RepoPackage->new_ppd($pkg, arch => $self->{arch}); $pkg->{repo_id} = $repo->{id}; $pkg->dbi_store($dbh) if $pkg->{codebase}; $status->tick; }); $p->parse_more($$cref); $p->parse_done; $status->end; } else { ppm_log("ERR", "Unrecognized repo type " . $res->content_type); } }; if ($@) { ppm_log("ERR", "Unable to process reponse from repo $repo->{name}: $@"); } } else { $dbh->do("UPDATE repo SET packlist_fresh_until=? WHERE id=?", undef, 0, $repo->{id}); } } for my $ppd (@check_ppd) { _check_ppd($ppd, $self->{arch}, $repo, $dbh, \%delete_package); } $dbh->do("DELETE FROM package WHERE id IN (" . join(",", sort keys %delete_package) . ")") if %delete_package; $dbh->commit; } return; } sub _check_ppd { my($rel_url, $arch, $repo, $dbh, $delete_package) = @_; my $row = $dbh->selectrow_hashref("SELECT id, ppd_etag, ppd_lastmod, ppd_fresh_until FROM package WHERE repo_id = ? AND ppd_uri = ?", undef, $repo->{id}, $rel_url); my @h; if ($row) { if ($row->{ppd_fresh_until} && $row->{ppd_fresh_until} > time) { delete $delete_package->{$row->{id}} if $delete_package; return; } push(@h, "If-None-Match", $row->{ppd_etag}) if $row->{ppd_etag}; push(@h, "If-Modified-Since", $row->{ppd_lastmod}) if $row->{ppd_lastmod}; } my $abs_url = URI->new_abs($rel_url, $repo->{packlist_uri}); my $ua = web_ua(); (my $base_url = $rel_url) =~ s,.*/,,; $base_url =~ s,\.ppd$,,; local $ua->{progress_what} = "Downloading $repo->{name} $base_url PPD"; my $ppd_res = $ua->get($abs_url, @h); #print $ppd_res->as_string, "\n" unless $ppd_res->code eq 200 || $ppd_res->code eq 304; if ($row && $ppd_res->code == 304) { # not modified $dbh->do("UPDATE package SET ppd_fresh_until = ? WHERE id = ?", undef, $ppd_res->fresh_until, $row->{id}); delete $delete_package->{$row->{id}} if $delete_package; } elsif ($ppd_res->is_success) { my $ppd = ActivePerl::PPM::RepoPackage->new_ppd( $ppd_res->decoded_content(default_charset => "none"), arch => $arch, base => $ppd_res->base, rel_base => $abs_url, ); if ($ppd->{codebase}) { $ppd->{id} = $row->{id} if $row; $ppd->{repo_id} = $repo->{id}; $ppd->{ppd_uri} = $rel_url; $ppd->{ppd_etag} = $ppd_res->header("ETag"); $ppd->{ppd_lastmod} = $ppd_res->header("Last-Modified"); $ppd->{ppd_fresh_until} = $ppd_res->fresh_until; $ppd->dbi_store($dbh); delete $delete_package->{$row->{id}} if $delete_package && $row; } } } sub packages { my $self = shift; my $dbh = $self->dbh; if (@_) { my $aref = $dbh->selectall_arrayref("SELECT " . join(",", @_) . " FROM package"); my $i = 0; for my $f (@_) { if ($f eq "abstract" || $f eq "author") { # Potential Unicode field for my $row (@$aref) { if (($row->[$i] || "") =~ /[^\x00-\x7F]/) { utf8::decode($row->[$i]); } } } $i++; } return @$aref; } return @{$dbh->selectcol_arrayref("SELECT id FROM package")} if wantarray; return $dbh->selectrow_array("SELECT count(*) FROM package"); } sub search { my($self, $pattern, @fields) = @_; @fields = ("name") unless @fields; my $dbh = $self->dbh; $dbh->do("DELETE FROM search"); local $dbh->{AutoCommit} = 0; SEARCH: { if ($pattern =~ /::/) { my $op = ($pattern =~ /\*/) ? "GLOB" : "="; $dbh->do("INSERT INTO search SELECT id FROM package WHERE id IN (SELECT package_id FROM feature WHERE lower(name) $op ? AND role = 'p') ORDER BY name", undef, lc($pattern)); last SEARCH; } if ($pattern eq '*') { $dbh->do("INSERT INTO search SELECT id FROM package ORDER BY name"); last SEARCH; } unless ($pattern =~ /\*/) { $dbh->do("INSERT INTO search SELECT id FROM package WHERE name = ?", undef, $pattern); last SEARCH if $dbh->selectrow_array("SELECT count(*) FROM search"); # try again with a wider net $dbh->rollback; $pattern = "*$pattern*"; } $dbh->do("INSERT INTO search SELECT id FROM package WHERE lower(name) GLOB ? ORDER BY name", undef, lc($pattern)); } $dbh->commit; my $fields = join(", ", map "package.$_", @fields); my $select_arrayref = @fields > 1 ? "selectall_arrayref" : "selectcol_arrayref"; return @{$dbh->$select_arrayref("SELECT $fields FROM package,search WHERE package.id = search.id ORDER by search.rowid")}; } sub search_lookup { my($self, $row) = @_; my $dbh = $self->dbh; my $id = $dbh->selectrow_array("SELECT id FROM search WHERE rowid = $row"); return $self->package($id) if defined $id; return undef; } sub feature_best { my($self, $feature) = @_; my $dbh = $self->dbh; my($max) = $dbh->selectrow_array("SELECT max(version) FROM feature WHERE name = ? AND role = 'p'", undef, $feature); return $max; } sub package_best { my($self, $feature, $version) = @_; my $dbh = $self->dbh; my $ids = $dbh->selectcol_arrayref("SELECT package.id FROM package, feature WHERE package.id = feature.package_id AND feature.role = 'p' AND feature.name = ? AND feature.version >= ?", undef, $feature, $version); my @pkg = map $self->package($_), @$ids; return ActivePerl::PPM::Package::best(@pkg); } sub feature_have { my $self = shift; my $feature = shift; for my $area_name (@_ ? @_ : $self->areas) { my $area = $self->area($area_name); next if !@_ && !$area->initialized; if (defined(my $have = $area->feature_have($feature))) { ppm_debug("Feature $feature found in $area_name"); return $have; } ppm_debug("Feature $feature not found in $area_name"); } if (!@_ && $feature =~ /::/) { require ActiveState::ModInfo; if (my $path = ActiveState::ModInfo::find_module($feature, $self->{inc})) { return ActiveState::ModInfo::parse_version($path) || 0; } ppm_debug("Module $feature not found in \@INC"); } return undef; } sub feature_fixup_case { my($self, $name) = @_; my $dbh = $self->dbh; my $names = $dbh->selectcol_arrayref("SELECT DISTINCT name FROM feature WHERE role = 'p' AND lower(name) = lower(?)", undef, $name); if (@$names && !grep $_ eq $name, @$names) { die "Feature name $name is ambiguous; please select one of:\n " . join(", ", @$names) if @$names > 1; ppm_log("WARN", "Using feature name '$names->[0]' instead of '$name'"); $name = $names->[0]; } return $name; } sub packages_depending_on { my($self, $pkg, $area_name) = @_; my $pkg_name; if (ref $pkg) { $pkg_name = $pkg->name; } else { $pkg_name = $pkg; $pkg = undef; } unless ($area_name) { for $a ($self->areas) { my $area = $self->area($a); next unless $area->initialized; if (defined $area->package_id($pkg_name)) { $area_name = $a; last; } } die "Can't find $pkg_name in any area" unless $area_name; #print "Found $pkg_name in $area_name\n"; } $pkg = $self->area($area_name)->package($pkg_name) unless $pkg; my %provide = $pkg->provides; #print "$pkg_name provide: @{[sort keys %provide]}\n"; my $feature_sql = join(",", map "'$_'", sort keys %provide); # find packages that require any of the features $pkg provide my @dep_pkgs; for $a ($self->areas) { my $area = $self->area($a); next unless $area->initialized; my $dbh = $area->dbh; my $pkg_ids = $dbh->selectcol_arrayref("SELECT package_id FROM feature WHERE role = 'r' AND name in ($feature_sql)"); next unless $pkg_ids && @$pkg_ids; for my $dep_pkg (map $area->package($_), @$pkg_ids) { next if $a eq $area_name && $pkg->name eq $dep_pkg->name; push(@dep_pkgs, $dep_pkg); } } # XXX Check versions # XXX Check if dependant features are provided by other package return @dep_pkgs; } sub packages_missing { my($self, %args) = @_; my @pkg_have = @{delete $args{have} || []}; my @area_have = @{delete $args{area} || []}; my @todo = @{delete $args{want} || []}; my $force = delete $args{force}; my $follow_deps = delete $args{follow_deps} || "missing"; if (my $want_deps = delete $args{want_deps}) { push(@pkg_have, @$want_deps); for my $pkg (@$want_deps) { if ($follow_deps ne "none") { if (my $dep = $pkg->{require}) { push(@todo, map [$_ => $dep->{$_}, $pkg->{name} ], keys %$dep); } } } } my $error_handler = delete $args{error_handler}; if ($^W && %args) { require Carp; Carp::carp("Unknown argument '$_' passed") for sort keys %args; } return unless @todo; my @err; my @missing_upgrade; for my $feature (@todo) { $feature = [$feature, 0] unless ref($feature); my($name, $version) = @$feature; unless (defined $version) { if (defined($version = $self->feature_best($name))) { $feature->[1] = $version; } else { push(@missing_upgrade, $name); } } } if (@missing_upgrade) { push(@err, "No " . join_with("or", sort @missing_upgrade) . " available"); @todo = grep defined($_->[1]), @todo; } my @pkg_missing; while (@todo) { my($feature, $want, $needed_by) = @{shift @todo}; ppm_debug("Want $feature >= $want"); my $have; for my $pkg (@pkg_have, @pkg_missing) { $have = $pkg->{provide}{$feature}; if (defined $have) { if ($have < $want) { my $msg = "Conflict for feature $feature version $have provided by $pkg->{name}, "; $msg .= "$needed_by " if $needed_by; $msg .= "want version $want"; push(@err, $msg); } push(@{$pkg->{_needed_by}}, $needed_by) if $needed_by; last; } } $have = $self->feature_have($feature, @area_have) unless defined($have); ppm_debug("Have $feature $have") if defined($have); if ((!$needed_by && $force) || ($needed_by && $follow_deps eq "all") || !defined($have) || $have < $want) { if (my $pkg = $self->package_best($feature, $want)) { unless ($force) { my $err = $self->is_downgrade($pkg, $feature, $needed_by); push(@err, $err) if $err; } push(@pkg_missing, $pkg); if ($needed_by) { push(@{$pkg->{_needed_by}}, $needed_by); } else { $pkg->{_wanted}++; } if ($follow_deps ne "none") { if (my $dep = $pkg->{require}) { push(@todo, map [$_ => $dep->{$_}, $pkg->{name} ], keys %$dep); } } } else { push(@err, "Can't find any package that provides $feature" . ($want && $have ? " version $want" : "") . ($needed_by ? " for $needed_by" : ""), ); } } } if (@err) { die join("\n", @err) unless $error_handler; $error_handler->(@err); } return $self->package_set_abs_ppd_uri(@pkg_missing); } sub is_downgrade { my($self, $pkg, $because, $needed_by) = @_; my @downgrade; for my $feature (sort keys %{$pkg->{provide}}) { next if $feature eq $pkg->{name}; my $have = $self->feature_have($feature); push(@downgrade, [$feature, $have, $pkg->{provide}{$feature}]) if $have && $have > $pkg->{provide}{$feature}; } if (@downgrade) { my $msg = "Installing " . $pkg->name_version; $msg .= " to get $because" if $because && $pkg->{name} ne $because; $msg .= " for $needed_by" if $needed_by; $msg .= " would downgrade " . join_with("and", map "$_->[0] from version $_->[1] to $_->[2]", @downgrade ); return $msg; } return ""; } sub package { my $self = shift; return ActivePerl::PPM::RepoPackage->new_dbi($self->dbh, @_); } sub package_set_abs_ppd_uri { my($self, @pkgs) = @_; my %repo_cache; for my $pkg (@pkgs) { if (defined(my $repo_id = $pkg->{repo_id})) { my($uri, $etag, $lastmod) = @{$repo_cache{$repo_id} ||= [$self->dbh->selectrow_array("SELECT packlist_uri, packlist_etag, packlist_lastmod FROM repo WHERE id = ?", undef, $repo_id)]}; if ($pkg->{ppd_uri}) { $pkg->{ppd_uri} = URI->new_abs($pkg->{ppd_uri}, $uri)->as_string; } else { $pkg->{ppd_uri} = $uri; $pkg->{ppd_etag} = $etag; $pkg->{ppd_lastmod} = $lastmod; } } } return @pkgs; } sub _topo_sort { my %pkgs = map { $_->{name} => $_ } @_; my @res; _topo_visit($_, \%pkgs, \@res) for reverse @_; delete $_->{_topo_visited} for @_; return reverse @res; } sub _topo_visit { my($p, $pkgs, $res) = @_; return unless $p; return if $p->{_topo_visited}++; if (my $needed_by = $p->{_needed_by}) { for my $dep (@$needed_by) { _topo_visit($pkgs->{$dep}, $pkgs, $res); } } push(@$res, $p); } sub install { my($self, %args) = @_; my $area = delete $args{area} || $self->default_install_area || die "No area"; $area = $self->area($area) unless ref($area); die "Can't install into read-only area" if $area->readonly; my @pkgs = @{delete $args{packages} || []}; die "No packages to install" unless @pkgs; my $ua = web_ua(); my $status = ppm_status(); my $tmpdir = do { require File::Temp; File::Temp::tempdir("ppm-XXXXXX", TMPDIR => 1) }; my $install_summary; eval { $self->package_set_abs_ppd_uri(@pkgs); # determine codebase_file for my $pkg (@pkgs) { my $name = $pkg->name_version; my $codebase = $pkg->{codebase}; die "No codebase for $name" unless $codebase; $codebase = URI->new_abs($codebase, $pkg->{ppd_uri}); if ($codebase =~ /\.(tgz|zip)$/) { $pkg->{codebase_type} = $1; } elsif ($codebase =~ /\.tar\.gz$/) { $pkg->{codebase_type} = "tgz"; } die "Don't know how to unpack $codebase" unless $pkg->{codebase_type}; if ($codebase->scheme eq 'file') { $pkg->{codebase_file} = $codebase->file; unless (-f $pkg->{codebase_file}) { die "No file _at $pkg->{codebase_file}"; } } else { local $ua->{progress_what} = "Downloading $name"; my $save = $pkg->{codebase_file} = "$tmpdir/$name.$pkg->{codebase_type}"; #print "\n $codebase ==> $save..."; my $res = $ua->get($codebase, ":content_file" => $save); die $res->status_line unless $res->is_success; if (my $len = $res->content_length) { my $save_len = -s $save; if ($save_len != $len) { die "Aborted download ($len bytes expected, got $save_len).\n"; } } # XXX An MD5 checksum for the tarball would be a good thing } } # unpack for my $pkg (@pkgs) { my $pname = $pkg->name_version; $status->begin("Unpacking $pname"); my $codebase_file = $pkg->{codebase_file}; require ActiveState::ModInfo; my $extract_file = sub { my($fname, $extractor) = @_; return if $fname =~ m,/\.exists$,; # don't think these are needed return if $fname =~ m,^blib/html/(bin|site/lib)/,; # will always regenerate these return if $fname =~ m,^blib/man1/, && !$area->man1; return if $fname =~ m,^blib/man3/, && !$area->man3; return if is_abs_path($fname); my $to = "$tmpdir/$pname/$fname"; $extractor->($to) || die "Can't extract to $to"; if ($fname =~ /\.pm$/) { my $mod = $fname; if ($mod =~ s,^blib/(?:lib|arch)/,,) { $mod = ActiveState::ModInfo::fname2mod($mod); $mod .= "::" unless $mod =~ /::/; $pkg->{provide}{$mod} = ActiveState::ModInfo::parse_version($to) || 0; } } }; if ($pkg->{codebase_type} eq "tgz") { require Archive::Tar; my $tar = Archive::Tar->new($codebase_file, 1) || die "Can't extract files from $codebase_file"; for my $file ($tar->get_files) { next unless $file->is_file; # don't extract links and other crap my $fname = $file->full_path; $extract_file->($fname, sub {$tar->extract_file($fname, $_[0])}, ); } } elsif ($pkg->{codebase_type} eq "zip") { require Archive::Zip; my $zip = Archive::Zip->new($codebase_file) || die "Can't extract files from $codebase_file"; for my $file ($zip->members) { next if $file->isDirectory; $extract_file->($file->fileName, sub {$file->extractToFileNamed($_[0]) == Archive::Zip::AZ_OK()}, ); } } else { die "Don't know how to unpack $pkg->{codebase_type} files"; } # If the same package is attempted installed multiple times, # these might still be left after last attempt. delete $pkg->{blib}; delete $pkg->{files}; my $blib = "$tmpdir/$pname/blib"; $pkg->{blib} = $blib if -d $blib; $status->end; } # relocate if ($^O ne "MSWin32") { require ActiveState::RelocateTree; my $ppm_sponge = ActiveState::RelocateTree::spongedir('ppm'); my $prefix = do { require Config; $Config::Config{prefix} }; for my $pkg (@pkgs) { next unless $pkg->{blib}; $status->begin("Relocating " . $pkg->name_version); ActiveState::RelocateTree::relocate ( to => $pkg->{blib}, inplace => 1, search => $ppm_sponge, replace => $prefix, quiet => 1, ); $status->end; } } # generate HTML from the POD if (eval { require ActivePerl::DocTools; }) { require Cwd; my $pwd = Cwd::cwd(); chdir($tmpdir) || die "Can't chdir $tmpdir: $!"; eval { for my $pkg (@pkgs) { next unless $pkg->{blib}; my $pname = $pkg->name_version; next unless -d $pname; $status->begin("Generating HTML for $pname"); ActivePerl::DocTools::UpdateHTML_blib(verbose => 0, blib => "$pname/blib"); $status->end; } }; chdir($pwd) || die "Can't chdir back to $pwd: $!"; die $@ if $@; } # install my $in_area = $area->name; $in_area = " in $in_area area" if $in_area; $status->begin("Updating files$in_area"); $install_summary = $area->install(packages => \@pkgs, force => $args{force}); if ($install_summary) { $status->end; } else { my $err = $@; $status->end("failed"); die $err || "Install failed for unknown reason"; } # run install scripts for my $pkg (_topo_sort(@pkgs)) { my $pname = $pkg->name_version; $pkg->run_script("install", $area, "$tmpdir/$pname", $install_summary->{pkg}{$pkg->{name}}, $args{run_cb}, ); } update_html_toc(); }; my $err = $@; require File::Path; File::Path::rmtree($tmpdir, 0); die $err if $err; return $install_summary; } 1; __END__ =head1 NAME ActivePerl::PPM::Client - Client class =head1 SYNOPSIS my $ppm = ActivePerl::PPM::Client->new; =head1 DESCRIPTION The C object ties together a set of install areas and repositories and allow the installed packages to be managed. The install areas are deducted from the values of C<@INC> when the object is constructed. The following methods are provided: =over =item $client = ActivePerl::PPM::Client->new =item $client = ActivePerl::PPM::Client->new( $home_dir ) The constructor creates a new client based on the configuration found in $home_dir which defaults to F<$ENV{HOME}/.ActivePerl> directory of the current user. If no such directory is found it is created. =item $client->arch A string that identifies the architecture for the current perl. This must match the ARCHITECTURE/NAME attribute of PPDs for them to match. =item $client->area( $name ) Returns an object representing the given named install area. The method will croak if no install area with the given $name is known. The C and C areas will always be available. See L for methods available on the returned object. =item $client->areas Return list of available install area names. The list is ordered to match the corresponding entries in C<@INC>. =item $client->default_install_area Return the name of the area where installations should normally go. Might return C if there is no appropriate default. =item $value = $client->config_get( $key ) =item ($value1, $value2, ...) = $client->config_get( $key1, $key2, ...) Read back one or more configuration values previosly saved. =item ($key, $value, ...) = $client->config_list =item ($key, $value, ...) = $client->config_list( $glob_pattern ) Return all key/value pairs where $key match the given $glob_pattern. If $glob_pattern is missing return all key/value pairs. =item $client->config_save( $key => $value ) =item $client->config_save( %pairs ) Will persistently store the given key/value pairs. The values can be extracted again with $client->config_get(). =item $client->repo( $repo_id ) Returns a reference to a hash describing the repo with the given identifier. The interesting fields of this hash are: =over =item name The full (user friendly) name of the repository. Can be modified by $repo->repo_set_name(). =item enabled A boolean that indicated if the repo is enabled or not. Can be modified by $repo->repo_enable(). =item pkgs The number of packages provided by this repository. =item packlist_uri The URI that the PPM client will monitor for changes to the repository. This URI can denote a F, F file or an HTML document with links to PPD files (typically a server generated directory listing). The URI can use any scheme that LWP supports and can embed a username and password for HTTP using this syntax: C. =item packlist_last_status The HTTP status code reported last time the PPM client tried to access C document. =item packlist_last_access When did we last try to to access the C document. The value is seconds from epoch as for perl's time() function. =item packlist_fresh_until When do we need to refetch the C document. The value is seconds from epoch as for perl's time() function. =back =item $client->repos Returns list of available repo identifiers. =item $client->repo_add( name => $name, packlist_uri => $uri ) Will add a new repository with the given attributes. The method will croak if a repository with the same C already exists. The return value is the $repo_id of the new repository. =item $client->repo_delete( $repo_id ) Will make the client forget about the given repository. =item $client->repo_enable( $repo_id ) =item $client->repo_enable( $repo_id, $bool ) Makes it possible to enable and disable the given reposiory. If $bool is provided and is FALSE, then the repository is disabled. The return value is TRUE if the given repository was enabled. =item $client->repo_set_name( $repo_id, $name ) Will update the name by which the given repo is known. =item $client->repo_set_packlist_uri( $repo_id, $uri ) Will update the address of the packlist to monitor for the given repository. Will croak if the $uri is already used by some other repo. Updating the URI will loose all cached information about the repo. A new 'repo_sync' is needed to update this information. =item $client->repo_sync( %args ) Will sync the local cache of packages from the enabled repositories. Remote repositories are not contacted if the cache is not considered stale yet. The following options are recognized: =over =item force => $bool If TRUE force state to be transfered again from remote repositories. Make requests unconditional. =item validate => $bool If TRUE validate state from remote repositories even if state still believed to be fresh. Will still send conditional requests. =item max_ppd => $num If repository is an HTML document set limit for how many PPD links it might contain. The default is 100. =item repo => $repo_id Pass C with an identifier to only sync the given repo. =back =item $client->search( $pattern ) =item $client->search( $pattern, $field,... ) Will search for packages matching the given glob style $pattern. Without further arguments this will return a list of package names. With $field arguments it will return a list of array references, each one filled in with the corresponding values for maching packages. =item $client->search_lookup( $num ) Will look up the given package from the last search() result, where $num matches the 1-based index into the list returned by the last search. This will return an L object. =item $client->packages =item $client->packages( $field,... ) Without arguments returns the ids of packages available. In scalar context returns the number of packages. With arguments return a list of array references each one representing one package. The elements of each array are the fields requested. See L for what field names are available. =item $client->package( $id ) =item $client->package( $name ) =item $client->package( $name, $version ) Returns the L object matching the arguments or C if none match. As there can be multiple packages with the same name, an arbitrary one is selected if $name but no $version is given. =item $client->feature_best( $feature ) Returns the highest version number provided for the given feature by the packages found in all enabled repositories. The method return C if no package provide this feature. =item $client->package_best( $feature, $version ) Returns the best package of all enabled repositories that provide the given feature at or better than the given version. =item $client->feature_have( $feature ) =item $client->feature_have( $feature, @areas ) Returns the installed version number of the given feature. Returns C if none of the installed packages provide this feature. If one or more @areas are provided, only look in the areas given by these names. =item $client->packages_depending_on( $pkg, $area ) Returns the packages (as C objects) that would "break" if the given package was uninstalled. This means that the returned packages are those that depend on features that the given package provide. In scalar context return number of packages. The $pkg argument can be either a package name or a package object. =item $client->packages_missing( %args ) Returns the list of packages to install in order to obtain the requested features. The returned list consist of L objects. The attribute C<_wanted> will be TRUE if a package was requested directly. The attribute C<_needed_by> will be an array reference of package names listing packages having resolved dependencies on this package. These attributes do not exclude each other. The returned list will be empty if all the requested features are already installed. The method will croak if nothing provides the requested features, if dependencies can't be resolved or if the packages selected have conflicting dependencies. The arguments to the function are passed as key/value pairs: =over =item want => \@features This is the list of features to resolve. The elements can be plain strings denoting feature names, or references to arrays containing a $name, $version pair. If $version is provided as C then this is taken as an upgrade request and the function will try to find the packages that provide the best possible version of this feature. =item have => \@pkgs List of packages you already have decided to install. The function will check if any of these packages provide needed features before looking anywhere else. =item want_deps => \@pkgs Resolve any dependencies for the given packages. =item area => \@areas List of names of install areas to consider when determining if requested features or dependencies are already installed or not. =item force => $bool If TRUE then return packages that provide the given features even if they are already installed. Will also disable check for downgrades. =item follow_deps => $str In what way should packages dependencies be resolved. The provided $str can take the values C, C, or C. The default is C. If $str is C then dependent packages are returned even if they are already installed. If $str is C then only missing dependencies are returned. If $str is C then dependencies are ignored. =item error_handler => \&callback Call the given error handler instead of croaking in the case of trouble. Error messages are provided as argument. There can be more than one. Providing an error_handler allow the function to return missing packages for working dependencies even if not all dependencies worked out. =back =item $client->install( %args ) Will download, unpack and install the given packages. The function will raise an exception of it gets into trouble, otherwise it will return The arguments to the function are passed as key/value pairs: =over =item packages => \@pkgs Mandatory argument that provide the packages to install. The array passed should contain C objects. =item area => $area What install area to install into. If not provided, then $client->default_install_area is used. =item run_cb => \&func A callback function that should behave like &ActivePerl::Run::run which will be called to execute the commands of the post install script. If not provided, then &ActivePerl::Run::run will be used. =back =back =head1 BUGS none.