home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2006 December / PCpro_2006_12.ISO / ossdvd / server / Perl2 / site / lib / ppm / ui.pm < prev    next >
Encoding:
Perl POD Document  |  2002-10-23  |  36.8 KB  |  1,275 lines

  1. package PPM::UI;
  2.  
  3. use strict;
  4. use Data::Dumper;
  5. use PPM::Repository;
  6. use PPM::Installer;
  7. use PPM::Config;
  8. use PPM::Trace qw(trace);
  9. use PPM::Result qw(Ok Warning Error List);
  10.  
  11. $PPM::UI::VERSION = '3.00';
  12.  
  13. my $CONF;
  14. my $TARG;
  15. my $REPS;
  16.  
  17. #=============================================================================
  18. # Name indexes into arrays:
  19. #=============================================================================
  20. use constant PROP_PPD_OBJ => 0;
  21. use constant PROP_INSTDATE => 1;
  22. use constant PROP_REPOS => 2;
  23.  
  24. use constant QUERY_NAME => 0;
  25. use constant QUERY_VERSION => 1;
  26. use constant QUERY_ABSTRACT => 2;
  27. use constant QUERY_AUTHOR => 3;
  28.  
  29. use constant CONF_INFO_KEY => 0;
  30. use constant CONF_INFO_VAL => 1;
  31.  
  32. use constant CONF_KEYS_KEY => 0;
  33. use constant CONF_KEYS_RW => 1;
  34.  
  35. use constant REP_INFO_NAME => 0;
  36. use constant REP_INFO_LOC => 1;
  37. use constant REP_INFO_TYPE => 2;
  38.  
  39. #=============================================================================
  40. # Configuration Options
  41. #=============================================================================
  42.  
  43. my %config_keys;
  44. BEGIN {
  45.    %config_keys = (tempdir => 1,
  46.            downloadbytes => 1,
  47.            tracefile => 1,
  48.            tracelvl => 1,
  49.            profile  => 1,
  50.            profile_server => 0,
  51.            profile_enable => 1,
  52.           );
  53. }
  54.  
  55. sub config_keys {
  56.     trace(3, "PPM::UI::config_keys()\n");
  57.     List(map { [$_ => $config_keys{$_}] } keys %config_keys);
  58. }
  59.  
  60. sub config_info {
  61.     trace(3, "PPM::UI::config_info()\n");
  62.     List(map { [$_ => $CONF->{DATA}{$_}] } keys %config_keys);
  63. }
  64.  
  65. sub config_set {
  66.     my $key = shift;
  67.     my $val = shift;
  68.     trace(3, "PPM::UI::config_set($key, $val)\n");
  69.     return Error("no such config key '$key'")
  70.       unless exists $config_keys{$key};
  71.     return Error("read-only configuration key '$key'")
  72.       unless $config_keys{$key};
  73.     $CONF->{DATA}{$key} = $val;
  74.     $CONF->save;
  75.     return Ok();
  76. }
  77.  
  78. sub config_get {
  79.     my $key = shift;
  80.     trace(3, "PPM::UI::config_get($key)\n");
  81.     return Error("no such config key '$key'.")
  82.       unless exists $config_keys{$key};
  83.     return Ok($CONF->{DATA}{$key});
  84. }
  85.  
  86. #=============================================================================
  87. # Repositories
  88. #=============================================================================
  89.  
  90. sub repository_list {
  91.     trace(3, "PPM::UI::repository_list()\n");
  92.     return List(sort keys %{$REPS->{DATA}});
  93. }
  94.  
  95. sub repository_add {
  96.     my $name = shift;
  97.     my $location = shift;
  98.     my $username = shift;
  99.     my $password = shift;
  100.     trace(3, "PPM::UI::repository_add($name, $location, ", $username,
  101.       ", ", $password, ")\n");
  102.  
  103.     # Validate it:
  104.     my ($r, $er) = PPM::Repository->new($location, $name, $username, $password);
  105.     return Error($er)
  106.       unless $r;
  107.  
  108.     $REPS->{DATA}{$name}{url} = $location;
  109.     $REPS->{DATA}{$name}{username} = $username if defined $username;
  110.     $REPS->{DATA}{$name}{password} = $password if defined $password;
  111.     $REPS->save;
  112.     return Ok();
  113. }
  114.  
  115. sub repository_del {
  116.     my $name = shift;
  117.     trace(3, "PPM::UI::repository_del($name)\n");
  118.     return Error("Can't delete nonexistent repository '$name'.")
  119.       unless exists $REPS->{DATA}{$name};
  120.     delete $REPS->{DATA}{$name};
  121.     $REPS->save;
  122.     del_rep($name);
  123.     return Ok();
  124. }
  125.  
  126. sub repository_rename {
  127.     my $oldname = shift;
  128.     my $newname = shift;
  129.     trace(3, "PPM::UI::repository_rename($oldname, $newname)\n");
  130.     $REPS->{DATA}{$newname} = $REPS->{DATA}{$oldname}
  131.       if exists $REPS->{DATA}{$oldname};
  132.     repository_del($oldname);
  133. }
  134.  
  135. sub repository_info {
  136.     my $name = shift;
  137.     trace(3, "PPM::UI::repository_info($name)\n");
  138.     return Error("Can't describe nonexistent repository '$name'.")
  139.       unless exists $REPS->{DATA}{$name};
  140.     my $rep = get_rep($name);
  141.     if ($rep->ok) {
  142.     $rep = $rep->result;
  143.     return List(
  144.         $name,
  145.         $rep->location,
  146.         $rep->type_printable,
  147.         $rep->username,
  148.         $rep->password,
  149.     );
  150.     }
  151.     else {
  152.     return Warning($rep->msg_raw,
  153.                -1,
  154.                [$name,
  155.             $REPS->{DATA}{$name}{url},
  156.             'unsupported']);
  157.     }
  158. }
  159.  
  160. #=============================================================================
  161. # Operations on non-installed packages
  162. #=============================================================================
  163.  
  164. sub search {
  165.     my ($rlist, $rbad) = get_reps(shift);
  166.     unless (@$rlist) {
  167.     my $msg = "No valid repositories:\n";
  168.     $msg .= $_->msg for @$rbad;
  169.     return Error($msg);
  170.     }
  171.     my $target = get_targ(shift);
  172.     return $target unless $target->ok;
  173.     $target = $target->result;
  174.     my $query = shift;
  175.     my $case = shift;
  176.     my @results;
  177.     for my $r (@$rlist) {
  178.     my $l = $r->search($target, $query, $case);
  179.     next unless $l->ok;
  180.     push @results, map { get_pkg($_, $r) } $l->result_l;
  181.     }
  182.     return List(@results);
  183. }
  184.  
  185. sub describe {
  186.     my ($rlist, $rbad) = get_reps(shift);
  187.     unless (@$rlist) {
  188.     my $msg = "No valid repositories:\n";
  189.     $msg .= $_->msg for @$rbad;
  190.     return Error($msg);
  191.     }
  192.     my $target = get_targ(shift);
  193.     return $target unless $target->ok;
  194.     $target = $target->result;
  195.     my $pkg = get_pkg(shift, $rlist);
  196.     my $package = $pkg->name;
  197.     my $desc = $pkg->describe($target);
  198.     return $desc unless $desc->ok;
  199.     return Ok(get_pkg($desc->result, $rlist));
  200. }
  201.  
  202. sub install {
  203.     my ($rlist, $rbad) = get_reps(shift);
  204.     unless (@$rlist) {
  205.     my $msg = "No valid repositories:\n";
  206.     $msg .= $_->msg for @$rbad;
  207.     return Error($msg);
  208.     }
  209.     my $target = get_targ(shift);
  210.     return $target unless $target->ok;
  211.     $target = $target->result;
  212.     my $pkg = get_pkg(shift, $rlist);
  213.     my $opts = shift;
  214.     my $status_cb = shift;
  215.  
  216.     # Find the correct target for this package. This means matching the
  217.     # LANGUAGE tag in the PPD. Basically we find out what LANGUAGE the PPD
  218.     # represents, and we search through the targets looking for a subset which
  219.     # implement that language. If more than one target implements the language
  220.     # and version, we pick the first. If none work, we fail. If the LANGUAGE
  221.     # tag is missing, or the LANGUAGE matches the given target, we use the
  222.     # given target.
  223.     $target = $pkg->choose_target($target, target_list()->result_l);
  224.     return $target unless $target->ok;
  225.     $target = $target->result;
  226.     install_or_upgrade($rlist, $target, $pkg, $opts, $status_cb, 'install');
  227. }
  228.  
  229. #=============================================================================
  230. # Targets
  231. #=============================================================================
  232.  
  233. sub target_list {
  234.     trace(3, "PPM::UI::target_list()\n");
  235.     return List(sort keys %{$TARG->{DATA}});
  236. }
  237.  
  238. sub target_info {
  239.     my $target = shift;
  240.     trace(3, "PPM::UI::target_info($target)\n");
  241.     my $t = get_targ($target);
  242.     return $t unless $t->ok;
  243.     $t = $t->result;
  244.     my @keys = map { "\u$_" } $t->ckeys;
  245.     my @vals = $t->cvals;
  246.     my %hash;
  247.     @hash{@keys} = @vals;
  248.     return Ok(\%hash);
  249. }
  250. sub target_raw_info {
  251.     my $target = shift;
  252.     return Ok($TARG->{DATA}{$target});
  253. }
  254.  
  255. sub target_config_info {
  256.     my $target = get_targ(shift);
  257.     return $target unless $target->ok;
  258.     $target = $target->result;
  259.     trace(3, "PPM::UI::target_config_info(", $target->name, ")\n");
  260.     return $target->config_info;
  261. }
  262.  
  263. sub target_config_keys {
  264.     my $target = get_targ(shift);
  265.     return $target unless $target->ok;
  266.     $target = $target->result;
  267.     trace(3, "PPM::UI::target_config-keys(", $target->name, ")\n");
  268.     return $target->config_keys;
  269. }
  270.  
  271. sub target_config_get {
  272.     my $target = get_targ(shift);
  273.     return $target unless $target->ok;
  274.     $target = $target->result;
  275.     my $key = shift;
  276.     trace(3, "PPM::UI::target_config_get(", $target->name, ", $key)\n");
  277.     return $target->config_get($key);
  278. }
  279.  
  280. sub target_config_set {
  281.     my $target = get_targ(shift);
  282.     return $target unless $target->ok;
  283.     $target = $target->result;
  284.     my $key = shift;
  285.     my $value = shift;
  286.     trace(3, "PPM::UI::target_config_get(", $target->name, ", $key, $value)\n");
  287.     return $target->config_set($key, $value);
  288. }
  289.  
  290. sub target_rename {
  291.     my $oldname = shift;
  292.     my $newname = shift;
  293.  
  294.     # Make sure the target even exists:
  295.     my @targets = target_list()->result_l;
  296.     return Error("Can't rename nonexistent target '$oldname'.")
  297.       unless grep { $_ eq $oldname } @targets;
  298.  
  299.     # Load the targets file read/write:
  300.     {
  301.     my $t = PPM::Config::load_config_file('targets', 'rw');
  302.     $t->{DATA}{$newname} = $t->{DATA}{$oldname};
  303.     delete $t->{DATA}{$oldname};
  304.     }
  305.     $TARG = PPM::Config::load_config_file('targets', 'ro');
  306.  
  307.     # Return success if profile tracking is disabled.
  308.     return Ok() unless config_get('profile_enable')->result;
  309.  
  310.     # We must rename the target in all profiles:
  311.     my $res = profile_list();
  312.     unless ($res->is_success) {
  313.     return Error(
  314.         "failed to rename target in profiles: " . $res->msg_raw
  315.     ) unless $res->ok;
  316.     }
  317.     my @profiles = $res->result_l;
  318.  
  319.     my $repos = get_rep(config_get('profile_server')->result);
  320.     return $repos unless $repos->ok;
  321.     $repos = $repos->result;
  322.     for my $profile (@profiles) {
  323.     my $r = $repos->profile_target_rename($profile, $oldname, $newname);
  324.     return Error(
  325.         "failed to rename target in profiles: " . $r->msg_raw
  326.     ) unless $r->ok;
  327.     }
  328.  
  329.     Ok();
  330. }
  331.  
  332. sub target_fix_paths {
  333.     my $from = shift;
  334.     my $to   = shift;
  335.     my $i    = $^O eq 'MSWin32' ? '(?i)' : '';
  336.     {
  337.     my $t    = PPM::Config::load_config_file('targets', 'rw');
  338.     for my $targ (target_list()->result_l) {
  339.         for my $key (keys %{$t->{DATA}{$targ}}) {
  340.         $t->{DATA}{$targ}{$key} =~ s{$i\Q$from\E}{$to};
  341.         }
  342.     }
  343.     }
  344.     $TARG = PPM::Config::load_config_file('targets', 'ro');
  345. }
  346.  
  347. sub target_add {
  348.     my $name = shift;
  349.     my %opts = @_;
  350.  
  351.     # Handle loading a file:
  352.     if (not defined $name and -f $opts{From}) {
  353.     my $t = PPM::Config->new;
  354.     $t->loadfile($opts{From});
  355.     # There's only ever 1 target in that config file:
  356.     ($name) = keys %{$t->{DATA}};
  357.     %opts = %{$t->{DATA}{$name}};
  358.     }
  359.     return Error("can't add existing target '$name'")
  360.     if exists $TARG->{DATA}{$name};
  361.  
  362.     # Find an unused Port:
  363.     require PPM::Compat;
  364.     $opts{port} = PPM::Compat::PPM_PORT_PERL();
  365.     ++$opts{port} while (
  366.     grep { $opts{port} eq $TARG->{DATA}{$_}{port} }
  367.     keys %{$TARG->{DATA}}
  368.     );
  369.  
  370.     # Save the file:
  371.     {
  372.     my $t = PPM::Config::load_config_file('targets', 'rw');
  373.     $t->{DATA}{$name} = \%opts;
  374.     }
  375.     $TARG = PPM::Config::load_config_file('targets', 'ro');
  376.     return Ok();
  377. }
  378.  
  379. sub target_del {
  380.     my $name = shift;
  381.     return Error("can't delete nonexistent target '$name'")
  382.     unless exists $TARG->{DATA}{$name};
  383.     {
  384.     my $t = PPM::Config::load_config_file('targets', 'rw');
  385.     delete $t->{DATA}{$name};
  386.     }
  387.     $TARG = PPM::Config::load_config_file('targets', 'ro');
  388.     return Ok();
  389. }
  390.  
  391. #=============================================================================
  392. # Operations on installed packages
  393. #=============================================================================
  394.  
  395. sub query {
  396.     my $target = get_targ(shift);
  397.     return $target unless $target->ok;
  398.     $target = $target->result;
  399.     my $query = shift;
  400.     my $case = shift;
  401.     trace(3, "PPM::UI::query(", $target->name, ", '$query', $case)\n");
  402.     my @results = map { get_pkg($_) }
  403.           $target->query($query, $case)->result_l;
  404.     List(@results);
  405. }
  406.  
  407. sub properties {
  408.     my $target = get_targ(shift);
  409.     return $target unless $target->ok;
  410.     $target = $target->result;
  411.     my $pkg = get_pkg(shift, undef); # don't care about repository.
  412.     trace(3, "PPM::UI::properties(", $target->name, ", ", $pkg->name, ")\n");
  413.     my $res = $target->properties($pkg->name);
  414.     return $res unless $res->ok;
  415.     my @res = $res->result_l;
  416.     $res[0] = get_pkg($res[0]);
  417.     return List(@res);
  418. }
  419.  
  420. sub remove {
  421.     my $target = get_targ(shift);
  422.     return $target unless $target->ok;
  423.     $target = $target->result;
  424.     my $pkg = get_pkg(shift, undef); # don't care about repository.
  425.     my $package = $pkg->name;
  426.     my $force = shift;  # normally, if removing a package would break a
  427.             # dependency of another installed package, we refuse.
  428.             # But if the user really wants to...
  429.     my $cb_remove = shift;
  430.     my $verbose = shift;
  431.  
  432.     trace(3, "PPM::UI::remove(", $target->name, ", $package)\n");
  433.     if (grep { $pkg->name eq $_ } $target->precious->result_l) {
  434.     return Error("package '$package' is required by the target.");
  435.     }
  436.     my $prop = $target->properties($package);
  437.     return $prop unless $prop->ok;
  438.  
  439.     my $ok = $target->dependents($package);
  440.     return $ok unless $ok->ok;
  441.  
  442.     my @deps = $ok->result_l;
  443.     if (@deps and not $force) {
  444.     my $msg = "removing '$package' would break these dependencies:\n";
  445.     $msg .= "\t$package is needed by $_.\n" for @deps;
  446.     return Error($msg);
  447.     }
  448.  
  449.     my $version = ($prop->result_l)[PROP_PPD_OBJ]->version;
  450.     $cb_remove->($package, $version, $target->name, "PRE-REMOVE");
  451.     my $ret = $target->remove($package, $verbose);
  452.     return $ret unless $ret->ok;
  453.     $cb_remove->($package, $version, $target->name, "COMPLETE");
  454.     my $track = config_get('profile_enable')->result;
  455.     if ($track and $ret->ok) {
  456.     my $repos = get_rep(config_get('profile_server')->result);
  457.     return $repos unless $repos->ok;
  458.     $repos = $repos->result;
  459.     my $rep = ($prop->result_l)[PROP_REPOS];
  460.     my $ver = ($prop->result_l)[PROP_PPD_OBJ]->version_osd;
  461.     my $entry = [$rep,
  462.              $target->config_get('TARGET_TYPE')->result,
  463.              $target->name,
  464.              $package,
  465.              $ver
  466.             ];
  467.     my $profile = config_get('profile')->result;
  468.     $repos->removed($profile, $entry);
  469.     }
  470.     $ret;
  471. }
  472.  
  473. sub verify {
  474.     my ($rlist, $rbad) = get_reps(shift);
  475.     unless (@$rlist) {
  476.     my $msg = "No valid repositories:\n";
  477.     $msg .= $_->msg for @$rbad;
  478.     return Error($msg);
  479.     }
  480.     my $target = get_targ(shift);
  481.     return $target unless $target->ok;
  482.     $target = $target->result;
  483.     my $pkg = get_pkg(shift, $rlist);
  484.     my $package = $pkg->name;
  485.     trace(3, "PPM::UI::verify(", $target->name, ", $package)\n");
  486.  
  487.     # To do: 
  488.     # 1. Check if the package is installed; return false otherwise.
  489.     my $prop = $target->properties($package);
  490.     return $prop unless $prop->ok;
  491.     my @prop = $prop->result_l;
  492.  
  493.     my $bundled  = grep { $prop[PROP_PPD_OBJ]->name eq $_ }
  494.                 $target->bundled->result_l;
  495.     my $precious = grep { $prop[PROP_PPD_OBJ]->name eq $_ }
  496.                 $target->precious->result_l;
  497.  
  498.     # 2. Get the installed version of the package.
  499.     my $ver = $prop[PROP_PPD_OBJ]->version_osd;
  500.     my $ver_p = $prop[PROP_PPD_OBJ]->version;
  501.  
  502.     # 3. Send the installed version to the Repository for checking.
  503.     # I used to only upgrade from the place it came from. Now it will come
  504.     # from the current repository.
  505.     my $res = $pkg->uptodate($target);
  506.     unless ($res->ok) {
  507.     return Error("bundled package - no upgrade available")
  508.       if $bundled;
  509.     return $res;
  510.     }
  511.     my ($uptodate, $newversion) = $res->result_l;
  512.  
  513.     # 4. Return uptodate(t/f), newversion, oldversion, bundled(t/f):
  514.     return List($uptodate, $bundled, $precious, $newversion, $ver_p);
  515. }
  516.  
  517. sub verify_pkgs {
  518.     my ($rlist, $rbad) = get_reps(shift);
  519.     unless (@$rlist) {
  520.     my $msg = "No valid repositories:\n";
  521.     $msg .= $_->msg for @$rbad;
  522.     return Error($msg);
  523.     }
  524.     my $target = get_targ(shift);
  525.     return $target unless $target->ok;
  526.     $target = $target->result;
  527.     my @pkgs = @_;
  528.  
  529.     # Get the versions of the packages
  530.     my (@ppds, @b, @p);
  531.     my @version = map {
  532.     my $pkg = $_;
  533.     my $inst = properties($target, $pkg);
  534.     return $inst unless $inst->ok;
  535.     my @prop = $inst->result_l;
  536.     my $ppd = $prop[PROP_PPD_OBJ]->getppd_obj($target)->result;
  537.     push @ppds, $ppd;
  538.     my $bundled  = grep { $prop[PROP_PPD_OBJ]->name eq $_ }
  539.                 $target->bundled->result_l;
  540.     push @b, $bundled;
  541.     my $precious = grep { $prop[PROP_PPD_OBJ]->name eq $_ }
  542.                 $target->precious->result_l;
  543.     push @p, $precious;
  544.     $ppd->version_osd;
  545.     } @pkgs;
  546.  
  547.     # Query the package in each repository
  548.     my @ans;
  549.     for my $rep (@$rlist) {
  550.     my @batch;
  551.     for my $i (0 .. $#pkgs) {
  552.         my $pkg = get_pkg($pkgs[$i], [$rep]);
  553.         push @batch, ['uptodate2', $pkg->{id}, $version[$i]];
  554.     }
  555.     my $resp = $rep->batch($target, @batch);
  556.     return $resp unless $resp->ok;
  557.     my @ret = $resp->result_l;
  558.     for my $i (0 .. $#pkgs) {
  559.         next unless $ret[$i]->is_success;
  560.         my $val = $ret[$i]->result;
  561.         push @$val, $ppds[$i], $b[$i], $p[$i];
  562.     }
  563.     push @ans, @ret;
  564.     #push @ans, [$resp->result_l];
  565.     }
  566.     List(@ans);
  567. }
  568.  
  569. sub upgrade {
  570.     my ($rlist, $rbad) = get_reps(shift);
  571.     unless (@$rlist) {
  572.     my $msg = "No valid repositories:\n";
  573.     $msg .= $_->msg for @$rbad;
  574.     return Error($msg);
  575.     }
  576.     my $target = get_targ(shift);
  577.     return $target unless $target->ok;
  578.     $target = $target->result;
  579.     my $pkg = get_pkg(shift, $rlist);
  580.     my $package = $pkg->name;
  581.     my $opts = shift;
  582.     my $status_cb = shift;
  583.  
  584.     trace(3, "PPM::UI::upgrade(", $target->name,
  585.       ", $package, $opts->{force}, $opts->{follow}, $opts->{dryrun})\n");
  586.  
  587.     install_or_upgrade($rlist, $target, $pkg, $opts, $status_cb, 'upgrade');
  588. }
  589.  
  590. #=============================================================================
  591. # Operations which require you to have logged in
  592. #=============================================================================
  593.  
  594. sub profile_set {
  595.     my $profile = shift;
  596.     trace(3, "PPM::UI::profile_set($profile)\n");
  597.     config_set('profile', $profile);
  598.     Ok();
  599. }
  600.  
  601. sub profile_get {
  602.     trace(3, "PPM::UI::profile_get()\n");
  603.     config_get('profile');
  604. }
  605.  
  606. sub profile_list {
  607.     trace(3, "PPM::UI::profile_list()\n");
  608.     my $p_rep = config_get('profile_server')->result;
  609.     my $rep = get_rep($p_rep);
  610.     return $rep unless $rep->ok;
  611.     $rep = $rep->result;
  612.     $rep->profile_list;
  613. }
  614.  
  615. sub profile_add {
  616.     my $profile = shift;
  617.     trace(3, "PPM::UI::profile_add($profile)\n");
  618.     my $p_rep = config_get('profile_server')->result;
  619.     my $rep = get_rep($p_rep);
  620.     return $rep unless $rep->ok;
  621.     $rep = $rep->result;
  622.     $rep->profile_add($profile);
  623. }
  624.  
  625. sub profile_del {
  626.     my $profile = shift;
  627.     trace(3, "PPM::UI::profile_del($profile)\n");
  628.     my $p_rep = config_get('profile_server')->result;
  629.     my $rep = get_rep($p_rep);
  630.     return $rep unless $rep->ok;
  631.     $rep = $rep->result;
  632.     $rep->profile_del($profile);
  633. }
  634.  
  635. sub profile_restore {
  636.     my $profile = shift;
  637.     my $status_cb = shift;
  638.     my $remove_cb = shift;
  639.     my $force = shift;
  640.     my $follow = shift;
  641.     my $dry = shift;
  642.     my $clean_pkgs = shift;
  643.  
  644.     trace(3, "PPM::UI::profile_restore($profile, CODEREF, ",
  645.       "$force, $follow, $dry, $clean_pkgs)\n");
  646.  
  647.     my $p_rep = config_get('profile_server')->result;
  648.     my $rep = get_rep($p_rep);
  649.     return $rep unless $rep->ok;
  650.     $rep = $rep->result;
  651.  
  652.     # 1. Download the profile_info() from the repository
  653.     my $res = $rep->profile_info($profile);
  654.     return $res unless $res->ok;
  655.  
  656.     my %packages;
  657.  
  658.     # 2. For each package in profile_info(), upgrade (or install)
  659.     for my $entry ($res->result_l) {
  660.     my ($repos, $targ_type, $targ_name, $package, $version) = @$entry;
  661.     my $rep = get_rep($repos);
  662.     return $rep unless $rep->ok;
  663.     $rep = $rep->result;
  664.     my $targ = get_targ($targ_name)->result;
  665.     next unless $targ;    # skip unknown targs
  666.  
  667.     $packages{$targ->name}{$package} = $version;
  668.  
  669.     my $prop = properties($targ_name, $package);
  670.     next if ($prop->ok
  671.          and ($prop->result_l)[PROP_PPD_OBJ]->version_osd eq $version);
  672.  
  673.     if ($dry) {
  674.         my $version = PPM::PPD::printify($version);
  675.         $status_cb->($package, $version, $targ->name,
  676.              'PRE-INSTALL', 0, 0, 0);
  677.     }
  678.     else {
  679.         remove($targ_name, $package, 1, $remove_cb)
  680.           if $prop->ok;
  681.         install($rep, $targ_name, $package, $force, $follow, $dry, $status_cb);
  682.     }
  683.     }
  684.  
  685.     return Ok() unless $clean_pkgs;
  686.  
  687.     # 3. Now query each target and make sure it only contains the packages we
  688.     # just installed (if clean_pkgs is set):
  689.     for my $target (keys %packages) {
  690.     my @precious = get_targ($target)->result->precious->result_l;
  691.     my $q = query($target, '*', 0);
  692.     next unless $q->ok;
  693.     for my $pkg ($q->result_l) {
  694.         next if exists $packages{$target}{$pkg->name};
  695.         next if grep { $pkg->name eq $_ } @precious;
  696.         if ($dry) {
  697.         $remove_cb->($pkg->name, $pkg->version, $target);
  698.         }
  699.         else {
  700.         remove($target, $pkg->name, 1, $remove_cb);
  701.         }
  702.     }
  703.     }
  704.  
  705.     return Ok();
  706. }
  707.  
  708. sub profile_save {
  709.     my $name = shift;
  710.     trace(3, "PPM::UI::profile_save($name)\n");
  711.  
  712.     my $p_rep = config_get('profile_server')->result;
  713.     my $rep = get_rep($p_rep);
  714.     return $rep unless $rep->ok;
  715.     $rep = $rep->result;
  716.  
  717.     # 1. Get the "query *" information from all current targets.
  718.     my @entries;
  719.  
  720.     # First, get the targets:
  721.     my @targets = map { get_targ($_)->result } target_list()->result_l;
  722.     for my $targ (@targets) {
  723.  
  724.     # Now get information about that target:
  725.     my $targ_t = $targ->config_get("TARGET_TYPE")->result;
  726.     my $targ_name = $targ->name;
  727.  
  728.     # Now get the packages:
  729.     my @pkgs = query($targ, '*', 0)->result_l;
  730.     for my $pkg (@pkgs) {
  731.         my $obj = $pkg->getppd_obj;
  732.         next unless $obj->ok;
  733.         my $prop = properties($targ, $pkg->name);
  734.         my $repos = ($prop->result_l)[PROP_REPOS];
  735.         my $entry = [$repos,
  736.              $targ_t,
  737.              $targ_name,
  738.              $pkg->name,
  739.              $obj->result->version_osd,
  740.             ];
  741.         push @entries, $entry;
  742.     }
  743.     }
  744.  
  745.     # 2. Upload the information to the Repository.
  746.     $rep->profile_save($name, @entries);
  747. }
  748.  
  749. sub profile_info {
  750.     my $name = shift;
  751.     trace(3, "PPM::UI::profile_info($name)\n");
  752.     my $p_rep = config_get('profile_server')->result;
  753.     my $rep = get_rep($p_rep);
  754.     return $rep unless $rep->ok;
  755.     $rep = $rep->result;
  756.     my $res = $rep->profile_info($name);
  757.     return $res unless $res->ok;
  758.     my @lst = $res->result_l;
  759.     my @ret;
  760.     for (@lst) {
  761.     my $ent = [@$_[qw(3 4 2)]];
  762.     $ent->[1] = PPM::PPD::printify($ent->[1]);
  763.     push @ret, $ent;
  764.     }
  765.     List(@ret);
  766. }
  767.  
  768. sub profile_rename {
  769.     my $oldname = shift;
  770.     my $newname = shift;
  771.  
  772.     # Make sure the profile actually exists:
  773.     my @profiles = profile_list()->result_l;
  774.     return Error("Can't rename nonexistent repository '$oldname'.")
  775.       unless grep { $oldname eq $_ } @profiles;
  776.  
  777.     # Tell the server to rename the profile:
  778.     my $repos = get_rep(config_get('profile_server')->result);
  779.     return $repos unless $repos->ok;
  780.     $repos = $repos->result;
  781.     $repos->profile_rename($oldname, $newname);
  782. }
  783.  
  784. #=============================================================================
  785. # Utilities
  786. #=============================================================================
  787. sub install_or_upgrade {
  788.     my $rlist = shift;      # A list of repositories to search in order
  789.     my $target = shift;
  790.     my $package = shift;
  791.     my $opts = shift;
  792.     my %opts = %$opts;
  793.     my $status_cb = shift;
  794.     my $event_name = shift;
  795.  
  796.     my $do_install = sub {
  797.     my $pkg = shift;
  798.  
  799.     # Download the PPD and package tarball:
  800.     my $pkg_obj = $pkg->getppd_obj($target)->result;
  801.     if ($opts{dryrun}) {
  802.         $status_cb->($pkg->name, $pkg_obj->version,
  803.              $target->name, 'PRE-INSTALL', 0, 0, 0);
  804.         return Ok(); # do nothing, successfully
  805.     }
  806.     my $location = $pkg->getppm($target,
  807.                     config_get("tempdir")->result,
  808.                     $status_cb,
  809.                     config_get("downloadbytes")->result,
  810.                    );
  811.  
  812.     # update ERR appropriately, and fail.
  813.     return $location unless $location->ok;
  814.  
  815.     # Send the install (or update) event to the backend:
  816.     my $err = $target->$event_name($pkg_obj->name,
  817.                        $location->result,
  818.                        $pkg_obj->ppd,
  819.                        $pkg->rep->location,
  820.                        $opts{verbose},
  821.                       );
  822.     return $err unless $err->ok;
  823.  
  824.     $status_cb->($pkg->name, $pkg_obj->version, $target->name, "COMPLETE");
  825.  
  826.     # Track the profile:
  827.     my $track = config_get('profile_enable')->result;
  828.     if ($track) {
  829.         my $p_rep = get_rep(config_get('profile_server')->result);
  830.         my $ok = $p_rep;
  831.         my $profile = config_get('profile')->result;
  832.         if ($p_rep->ok) {
  833.         $p_rep = $p_rep->result;
  834.         my $entry = [$pkg->rep->location,
  835.                  $target->config_get('TARGET_TYPE')->result,
  836.                  $target->name,
  837.                  $pkg_obj->name,
  838.                  $pkg_obj->version_osd,
  839.                 ];
  840.         if ($event_name eq 'install') {
  841.             $ok = $p_rep->installed($profile, $entry);
  842.         }
  843.         else {
  844.             $ok = $p_rep->upgraded($profile, $entry);
  845.         }
  846.         }
  847.         unless ($ok->is_success) {
  848.         my $warning = Warning("Profile '$profile' may not be in sync. "
  849.                    . $ok->msg_raw);
  850.         return $warning;
  851.         }
  852.     }
  853.     return Ok();
  854.     };
  855.  
  856.     # We can shortcut the prerequisite check if we're ignoring that:
  857.     return $do_install->($package)
  858.       if ($opts{force} and not $opts{follow});
  859.  
  860.     my $warning = Ok();
  861.     my @pkgs = ($package);
  862.     my %done;
  863.  
  864.   PACKAGE:
  865.     while (@pkgs) {
  866.     my $pkg = shift @pkgs;
  867.  
  868.     # If the package spec came from a repository, assume the user knows
  869.     # what they're doing, and it's ready to be updated.
  870.     $pkg->make_complete($target);
  871.     my $ppd_ref = $pkg->getppd_obj($target);
  872.     return $ppd_ref unless $ppd_ref->ok;
  873.     if ($ppd_ref->result->from ne 'repository') {
  874.         # If the package is up to date (and $force isn't set), return.
  875.         my $prop = properties($target, $pkg);
  876.         if ($prop->ok) {
  877.         my $u2d = $pkg->uptodate($target);
  878.  
  879.         # If the server doesn't have that package available, we'll
  880.         # _assume_ it's up to date, issuing a warning to that effect
  881.         my $uptodate = 1;
  882.         if ($u2d->ok) {
  883.             ($uptodate) = $u2d->result_l;
  884.         }
  885.         else {
  886.             #print "NOTE: package " . $pkg->name . " not on server...\n";
  887.             #print Dumper $u2d;
  888.             #print Dumper \@pkgs;
  889.             next PACKAGE;
  890.         }
  891.         next PACKAGE if ($uptodate and not $opts{force});
  892.         }
  893.     }
  894.  
  895.     # Try to get a list of prerequisites for the package:
  896.     my @missing;
  897.     my $impl = $ppd_ref->result->find_impl($target);
  898.     return $impl unless $impl->ok;
  899.     
  900.     # Get a list of prerequisites from the implementation:
  901.     my @prereqs = grep { not $done{$_->name} } $impl->result->prereqs;
  902.  
  903.     # We can shortcut the cross-checking of prereqs if we're forcing the
  904.     # install of any prereqs:
  905.     if ($opts{force} and $opts{follow} and @prereqs) {
  906.         unshift @pkgs, (map { get_pkg($_->name, $rlist) } @prereqs), $pkg;
  907.         next PACKAGE;
  908.     }
  909.  
  910.     # Check each prerequisite to see if it's installed.
  911.     else {
  912.         for my $pre (@prereqs) {
  913.         my $prop = $target->properties($pre->name);
  914.         push @missing, $pre->name and next
  915.           unless $prop->ok;
  916.         my $ver = ($prop->result_l)[PROP_PPD_OBJ]->version_osd;
  917.         my $ok = $pkg->uptodate($target, $pre->name, $ver);
  918.         push @missing, $pre->name
  919.           if ($ok->ok and not (($ok->result_l)[0]));
  920.         }
  921.         if (@missing and not $opts{force} and not $opts{follow}) {
  922.         return Error(
  923.             "can't install package '", $pkg->name,
  924.             "': missing prereqs @missing."
  925.         );
  926.         }
  927.         elsif (@missing) {
  928.         unshift @pkgs, (map { get_pkg($_, $rlist) } @missing), $pkg;
  929.         next PACKAGE;
  930.         }
  931.     }
  932.  
  933.     # Install the durned package
  934.     my $res = $do_install->($pkg);
  935.     return $res unless $res->ok;
  936.     $warning = $res unless $res->is_success;
  937.     $done{$pkg->name}++;
  938.     }
  939.     return $warning;
  940. }
  941.  
  942. #=============================================================================
  943. # These utilities make it easier for clients of this class to find out
  944. # information about packages. Any subroutine which takes the name of a package
  945. # can now take either a URL or a filename. That means clients may want to know
  946. # this!
  947. #=============================================================================
  948. sub get_pkg {
  949.     my $pkg = shift;
  950.     my $rep = shift;
  951.     return $pkg if eval { $pkg->isa('PPM::Package') };
  952.     PPM::Package->new($pkg, $rep);
  953. }
  954.  
  955. sub pkg_type {
  956.     my $pkg = get_pkg(shift, undef); # not going to use the repository
  957.     return $pkg->type;
  958. }
  959.  
  960. sub is_pkg {
  961.     my $pkg = shift;
  962.     return 1 if eval { $pkg->isa('PPM::Package') };
  963.     my $p = PPM::Package->new($pkg);
  964.     return 0 if $p->type eq 'UNKNOWN';
  965.     1;
  966. }
  967.  
  968. #=============================================================================
  969. # Cache of "active" repositories and targets:
  970. #=============================================================================
  971. my %open_repositories;
  972. sub get_rep {
  973.     my $rep = shift;
  974.     trace(3, "PPM::UI::get_rep($rep)\n");
  975.     return Ok($rep) if eval { $rep->isa("PPM::Repository") };
  976.     return Ok($open_repositories{$rep})
  977.       if exists $open_repositories{$rep};
  978.     my ($url,$name,$pass) = exists $REPS->{DATA}{$rep}
  979.               ? @{$REPS->{DATA}{$rep}}{qw(url username password)}
  980.               : ($rep, undef, undef);
  981.  
  982.     my @ok = PPM::Repository->new($url, $rep, $name, $pass);
  983.     return Error($ok[1]) unless $ok[0];
  984.     $open_repositories{$rep} = $ok[0];
  985.     Ok($ok[0]);
  986. }
  987. sub del_rep {
  988.     my $rep = shift;
  989.     delete $open_repositories{$rep};
  990. }
  991. sub get_reps {
  992.     my $reps = shift;
  993.     my (@good, @bad);
  994.     for my $_rep (@$reps) {
  995.     my $rep = get_rep($_rep);
  996.     if ($rep->ok) {
  997.         push @good, $rep->result;
  998.     }
  999.     else {
  1000.         push @bad, $rep;
  1001.     }
  1002.     }
  1003.     (\@good, \@bad)
  1004. }
  1005.  
  1006. my %open_installers;
  1007. sub get_targ {
  1008.     my $targ = shift;
  1009.     $targ = '' unless defined $targ;
  1010.     trace(3, "PPM::UI::get_targ($targ)\n");
  1011.     return Ok($targ) if eval { $targ->isa("PPM::Installer") };
  1012.     return Ok($open_installers{$targ})
  1013.       if exists $open_installers{$targ};
  1014.     return Error("Target '$targ' not found")
  1015.       unless exists $TARG->{DATA}{$targ};
  1016.     my $t = $TARG->{DATA}{$targ};
  1017.     my @r = PPM::Installer->new($targ, $t);
  1018.     return Error($r[1]) unless $r[0];
  1019.     $open_installers{$targ} = $r[0];
  1020.     Ok($r[0]);
  1021. }
  1022.  
  1023. #=============================================================================
  1024. # Settings persistence
  1025. #=============================================================================
  1026. BEGIN {
  1027.     $CONF = PPM::Config::load_config_file('clientlib');
  1028.     $REPS = PPM::Config::load_config_file('repositories');
  1029.     $TARG = PPM::Config::load_config_file('targets', 'ro');
  1030.  
  1031.     my $tempdir = config_get('tempdir');
  1032.     config_set('tempdir', $ENV{TEMP}) if $tempdir->ok && ! -d $tempdir->result;
  1033.  
  1034.     # Start up the trace if it's needed:
  1035.     my $tracelvl = config_get('tracelvl');
  1036.     if ($tracelvl->result && $tracelvl->result > 0) {
  1037.     PPM::Trace::trace_init(config_get('tracefile')->result,
  1038.                    config_get('tracelvl')->result);
  1039.     }
  1040. }
  1041.  
  1042. package PPM::Package;
  1043. use strict;
  1044. use PPM::Result qw(Ok Warning Error List);
  1045. use URI;
  1046. use Data::Dumper;
  1047.  
  1048. sub new {
  1049.     my $class = shift;
  1050.     my $name  = shift;
  1051.     my $rep   = shift;
  1052.     my $o = bless {}, ref($class) || $class;
  1053.     $rep = [] if not defined $rep;
  1054.  
  1055.     # A PPM::PPD object
  1056.     if (eval { $name->isa('PPM::PPD') }) {
  1057.     $o->{type}    = 'PPM::PPD';
  1058.     $o->{name}    = $o->{rawname} = $name->name;
  1059.     $o->{id}      = $name->id;
  1060.     $o->{current_rep} =
  1061.         defined $name->repository ? $name->repository :
  1062.         ref $rep eq 'ARRAY'       ? $rep->[0]         : $rep;
  1063.     $o->{reps}    = [$o->{current_rep}];
  1064.     $o->{obj}     = Ok($name);
  1065.     }
  1066.     # A URL:
  1067.     elsif ($name =~ m{(^[^:]{2,}://.+)/([^/]+)\.ppd}i) {
  1068.     $o->{type}    = 'WWW';
  1069.     $o->{rawname} = $o->{id} = $2;
  1070.     my $rep       = PPM::UI::get_rep($1);
  1071.     $o->{uri}     = URI->new($name);
  1072.     die "Can't parse PPD location $name: " . $rep->msg
  1073.       unless $rep->is_success;
  1074.     $o->{reps}    = [$rep->result];
  1075.     my $ppd_obj   = $o->getppd_obj(undef); # undef'd target...
  1076.     $o->{name}    = $o->{rawname} unless $ppd_obj->ok;
  1077.     $o->{name}    = $ppd_obj->result->name;
  1078.     }
  1079.     # A filename:
  1080.     elsif ($name =~ m{((?:^[A-Z]:[\\/]|[\\/]{2}[^\\/]+)?[^:]*[\\/])?([^/]+)\.ppd}i) {
  1081.     $o->{type}    = 'FILE';
  1082.     $o->{rawname} = $o->{id} = $2;
  1083.     my $dir = $1;
  1084.     $dir =~ s{[\\/]+$}{} if $dir and $dir !~ m{^[\\/]+$};
  1085.     my $rep = PPM::UI::get_rep($dir || '.');
  1086.     die "Can't parse PPD location $name: " . $rep->msg
  1087.       unless $rep->is_success;
  1088.     $o->{reps}  = [$rep->result];
  1089.     my $ppd_obj = $o->getppd_obj(undef); # undef'd target...
  1090.     if ($ppd_obj->ok) {
  1091.         $o->{name} = $ppd_obj->result->name;
  1092.     }
  1093.     else {
  1094.         $o->{name} = $o->{rawname} unless $ppd_obj->ok;
  1095.     }
  1096.     }
  1097.     # A plain package name:
  1098.     elsif ($name =~ m{^[-_A-Za-z0-9]+$}) {
  1099.     $o->{type} = 'PKG';
  1100.     $o->{name} = $o->{rawname} = $name;
  1101.     $o->{reps} = ref($rep) eq 'ARRAY' ? $rep : [$rep];
  1102.     }
  1103.     # Something else:
  1104.     else {
  1105.     #print STDERR "WARNING: could not parse package name '$name'.\n";
  1106.     $o->{type} = 'UNKNOWN';
  1107.     $o->{name} = $o->{rawname} = $name;
  1108.     $o->{reps} = ref($rep) eq 'ARRAY' ? $rep : [$rep];
  1109.     }
  1110.     $o->{id} = $o->{rawname} unless defined $o->{id};
  1111.  
  1112.     return $o;
  1113. }
  1114.  
  1115. sub name {
  1116.     my $o = shift;
  1117.     $o->{name};
  1118. }
  1119.  
  1120. sub reps {
  1121.     my $o = shift;
  1122.     @{$o->{reps}};
  1123. }
  1124.  
  1125. sub rep {
  1126.     my $o = shift;
  1127.     $o->{current_rep};
  1128. }
  1129.  
  1130. sub type {
  1131.     my $o = shift;
  1132.     $o->{type};
  1133. }
  1134.  
  1135. sub uri {
  1136.     my $o = shift;
  1137.     $o->{uri};
  1138. }
  1139.  
  1140. # Forces a refresh of the {obj} or {desc} fields if they are not marked as
  1141. # complete by the PPM::Repository client.
  1142. sub make_complete {
  1143.     my $o = shift;
  1144.     my $targ = PPM::UI::get_targ(shift)->result;
  1145.     my $obj = $o->getppd_obj($targ);
  1146.     return if (
  1147.     $obj and
  1148.     $obj->ok and
  1149.     $obj->result->is_complete and
  1150.     $obj->result->ppd
  1151.     );
  1152.     delete @$o{qw(obj desc)};
  1153.     $o->{obj} = $o->{desc} = $o->getppd_obj($targ);
  1154. }
  1155.  
  1156. # Find the first repository containing the package, and report whether the
  1157. # package is up-to-date w.r.t that repository.
  1158. sub uptodate {
  1159.     my $o = shift;
  1160.     my $target = PPM::UI::get_targ(shift)->result;
  1161.     my $desc = $o->describe($target);
  1162.     if ($desc and $desc->ok) {
  1163.     my $u2d = $o->{current_rep}->uptodate(
  1164.         $target,
  1165.         $o->{id},
  1166.         $desc->result->version_osd,
  1167.     );
  1168.     return $u2d;
  1169.     }
  1170.     Error("package $o->{rawname} not found in repositories");
  1171. }
  1172.  
  1173. sub describe {
  1174.     my $o = shift;
  1175.     my $target = PPM::UI::get_targ(shift)->result;
  1176.     return $o->{obj}  if $o->{type} eq 'PPM::PPD';
  1177.     return $o->{desc} if $o->{desc};
  1178.     unless ($o->{desc}) {
  1179.     for my $rep (@{$o->{reps}}) {
  1180.         $o->{current_rep} = $rep;
  1181.         $o->{desc} = $rep->describe($target, $o->{id});
  1182.         last if $o->{desc}->ok;
  1183.     }
  1184.     }
  1185.     $o->{desc};
  1186. }
  1187.  
  1188. sub getppd_obj {
  1189.     my $o = shift;
  1190.     my $target = PPM::UI::get_targ(shift)->result;
  1191.     return $o->{obj} if defined $o->{obj};
  1192.     for my $rep (@{$o->{reps}}) {
  1193.     $o->{current_rep} = $rep;
  1194.     $o->{obj} = $rep->getppd_obj($target, $o->{id});
  1195.     last if $o->{obj}->ok;
  1196.     }
  1197.     $o->{obj}
  1198. }
  1199.  
  1200. sub getppd {
  1201.     my $o = shift;
  1202.     my $target = PPM::UI::get_targ(shift)->result;
  1203.  
  1204.     # If the current object already has a complete PPD, use it
  1205.     return Ok($o->{obj}->result->ppd) if (
  1206.     $o->{obj} and
  1207.     $o->{obj}->ok and
  1208.     $o->{obj}->result->is_complete and
  1209.     $o->{obj}->result->ppd
  1210.     );
  1211.     $o->make_complete($target);
  1212.     return Ok($o->{obj}->result->ppd);
  1213. }
  1214.  
  1215. sub getppm {
  1216.     my $o = shift;
  1217.     my $target = PPM::UI::get_targ(shift)->result;
  1218.     my $ppm;
  1219.     for my $rep (@{$o->{reps}}) {
  1220.     $o->{current_rep} = $rep;
  1221.     $ppm = $rep->getppm($target, $o->{id}, @_);
  1222.     last if $ppm->ok;
  1223.     }
  1224.     $ppm;
  1225. }
  1226.  
  1227. # Find the correct target for this package. This means matching the
  1228. # LANGUAGE tag in the PPD. Basically we find out what LANGUAGE the PPD
  1229. # represents, and we search through the targets looking for a subset which
  1230. # implement that language. If more than one target implements the language
  1231. # and version, we pick the first. If none work, we fail. If the LANGUAGE
  1232. # tag is missing, or the LANGUAGE matches the given target, we use the
  1233. # given target.
  1234. # NOTE: because LANGUAGE is a child-node of IMPLEMENTATION, we _first_ have to
  1235. # search for an implementation that matches the target, _then_ we have to
  1236. # verify that the target supports the LANGUAGE tag. If it does, we return it,
  1237. # otherwise we go on to the next target.
  1238. sub choose_target {
  1239.     my $o = shift;
  1240.     for (@_) {
  1241.     # Load the target:
  1242.     my $target = PPM::UI::get_targ($_);
  1243.     next unless $target->ok;
  1244.     $target = $target->result;
  1245.  
  1246.     # Load the PPD and find a suitable implementation for this target:
  1247.     $o->make_complete($target);
  1248.     my $ppd = $o->getppd_obj($target);
  1249.     return $ppd unless $ppd->ok;    # the package doesn't exist.
  1250.     my $impl = $ppd->result->find_impl($target);
  1251.     next unless $impl->ok;
  1252.     my $lang = $impl->result->language;
  1253.  
  1254.     # Older PPDs didn't have a LANGUAGE tag, so we must assume a Perl
  1255.     # implementation. For old-times' sake, we'll assume version 5.005 is
  1256.     # required.
  1257.     unless (defined $lang) {
  1258.         $lang = PPM::PPD::Language->new({
  1259.         NAME    => 'Perl',
  1260.         VERSION    => '5.8.0',
  1261.         });
  1262.     }
  1263.  
  1264.     # Check if this implementation's language is understood by the target:
  1265.     my $match = $lang->matches_target($target);
  1266.     return $match unless $match->ok;
  1267.     return Ok($target) if $match->result;
  1268.     }
  1269.     return Error(
  1270.     "no suitable installation target found for package $o->{name}."
  1271.     );
  1272. }
  1273.  
  1274. 1;
  1275.