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") =~ /<REPOSITORY(?:SUMMARY)?\b/) {
			    $repo->{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 =~ /<REPOSITORY(?:SUMMARY)?\b/) {
		    my $status = ppm_status();
		    $status->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<ActivePerl::PPM::Client> 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<perl> and C<site> areas will always be available.  See
L<ActivePerl::PPM::InstallArea> 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<undef> 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<packlist.xml>, F<packlist.lst>
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<http://user:pass@ppm.example.com/>.

=item packlist_last_status

The HTTP status code reported last time the PPM client tried to access
C<packlist_uri> document.

=item packlist_last_access

When did we last try to to access the C<packlist_uri> 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<packlist_uri> 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<packlist_uri> 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<repo> 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<ActivePerl::PPM::RepoPackage> 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<ActivePerl::PPM::RepoPackage> for what field names are
available.

=item $client->package( $id )

=item $client->package( $name )

=item $client->package( $name, $version )

Returns the L<ActivePerl::PPM::RepoPackage> object matching the
arguments or C<undef> 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<undef> 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<undef> 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<ActivePerl::PPM::Package> 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<ActivePerl::PPM::RepoPackage> 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<undef> 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<all>, C<missing>, or C<none>.  The default
is C<missing>.  If $str is C<all> then dependent packages are returned
even if they are already installed.  If $str is C<missing> then only
missing dependencies are returned.  If $str is C<none> 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<ActivePerl::PPM::Package> 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.