package ActivePerl::PPM::Package; use strict; use Carp qw(croak); use ActiveState::Version qw(vcmp); use ActivePerl::PPM::Logger qw(ppm_status); sub BASE_FIELDS { return ( [id => "integer primary key"], [name => "text not null"], [version => "text"], [release_date => "datetime"], [author => "text"], [abstract => "text"], [ppd_uri => "text"], [ppd_etag => "text"], [ppd_lastmod => "text"], [codebase => "text"], ); } # # constructors # sub new { my $class = shift; my $self = bless +(@_ == 1 ? shift : do{ my %hash = @_; \%hash }), $class; croak("No name given for package") unless $self->{name}; $self->{provide}{$self->{name}} ||= 0; # always provide ourself $self; } sub clone { my $self = shift; require Storable; my $other = Storable::dclone($self); delete $other->{id}; return $other; } # # accessors # sub AUTOLOAD { our $AUTOLOAD; my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); return if $method eq "DESTROY"; my $self = shift; unless (grep $_->[0] eq $method, $self->BASE_FIELDS) { croak(qq(Can't locate object method "$method" via package ) . (ref($self) || $self)); } my $old = $self->{$method}; if (@_) { $self->{$method} = shift; } return $old; } sub name_version { my $self = shift; my $tmp = $self->{name}; if (my $v = $self->{version}) { $tmp .= "-$v"; } return $tmp; } sub provides { my $self = shift; return %{$self->{provide}}; } sub requires { my $self = shift; return %{$self->{require} || {}}; } sub features_declared { my $self = shift; my $p = $self->{provide}; return keys(%$p) > 1 || $p->{$self->{name}}; } # # comparators # sub compare { my($a, $b) = @_; my $c = undef; if ($a->features_declared && $b->features_declared) { # compare the shared features to see if we have a winner for my $mod (keys %{$a->{provide}}) { next unless exists $b->{provide}{$mod}; my $c2 = $a->{provide}{$mod} <=> $b->{provide}{$mod}; $c = 0 unless defined $c; next if $c2 == 0; if ($c) { return undef unless $c == $c2; # conflict } else { $c = $c2; } } if (defined($c) && $c == 0) { # if the shared features compared the same, break the tie # by selecting the package with more features. $c = (keys %{$a->{provide}} <=> keys %{$b->{provide}}); } } # last resort is heuristic comparison of version labels $c ||= vcmp($a->{version}, $b->{version}); return $c; } sub better_than { my($self, $other) = @_; my $c = compare($self, $other); unless (defined($c)) { croak("No ordering between package " . $self->name_version . " and " . $other->name_version); } return $c > 0; } sub best { my $best = shift; my @dunno; for my $p (@_) { my $c = compare($best, $p); if (defined $c) { $best = $p if $c < 0; } else { push(@dunno, $p); } } die "Can't determine best" if @dunno; # XXX can we do better return $best; } # # SQL storage # sub sql_create_tables { my($class, %opt) = @_; my @fields = $class->BASE_FIELDS; if ($opt{name_unique}) { my($name) = grep $_->[0] eq "name", @fields; $name->[1] .= " unique"; } return "CREATE TABLE IF NOT EXISTS package (\n " . join(",\n ", map join(" ", @$_), @fields) . " )", "CREATE TABLE IF NOT EXISTS feature ( package_id integer not null, role char(1) not null, /* 'p' or 'r' */ name text not null, version double not null )", "CREATE TABLE IF NOT EXISTS script ( package_id integer not null, role text not null, /* 'install' or 'uninstall' */ exec text, /* interpreter */ uri text, text text )", } my %ROLE = ( 'p' => 'provide', 'r' => 'require', ); sub new_dbi { my($class, $dbh, $id_or_name, $version) = @_; my @bind = ($id_or_name); my $where; if ($id_or_name =~ /^\d+$/) { $where = "id = ?" } else { $where = "name = ? AND "; if (defined $version) { $where .= "version = ?"; push(@bind, $version); } else { $where .= "version ISNULL"; } } my $pkg = $dbh->selectrow_hashref("SELECT * FROM package WHERE $where", undef, @bind); return undef unless $pkg; # fix up potential Unicode fields for my $f (qw(author abstract)) { if (($pkg->{$f} || "") =~ /[^\x00-\x7F]/) { utf8::decode($pkg->{$f}); } } if (1) { my $sth = $dbh->prepare("SELECT role, name, version FROM feature WHERE package_id = ?"); $sth->execute($pkg->{id}); while (my($role, $feature, $version) = $sth->fetchrow_array) { $pkg->{$ROLE{$role}}{$feature} = $version; } } if (1) { my $sth = $dbh->prepare("SELECT role, exec, uri, text FROM script WHERE package_id = ?"); $sth->execute($pkg->{id}); while (my($role, $exec, $uri, $text) = $sth->fetchrow_array) { $pkg->{script}{$role}{exec} = $exec if defined($exec); $pkg->{script}{$role}{uri} = $uri if defined($uri); $pkg->{script}{$role}{text} = $text if defined($text); } } return $class->new($pkg); } sub dbi_store { my($self, $dbh) = @_; my $id = $self->{id}; my @fields = map $_->[0], $self->BASE_FIELDS; shift(@fields); # get rid of id if (defined $id) { $dbh->do("UPDATE package SET " . join(", ", map "$_ = ?", @fields) . " WHERE id = ?", undef, @{$self}{@fields}, $id); $dbh->do("DELETE FROM feature WHERE package_id = ?", undef, $id); $dbh->do("DELETE FROM script WHERE package_id = ?", undef, $id); } else { $dbh->do("INSERT INTO package (" . join(", ", @fields) . ") VALUES(" . join(", ", map "?", @fields) . ")", undef, @{$self}{@fields}) || return undef; $id = $dbh->func('last_insert_rowid'); } for my $role (values %ROLE) { my $hash = $self->{$role} || next; while (my($feature, $version) = each %$hash) { $dbh->do("INSERT INTO feature (package_id, role, name, version) VALUES(?, ?, ?, ?)", undef, $id, substr($role, 0, 1), $feature, $version) } } if (my $script = $self->{script}) { for my $role (sort keys %$script) { local $dbh->{PrintError} = 1; my $v = $script->{$role}; $dbh->do("INSERT INTO script (package_id, role, exec, uri, text) VALUES(?, ?, ?, ?, ?)", undef, $id, $role, $v->{exec}, $v->{uri}, $v->{text}); } } return $id; } # # Script support # sub has_script { my($self, $kind) = @_; return !!$self->{script}{$kind}; } sub run_script { my($self, $kind, $area, $tmpdir, $pkg_info, $run_cb) = @_; my $script = $self->{script}{$kind}; return unless $script; $tmpdir ||= do { require File::Temp; File::Temp::tempdir("ppm-XXXXXX", TMPDIR => 1, CLEANUP => 1) }; my @commands; if (defined(my $uri = $script->{uri})) { require ActivePerl::PPM::Web; my $ua = ActivePerl::PPM::Web::web_ua(); local $ua->{progress_what} = "Downloading " . $self->name_version . " $kind script"; my $res = $ua->get(URI->new_abs($uri, $self->{ppd_uri})); die $res->status_line unless $res->is_success; if (my $len = $res->content_length) { my $save_len = length($res->content); if ($save_len != $len) { die "Aborted download ($len bytes expected, got $save_len).\n"; } } if ($script->{exec}) { my $file = "$tmpdir/${kind}_script"; open(my $fh, ">:utf8", $file) || die "Can't create $file: $!"; print $fh $res->decoded_content; close($fh) || die "Can't write $file: $!"; chmod(0755, $file); push(@commands, _expand_exec($script->{exec}, "${kind}_script")); } else { push(@commands, grep length, split(/\n/, $res->decoded_content)); } } else { if (my $exec = $script->{exec}) { my $text = $script->{text}; $text =~ s/;;/\n/g; # what ugliness my $file = "$tmpdir/${kind}_script"; open(my $fh, ">", $file) || die "Can't create $file: $!"; print $fh $text; close($fh) || die "Can't write $file: $!"; chmod(0755, $file); push(@commands, _expand_exec($script->{exec}, "${kind}_script")); } else { push(@commands, grep length, split(/;;/, $script->{text})); } } if (@commands) { require Cwd; my $old_cwd = Cwd::cwd(); local $ENV{PPM_INSTROOT} = $area->prefix; local $ENV{PPM_INSTLIB} = $area->lib; local $ENV{PPM_INSTARCHLIB} = $area->archlib; local $ENV{PPM_VERSION} = do { require ActivePerl::PPM; $ActivePerl::PPM::VERSION }; local $ENV{PPM_ACTION} = $kind; local $ENV{PPM_NEW_VERSION} = $pkg_info->{new_version} if exists $pkg_info->{new_version}; local $ENV{PPM_PREV_VERSION}; if (exists $pkg_info->{old_version}) { $ENV{PPM_ACTION} = "upgrade" if $ENV{PPM_ACTION} eq "install"; $ENV{PPM_PREV_VERSION} = $pkg_info->{old_version}; } local $ENV{PPM_INSTPACKLIST} = $pkg_info->{packlist} if exists $pkg_info->{packlist};; local $ENV{PPM_PERL} = $^X; $run_cb ||= do { require ActiveState::Run; \&ActiveState::Run::run; }; eval { chdir $tmpdir; ppm_status("begin", "Running " . $self->name_version . " $kind script"); for my $cmd (@commands) { &$run_cb(ref($cmd) ? @$cmd : $cmd); } ppm_status("end"); }; chdir($old_cwd) || die "Can't chdir back to '$old_cwd': $!"; die if $@; } } sub _expand_exec { my $exec = shift; my @args; if ($exec =~ /\W/) { require Text::ParseWords; ($exec, @args) = Text::ParseWords::shellwords($exec); } if (uc($exec) eq "SELF") { $exec = shift; $exec = "./$exec" if $^O ne "MSWin32"; } elsif (uc($exec) eq "PPM_PERL" || $exec eq "perl") { $exec = $^X; } $exec = '@' . $exec; # silence command echo return [$exec, @args, @_]; } 1; __END__ =head1 NAME ActivePerl::PPM::Package - Package class =head1 SYNOPSIS my $pkg = ActivePerl::PPM::Package->new(name => 'Foo',...); # or my $pkg = ActivePerl::PPM::Package->new(\%hash); =head1 DESCRIPTION The C class wraps hashes that describes packages; the unit that the PPM system manages. =head2 Constructors The following constructor methods are provided: =over =item $pkg = ActivePerl::PPM::Package->new( %opt ); =item $pkg = ActivePerl::PPM::Package->new( \%self ); The constructor either take key/value pairs or a hash reference as argument. The only mandatory field is C. If a hash reference is passed then it is turned into an C object and returned; which basically pass ownership of the hash. =item $copy = $pkg->clone Returns a copy of the current package object. The attributes of the clone can be modified without changing the original. =item ActivePerl::PPM::Package->new_dbi($dbh, $id); =item ActivePerl::PPM::Package->new_dbi($dbh, $name, $version); Read object from a database and return it. Returns C if no package with the given key is found. =item $pkg->dbi_store( $dbh ) Writes the current package to a database. If $pkg was constructed by C then this updates the package, otherwise this creates a new package object in the database. Returns the $id of the object stored if successful, otherwise C. =back =head2 Attributes The attributes of a package can be accessed directly using hash syntax or by accesor methods. The most common attributes are described below, but the set of attributes is extensible. =over =item $str = $pkg->id Returns the database id of package. This attribute is set if the object exists in a database. =item $str = $pkg->name Returns the name of the package. =item $str = $pkg->version Returns the version identifier for the package. This string can be anything and there is no reliable way to order packages based on these version strings. =item $str = $pkg->name_version Returns the name and version concatenated together. This form might be handy for display, but there is no reliable way to parse back what is the name and what is the version identifier. =item $str = $pkg->release_date Returns the date the package was released on as an ISO 8601 date (YYYY-MM-DDThh:mm:ss). For CPAN packages this is the date the package was uploaded to CPAN. =item $str = $pkg->author The name and email address of the current maintainer of the package. =item $str = $pkg->abstract A short sentence describing the purpose of the package. =item $url = $pkg->ppd_uri This is the URI for the PPD file itself. =item $str = $pkg->ppd_etag This is the C that the server reported for the PPD last time. =item $str = $pkg->ppd_lastmod This is the C field that the server reported for the PPD last time. =item $url = $pkg->codebase Returns the URL to implementation; a blib tarball. Interpret this URL relative to I. =item %features = $pkg->provides Returns a list of (feature, version) pairs describing what features this package provide. A feature name with a double colon in it represent a perl module. A package always provide its own name as a feature. =item %features = $pkg->requires Returns a list of (feature, version) pairs describing what features this package require to be installed for it to work properly. A feature name with a double colon in it represent a perl module. =head2 Comparators The following functions/methods can be used to order packages. =item $pkg->compare( $other ) Returns -1, 0, 1 like perl's builtin C. Return C if no order is defined. =item $pkg->better_than( $other ) Returns TRUE if this package is better than the package passed as argument. This method will croak if no order is defined. =item $pkg->best( @others ) =item ActivePerl::PPM::Package::best( @pkgs ) Returns the best package. Might croak if no order is defined among the packages passed in. =back =head2 Misc methods =over =item ActivePerl::PPM::Package->sql_create_tables This returns SQL C statements used to initialize the database that the C and C methods depend on. =item $bool = $pkg->features_declared Returns TRUE if this package declare what features it provide. PPM4 style packages should declare what modules and other features they provide, but packages from older repositories might not. =item $pkg->has_script( $kind ) Return TRUE if the package has the given $kind of script attached. The $kind argument should be either "install" or "uninstall". =item $pkg->run_script( $kind, $area, $tmpdir, \%pkg_info ) Execute the given kind of script for the package. The $kind argument should be either "install" or "uninstall". The $kind and $area argument must be provided. =back =head1 BUGS none.