home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _6ffd2f74be220ad04737a170e30c5653 < prev    next >
Encoding:
Text File  |  2004-04-13  |  37.0 KB  |  1,280 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 $res = $target->query($query, $case);
  403.     return $res unless $res->ok;
  404.     my @results = map { get_pkg($_) } $res->result_l;
  405.     List(@results);
  406. }
  407.  
  408. sub properties {
  409.     my $target = get_targ(shift);
  410.     return $target unless $target->ok;
  411.     $target = $target->result;
  412.     my $pkg = get_pkg(shift, undef); # don't care about repository.
  413.     trace(3, "PPM::UI::properties(", $target->name, ", ", $pkg->name, ")\n");
  414.     my $res = $target->properties($pkg->name);
  415.     return $res unless $res->ok;
  416.     my @res = $res->result_l;
  417.     $res[0] = get_pkg($res[0]);
  418.     return List(@res);
  419. }
  420.  
  421. sub remove {
  422.     my $target = get_targ(shift);
  423.     return $target unless $target->ok;
  424.     $target = $target->result;
  425.     my $pkg = get_pkg(shift, undef); # don't care about repository.
  426.     my $package = $pkg->name;
  427.     my $force = shift;  # normally, if removing a package would break a
  428.             # dependency of another installed package, we refuse.
  429.             # But if the user really wants to...
  430.     my $cb_remove = shift;
  431.     my $verbose = shift;
  432.  
  433.     trace(3, "PPM::UI::remove(", $target->name, ", $package)\n");
  434.     if (grep { $pkg->name eq $_ } $target->precious->result_l) {
  435.     return Error("package '$package' is required by the target.");
  436.     }
  437.     my $prop = $target->properties($package);
  438.     return $prop unless $prop->ok;
  439.  
  440.     my $ok = $target->dependents($package);
  441.     return $ok unless $ok->ok;
  442.  
  443.     my @deps = $ok->result_l;
  444.     if (@deps and not $force) {
  445.     my $msg = "removing '$package' would break these dependencies:\n";
  446.     $msg .= "\t$package is needed by $_.\n" for @deps;
  447.     return Error($msg);
  448.     }
  449.  
  450.     my $version = ($prop->result_l)[PROP_PPD_OBJ]->version;
  451.     $cb_remove->($package, $version, $target->name, "PRE-REMOVE");
  452.     my $ret = $target->remove($package, $verbose);
  453.     return $ret unless $ret->ok;
  454.     $cb_remove->($package, $version, $target->name, "COMPLETE");
  455.     my $track = config_get('profile_enable')->result;
  456.     if ($track and $ret->ok) {
  457.     my $repos = get_rep(config_get('profile_server')->result);
  458.     return $repos unless $repos->ok;
  459.     $repos = $repos->result;
  460.     my $rep = ($prop->result_l)[PROP_REPOS];
  461.     my $ver = ($prop->result_l)[PROP_PPD_OBJ]->version_osd;
  462.     my $entry = [$rep,
  463.              $target->config_get('TARGET_TYPE')->result,
  464.              $target->name,
  465.              $package,
  466.              $ver
  467.             ];
  468.     my $profile = config_get('profile')->result;
  469.     $repos->removed($profile, $entry);
  470.     }
  471.     $ret;
  472. }
  473.  
  474. sub verify {
  475.     my ($rlist, $rbad) = get_reps(shift);
  476.     unless (@$rlist) {
  477.     my $msg = "No valid repositories:\n";
  478.     $msg .= $_->msg for @$rbad;
  479.     return Error($msg);
  480.     }
  481.     my $target = get_targ(shift);
  482.     return $target unless $target->ok;
  483.     $target = $target->result;
  484.     my $pkg = get_pkg(shift, $rlist);
  485.     my $package = $pkg->name;
  486.     trace(3, "PPM::UI::verify(", $target->name, ", $package)\n");
  487.  
  488.     # To do: 
  489.     # 1. Check if the package is installed; return false otherwise.
  490.     my $prop = $target->properties($package);
  491.     return $prop unless $prop->ok;
  492.     my @prop = $prop->result_l;
  493.  
  494.     my $bundled  = grep { $prop[PROP_PPD_OBJ]->name eq $_ }
  495.                 $target->bundled->result_l;
  496.     my $precious = grep { $prop[PROP_PPD_OBJ]->name eq $_ }
  497.                 $target->precious->result_l;
  498.  
  499.     # 2. Get the installed version of the package.
  500.     my $ver = $prop[PROP_PPD_OBJ]->version_osd;
  501.     my $ver_p = $prop[PROP_PPD_OBJ]->version;
  502.  
  503.     # 3. Send the installed version to the Repository for checking.
  504.     # I used to only upgrade from the place it came from. Now it will come
  505.     # from the current repository.
  506.     my $res = $pkg->uptodate($target);
  507.     unless ($res->ok) {
  508.     return Error("bundled package - no upgrade available")
  509.       if $bundled;
  510.     return $res;
  511.     }
  512.     my ($uptodate, $newversion) = $res->result_l;
  513.  
  514.     # 4. Return uptodate(t/f), newversion, oldversion, bundled(t/f):
  515.     return List($uptodate, $bundled, $precious, $newversion, $ver_p);
  516. }
  517.  
  518. sub verify_pkgs {
  519.     my ($rlist, $rbad) = get_reps(shift);
  520.     unless (@$rlist) {
  521.     my $msg = "No valid repositories:\n";
  522.     $msg .= $_->msg for @$rbad;
  523.     return Error($msg);
  524.     }
  525.     my $target = get_targ(shift);
  526.     return $target unless $target->ok;
  527.     $target = $target->result;
  528.     my @pkgs = @_;
  529.  
  530.     # Get the versions of the packages
  531.     my (@ppds, @b, @p);
  532.     my @version = map {
  533.     my $pkg = $_;
  534.     my $inst = properties($target, $pkg);
  535.     return $inst unless $inst->ok;
  536.     my @prop = $inst->result_l;
  537.     my $ppd = $prop[PROP_PPD_OBJ]->getppd_obj($target)->result;
  538.     push @ppds, $ppd;
  539.     my $bundled  = grep { $prop[PROP_PPD_OBJ]->name eq $_ }
  540.                 $target->bundled->result_l;
  541.     push @b, $bundled;
  542.     my $precious = grep { $prop[PROP_PPD_OBJ]->name eq $_ }
  543.                 $target->precious->result_l;
  544.     push @p, $precious;
  545.     $ppd->version_osd;
  546.     } @pkgs;
  547.  
  548.     # Query the package in each repository
  549.     my @ans;
  550.     for my $rep (@$rlist) {
  551.     my @batch;
  552.     for my $i (0 .. $#pkgs) {
  553.         my $pkg = get_pkg($pkgs[$i], [$rep]);
  554.         push @batch, ['uptodate2', $pkg->{id}, $version[$i]];
  555.     }
  556.     my $resp = $rep->batch($target, @batch);
  557.     return $resp unless $resp->ok;
  558.     my @ret = $resp->result_l;
  559.     for my $i (0 .. $#pkgs) {
  560.         next unless $ret[$i]->is_success;
  561.         my $val = $ret[$i]->result;
  562.         push @$val, $ppds[$i], $b[$i], $p[$i];
  563.     }
  564.     push @ans, @ret;
  565.     #push @ans, [$resp->result_l];
  566.     }
  567.     List(@ans);
  568. }
  569.  
  570. sub upgrade {
  571.     my ($rlist, $rbad) = get_reps(shift);
  572.     unless (@$rlist) {
  573.     my $msg = "No valid repositories:\n";
  574.     $msg .= $_->msg for @$rbad;
  575.     return Error($msg);
  576.     }
  577.     my $target = get_targ(shift);
  578.     return $target unless $target->ok;
  579.     $target = $target->result;
  580.     my $pkg = get_pkg(shift, $rlist);
  581.     my $package = $pkg->name;
  582.     my $opts = shift;
  583.     my $status_cb = shift;
  584.  
  585.     trace(3, "PPM::UI::upgrade(", $target->name,
  586.       ", $package, $opts->{force}, $opts->{follow}, $opts->{dryrun})\n");
  587.  
  588.     install_or_upgrade($rlist, $target, $pkg, $opts, $status_cb, 'upgrade');
  589. }
  590.  
  591. #=============================================================================
  592. # Operations which require you to have logged in
  593. #=============================================================================
  594.  
  595. sub profile_set {
  596.     my $profile = shift;
  597.     trace(3, "PPM::UI::profile_set($profile)\n");
  598.     config_set('profile', $profile);
  599.     Ok();
  600. }
  601.  
  602. sub profile_get {
  603.     trace(3, "PPM::UI::profile_get()\n");
  604.     config_get('profile');
  605. }
  606.  
  607. sub profile_list {
  608.     trace(3, "PPM::UI::profile_list()\n");
  609.     my $p_rep = config_get('profile_server')->result;
  610.     my $rep = get_rep($p_rep);
  611.     return $rep unless $rep->ok;
  612.     $rep = $rep->result;
  613.     $rep->profile_list;
  614. }
  615.  
  616. sub profile_add {
  617.     my $profile = shift;
  618.     trace(3, "PPM::UI::profile_add($profile)\n");
  619.     my $p_rep = config_get('profile_server')->result;
  620.     my $rep = get_rep($p_rep);
  621.     return $rep unless $rep->ok;
  622.     $rep = $rep->result;
  623.     $rep->profile_add($profile);
  624. }
  625.  
  626. sub profile_del {
  627.     my $profile = shift;
  628.     trace(3, "PPM::UI::profile_del($profile)\n");
  629.     my $p_rep = config_get('profile_server')->result;
  630.     my $rep = get_rep($p_rep);
  631.     return $rep unless $rep->ok;
  632.     $rep = $rep->result;
  633.     $rep->profile_del($profile);
  634. }
  635.  
  636. sub profile_restore {
  637.     my $profile = shift;
  638.     my $status_cb = shift;
  639.     my $remove_cb = shift;
  640.     my $force = shift;
  641.     my $follow = shift;
  642.     my $dry = shift;
  643.     my $clean_pkgs = shift;
  644.  
  645.     trace(3, "PPM::UI::profile_restore($profile, CODEREF, ",
  646.       "$force, $follow, $dry, $clean_pkgs)\n");
  647.  
  648.     my $p_rep = config_get('profile_server')->result;
  649.     my $rep = get_rep($p_rep);
  650.     return $rep unless $rep->ok;
  651.     $rep = $rep->result;
  652.  
  653.     # 1. Download the profile_info() from the repository
  654.     my $res = $rep->profile_info($profile);
  655.     return $res unless $res->ok;
  656.  
  657.     my %packages;
  658.  
  659.     # 2. For each package in profile_info(), upgrade (or install)
  660.     for my $entry ($res->result_l) {
  661.     my ($repos, $targ_type, $targ_name, $package, $version) = @$entry;
  662.     my $rep = get_rep($repos);
  663.     return $rep unless $rep->ok;
  664.     $rep = $rep->result;
  665.     my $targ = get_targ($targ_name)->result;
  666.     next unless $targ;    # skip unknown targs
  667.  
  668.     $packages{$targ->name}{$package} = $version;
  669.  
  670.     my $prop = properties($targ_name, $package);
  671.     if ($prop->ok) {
  672.         my $pkg = ($prop->result_l)[PROP_PPD_OBJ];
  673.         my $ppm_ppd = $pkg->getppd_obj;
  674.         next if $ppm_ppd->ok and $ppm_ppd->result->version_osd eq $version;
  675.     }
  676.  
  677.     if ($dry) {
  678.         my $version = PPM::PPD::printify($version);
  679.         $status_cb->($package, $version, $targ->name,
  680.              'PRE-INSTALL', 0, 0, 0);
  681.     }
  682.     else {
  683.         remove($targ_name, $package, 1, $remove_cb)
  684.           if $prop->ok;
  685.         my $opts = {force => $force, follow => $follow, dryrun => $dry};
  686.         install([$rep], $targ_name, $package, $opts, $status_cb);
  687.     }
  688.     }
  689.  
  690.     return Ok() unless $clean_pkgs;
  691.  
  692.     # 3. Now query each target and make sure it only contains the packages we
  693.     # just installed (if clean_pkgs is set):
  694.     for my $target (keys %packages) {
  695.     my @precious = get_targ($target)->result->precious->result_l;
  696.     my $q = query($target, '*', 0);
  697.     next unless $q->ok;
  698.     for my $pkg ($q->result_l) {
  699.         next if exists $packages{$target}{$pkg->name};
  700.         next if grep { $pkg->name eq $_ } @precious;
  701.         if ($dry) {
  702.         $remove_cb->($pkg->name, $pkg->version, $target);
  703.         }
  704.         else {
  705.         remove($target, $pkg->name, 1, $remove_cb);
  706.         }
  707.     }
  708.     }
  709.  
  710.     return Ok();
  711. }
  712.  
  713. sub profile_save {
  714.     my $name = shift;
  715.     trace(3, "PPM::UI::profile_save($name)\n");
  716.  
  717.     my $p_rep = config_get('profile_server')->result;
  718.     my $rep = get_rep($p_rep);
  719.     return $rep unless $rep->ok;
  720.     $rep = $rep->result;
  721.  
  722.     # 1. Get the "query *" information from all current targets.
  723.     my @entries;
  724.  
  725.     # First, get the targets:
  726.     my @targets = map { get_targ($_)->result } target_list()->result_l;
  727.     for my $targ (@targets) {
  728.  
  729.     # Now get information about that target:
  730.     my $targ_t = $targ->config_get("TARGET_TYPE")->result;
  731.     my $targ_name = $targ->name;
  732.  
  733.     # Now get the packages:
  734.     my @pkgs = query($targ, '*', 0)->result_l;
  735.     for my $pkg (@pkgs) {
  736.         my $obj = $pkg->getppd_obj;
  737.         next unless $obj->ok;
  738.         my $prop = properties($targ, $pkg->name);
  739.         my $repos = ($prop->result_l)[PROP_REPOS];
  740.         my $entry = [$repos,
  741.              $targ_t,
  742.              $targ_name,
  743.              $pkg->name,
  744.              $obj->result->version_osd,
  745.             ];
  746.         push @entries, $entry;
  747.     }
  748.     }
  749.  
  750.     # 2. Upload the information to the Repository.
  751.     $rep->profile_save($name, @entries);
  752. }
  753.  
  754. sub profile_info {
  755.     my $name = shift;
  756.     trace(3, "PPM::UI::profile_info($name)\n");
  757.     my $p_rep = config_get('profile_server')->result;
  758.     my $rep = get_rep($p_rep);
  759.     return $rep unless $rep->ok;
  760.     $rep = $rep->result;
  761.     my $res = $rep->profile_info($name);
  762.     return $res unless $res->ok;
  763.     my @lst = $res->result_l;
  764.     my @ret;
  765.     for (@lst) {
  766.     my $ent = [@$_[qw(3 4 2)]];
  767.     $ent->[1] = PPM::PPD::printify($ent->[1]);
  768.     push @ret, $ent;
  769.     }
  770.     List(@ret);
  771. }
  772.  
  773. sub profile_rename {
  774.     my $oldname = shift;
  775.     my $newname = shift;
  776.  
  777.     # Make sure the profile actually exists:
  778.     my @profiles = profile_list()->result_l;
  779.     return Error("Can't rename nonexistent repository '$oldname'.")
  780.       unless grep { $oldname eq $_ } @profiles;
  781.  
  782.     # Tell the server to rename the profile:
  783.     my $repos = get_rep(config_get('profile_server')->result);
  784.     return $repos unless $repos->ok;
  785.     $repos = $repos->result;
  786.     $repos->profile_rename($oldname, $newname);
  787. }
  788.  
  789. #=============================================================================
  790. # Utilities
  791. #=============================================================================
  792. sub install_or_upgrade {
  793.     my $rlist = shift;      # A list of repositories to search in order
  794.     my $target = shift;
  795.     my $package = shift;
  796.     my $opts = shift;
  797.     my %opts = %$opts;
  798.     my $status_cb = shift;
  799.     my $event_name = shift;
  800.  
  801.     my $do_install = sub {
  802.     my $pkg = shift;
  803.  
  804.     # Download the PPD and package tarball:
  805.     my $pkg_obj = $pkg->getppd_obj($target)->result;
  806.     if ($opts{dryrun}) {
  807.         $status_cb->($pkg->name, $pkg_obj->version,
  808.              $target->name, 'PRE-INSTALL', 0, 0, 0);
  809.         return Ok(); # do nothing, successfully
  810.     }
  811.     my $location = $pkg->getppm($target,
  812.                     config_get("tempdir")->result,
  813.                     $status_cb,
  814.                     config_get("downloadbytes")->result,
  815.                    );
  816.  
  817.     # update ERR appropriately, and fail.
  818.     return $location unless $location->ok;
  819.  
  820.     # Send the install (or update) event to the backend:
  821.     my $err = $target->$event_name($pkg_obj->name,
  822.                        $location->result,
  823.                        $pkg_obj->ppd,
  824.                        $pkg->rep->location,
  825.                        $opts{verbose},
  826.                       );
  827.     return $err unless $err->ok;
  828.  
  829.     $status_cb->($pkg->name, $pkg_obj->version, $target->name, "COMPLETE");
  830.  
  831.     # Track the profile:
  832.     my $track = config_get('profile_enable')->result;
  833.     if ($track) {
  834.         my $p_rep = get_rep(config_get('profile_server')->result);
  835.         my $ok = $p_rep;
  836.         my $profile = config_get('profile')->result;
  837.         if ($p_rep->ok) {
  838.         $p_rep = $p_rep->result;
  839.         my $entry = [$pkg->rep->location,
  840.                  $target->config_get('TARGET_TYPE')->result,
  841.                  $target->name,
  842.                  $pkg_obj->name,
  843.                  $pkg_obj->version_osd,
  844.                 ];
  845.         if ($event_name eq 'install') {
  846.             $ok = $p_rep->installed($profile, $entry);
  847.         }
  848.         else {
  849.             $ok = $p_rep->upgraded($profile, $entry);
  850.         }
  851.         }
  852.         unless ($ok->is_success) {
  853.         my $warning = Warning("Profile '$profile' may not be in sync. "
  854.                    . $ok->msg_raw);
  855.         return $warning;
  856.         }
  857.     }
  858.     return Ok();
  859.     };
  860.  
  861.     # We can shortcut the prerequisite check if we're ignoring that:
  862.     return $do_install->($package)
  863.       if ($opts{force} and not $opts{follow});
  864.  
  865.     my $warning = Ok();
  866.     my @pkgs = ($package);
  867.     my %done;
  868.  
  869.   PACKAGE:
  870.     while (@pkgs) {
  871.     my $pkg = shift @pkgs;
  872.  
  873.     # If the package spec came from a repository, assume the user knows
  874.     # what they're doing, and it's ready to be updated.
  875.     $pkg->make_complete($target);
  876.     my $ppd_ref = $pkg->getppd_obj($target);
  877.     return $ppd_ref unless $ppd_ref->ok;
  878.     if ($ppd_ref->result->from ne 'repository') {
  879.         # If the package is up to date (and $force isn't set), return.
  880.         my $prop = properties($target, $pkg);
  881.         if ($prop->ok) {
  882.         my $u2d = $pkg->uptodate($target);
  883.  
  884.         # If the server doesn't have that package available, we'll
  885.         # _assume_ it's up to date, issuing a warning to that effect
  886.         my $uptodate = 1;
  887.         if ($u2d->ok) {
  888.             ($uptodate) = $u2d->result_l;
  889.         }
  890.         else {
  891.             #print "NOTE: package " . $pkg->name . " not on server...\n";
  892.             #print Dumper $u2d;
  893.             #print Dumper \@pkgs;
  894.             next PACKAGE;
  895.         }
  896.         next PACKAGE if ($uptodate and not $opts{force});
  897.         }
  898.     }
  899.  
  900.     # Try to get a list of prerequisites for the package:
  901.     my @missing;
  902.     my $impl = $ppd_ref->result->find_impl($target);
  903.     return $impl unless $impl->ok;
  904.     
  905.     # Get a list of prerequisites from the implementation:
  906.     my @prereqs = grep { not $done{$_->name} } $impl->result->prereqs;
  907.  
  908.     # We can shortcut the cross-checking of prereqs if we're forcing the
  909.     # install of any prereqs:
  910.     if ($opts{force} and $opts{follow} and @prereqs) {
  911.         unshift @pkgs, (map { get_pkg($_->name, $rlist) } @prereqs), $pkg;
  912.         next PACKAGE;
  913.     }
  914.  
  915.     # Check each prerequisite to see if it's installed.
  916.     else {
  917.         for my $pre (@prereqs) {
  918.         my $prop = $target->properties($pre->name);
  919.         push @missing, $pre->name and next
  920.           unless $prop->ok;
  921.         my $ver = ($prop->result_l)[PROP_PPD_OBJ]->version_osd;
  922.         my $ok = $pkg->uptodate($target, $pre->name, $ver);
  923.         push @missing, $pre->name
  924.           if ($ok->ok and not (($ok->result_l)[0]));
  925.         }
  926.         if (@missing and not $opts{force} and not $opts{follow}) {
  927.         return Error(
  928.             "can't install package '", $pkg->name,
  929.             "': missing prereqs @missing."
  930.         );
  931.         }
  932.         elsif (@missing) {
  933.         unshift @pkgs, (map { get_pkg($_, $rlist) } @missing), $pkg;
  934.         next PACKAGE;
  935.         }
  936.     }
  937.  
  938.     # Install the durned package
  939.     my $res = $do_install->($pkg);
  940.     return $res unless $res->ok;
  941.     $warning = $res unless $res->is_success;
  942.     $done{$pkg->name}++;
  943.     }
  944.     return $warning;
  945. }
  946.  
  947. #=============================================================================
  948. # These utilities make it easier for clients of this class to find out
  949. # information about packages. Any subroutine which takes the name of a package
  950. # can now take either a URL or a filename. That means clients may want to know
  951. # this!
  952. #=============================================================================
  953. sub get_pkg {
  954.     my $pkg = shift;
  955.     my $rep = shift;
  956.     return $pkg if eval { $pkg->isa('PPM::Package') };
  957.     PPM::Package->new($pkg, $rep);
  958. }
  959.  
  960. sub pkg_type {
  961.     my $pkg = get_pkg(shift, undef); # not going to use the repository
  962.     return $pkg->type;
  963. }
  964.  
  965. sub is_pkg {
  966.     my $pkg = shift;
  967.     return 1 if eval { $pkg->isa('PPM::Package') };
  968.     my $p = PPM::Package->new($pkg);
  969.     return 0 if $p->type eq 'UNKNOWN';
  970.     1;
  971. }
  972.  
  973. #=============================================================================
  974. # Cache of "active" repositories and targets:
  975. #=============================================================================
  976. my %open_repositories;
  977. sub get_rep {
  978.     my $rep = shift;
  979.     trace(3, "PPM::UI::get_rep($rep)\n");
  980.     return Ok($rep) if eval { $rep->isa("PPM::Repository") };
  981.     return Ok($open_repositories{$rep})
  982.       if exists $open_repositories{$rep};
  983.     my ($url,$name,$pass) = exists $REPS->{DATA}{$rep}
  984.               ? @{$REPS->{DATA}{$rep}}{qw(url username password)}
  985.               : ($rep, undef, undef);
  986.  
  987.     my @ok = PPM::Repository->new($url, $rep, $name, $pass);
  988.     return Error($ok[1]) unless $ok[0];
  989.     $open_repositories{$rep} = $ok[0];
  990.     Ok($ok[0]);
  991. }
  992. sub del_rep {
  993.     my $rep = shift;
  994.     delete $open_repositories{$rep};
  995. }
  996. sub get_reps {
  997.     my $reps = shift;
  998.     my (@good, @bad);
  999.     for my $_rep (@$reps) {
  1000.     my $rep = get_rep($_rep);
  1001.     if ($rep->ok) {
  1002.         push @good, $rep->result;
  1003.     }
  1004.     else {
  1005.         push @bad, $rep;
  1006.     }
  1007.     }
  1008.     (\@good, \@bad)
  1009. }
  1010.  
  1011. my %open_installers;
  1012. sub get_targ {
  1013.     my $targ = shift;
  1014.     $targ = '' unless defined $targ;
  1015.     trace(3, "PPM::UI::get_targ($targ)\n");
  1016.     return Ok($targ) if eval { $targ->isa("PPM::Installer") };
  1017.     return Ok($open_installers{$targ})
  1018.       if exists $open_installers{$targ};
  1019.     return Error("Target '$targ' not found")
  1020.       unless exists $TARG->{DATA}{$targ};
  1021.     my $t = $TARG->{DATA}{$targ};
  1022.     my @r = PPM::Installer->new($targ, $t);
  1023.     return Error($r[1]) unless $r[0];
  1024.     $open_installers{$targ} = $r[0];
  1025.     Ok($r[0]);
  1026. }
  1027.  
  1028. #=============================================================================
  1029. # Settings persistence
  1030. #=============================================================================
  1031. BEGIN {
  1032.     $CONF = PPM::Config::load_config_file('clientlib');
  1033.     $REPS = PPM::Config::load_config_file('repositories');
  1034.     $TARG = PPM::Config::load_config_file('targets', 'ro');
  1035.  
  1036.     my $tempdir = config_get('tempdir');
  1037.     config_set('tempdir', $ENV{TEMP}) if $tempdir->ok && ! -d $tempdir->result;
  1038.  
  1039.     # Start up the trace if it's needed:
  1040.     my $tracelvl = config_get('tracelvl');
  1041.     if ($tracelvl->result && $tracelvl->result > 0) {
  1042.     PPM::Trace::trace_init(config_get('tracefile')->result,
  1043.                    config_get('tracelvl')->result);
  1044.     }
  1045. }
  1046.  
  1047. package PPM::Package;
  1048. use strict;
  1049. use PPM::Result qw(Ok Warning Error List);
  1050. use URI;
  1051. use Data::Dumper;
  1052.  
  1053. sub new {
  1054.     my $class = shift;
  1055.     my $name  = shift;
  1056.     my $rep   = shift;
  1057.     my $o = bless {}, ref($class) || $class;
  1058.     $rep = [] if not defined $rep;
  1059.  
  1060.     # A PPM::PPD object
  1061.     if (eval { $name->isa('PPM::PPD') }) {
  1062.     $o->{type}    = 'PPM::PPD';
  1063.     $o->{name}    = $o->{rawname} = $name->name;
  1064.     $o->{id}      = $name->id;
  1065.     $o->{current_rep} =
  1066.         defined $name->repository ? $name->repository :
  1067.         ref $rep eq 'ARRAY'       ? $rep->[0]         : $rep;
  1068.     $o->{reps}    = [$o->{current_rep}];
  1069.     $o->{obj}     = Ok($name);
  1070.     }
  1071.     # A URL:
  1072.     elsif ($name =~ m{(^[^:]{2,}://.+)/([^/]+)\.ppd$}i) {
  1073.     $o->{type}    = 'WWW';
  1074.     $o->{rawname} = $o->{id} = $2;
  1075.     my $rep       = PPM::UI::get_rep($1);
  1076.     $o->{uri}     = URI->new($name);
  1077.     die "Can't parse PPD location $name: " . $rep->msg
  1078.       unless $rep->is_success;
  1079.     $o->{reps}    = [$rep->result];
  1080.     my $ppd_obj   = $o->getppd_obj(undef); # undef'd target...
  1081.     $o->{name}    = $o->{rawname} unless $ppd_obj->ok;
  1082.     $o->{name}    = $ppd_obj->result->name;
  1083.     }
  1084.     # A filename:
  1085.     elsif ($name =~ m{((?:^[A-Z]:[\\/]|[\\/]{2})?.*?)?([^\\/]+)\.ppd$}i) {
  1086.     $o->{type}    = 'FILE';
  1087.     $o->{rawname} = $o->{id} = $2;
  1088.     my $dir = $1;
  1089.     $dir =~ s{[\\/]+$}{} if $dir and $dir !~ m{^([A-Z]:)?[\\/]+$}i;
  1090.     my $rep = PPM::UI::get_rep($dir || '.');
  1091.     die "Can't parse PPD location $name: " . $rep->msg
  1092.       unless $rep->is_success;
  1093.     $o->{reps}  = [$rep->result];
  1094.     my $ppd_obj = $o->getppd_obj(undef); # undef'd target...
  1095.     if ($ppd_obj->ok) {
  1096.         $o->{name} = $ppd_obj->result->name;
  1097.     }
  1098.     else {
  1099.         $o->{name} = $o->{rawname} unless $ppd_obj->ok;
  1100.     }
  1101.     }
  1102.     # A plain package name:
  1103.     elsif ($name =~ m{^[-_A-Za-z0-9]+$}) {
  1104.     $o->{type} = 'PKG';
  1105.     $o->{name} = $o->{rawname} = $name;
  1106.     $o->{reps} = ref($rep) eq 'ARRAY' ? $rep : [$rep];
  1107.     }
  1108.     # Something else:
  1109.     else {
  1110.     #print STDERR "WARNING: could not parse package name '$name'.\n";
  1111.     $o->{type} = 'UNKNOWN';
  1112.     $o->{name} = $o->{rawname} = $name;
  1113.     $o->{reps} = ref($rep) eq 'ARRAY' ? $rep : [$rep];
  1114.     }
  1115.     $o->{id} = $o->{rawname} unless defined $o->{id};
  1116.  
  1117.     return $o;
  1118. }
  1119.  
  1120. sub name {
  1121.     my $o = shift;
  1122.     $o->{name};
  1123. }
  1124.  
  1125. sub reps {
  1126.     my $o = shift;
  1127.     @{$o->{reps}};
  1128. }
  1129.  
  1130. sub rep {
  1131.     my $o = shift;
  1132.     $o->{current_rep};
  1133. }
  1134.  
  1135. sub type {
  1136.     my $o = shift;
  1137.     $o->{type};
  1138. }
  1139.  
  1140. sub uri {
  1141.     my $o = shift;
  1142.     $o->{uri};
  1143. }
  1144.  
  1145. # Forces a refresh of the {obj} or {desc} fields if they are not marked as
  1146. # complete by the PPM::Repository client.
  1147. sub make_complete {
  1148.     my $o = shift;
  1149.     my $targ = PPM::UI::get_targ(shift)->result;
  1150.     my $obj = $o->getppd_obj($targ);
  1151.     return if (
  1152.     $obj and
  1153.     $obj->ok and
  1154.     $obj->result->is_complete and
  1155.     $obj->result->ppd
  1156.     );
  1157.     delete @$o{qw(obj desc)};
  1158.     $o->{obj} = $o->{desc} = $o->getppd_obj($targ);
  1159. }
  1160.  
  1161. # Find the first repository containing the package, and report whether the
  1162. # package is up-to-date w.r.t that repository.
  1163. sub uptodate {
  1164.     my $o = shift;
  1165.     my $target = PPM::UI::get_targ(shift)->result;
  1166.     my $desc = $o->describe($target);
  1167.     if ($desc and $desc->ok) {
  1168.     my $u2d = $o->{current_rep}->uptodate(
  1169.         $target,
  1170.         $o->{id},
  1171.         $desc->result->version_osd,
  1172.     );
  1173.     return $u2d;
  1174.     }
  1175.     Error("package $o->{rawname} not found in repositories");
  1176. }
  1177.  
  1178. sub describe {
  1179.     my $o = shift;
  1180.     my $target = PPM::UI::get_targ(shift)->result;
  1181.     return $o->{obj}  if $o->{type} eq 'PPM::PPD';
  1182.     return $o->{desc} if $o->{desc};
  1183.     unless ($o->{desc}) {
  1184.     for my $rep (@{$o->{reps}}) {
  1185.         $o->{current_rep} = $rep;
  1186.         $o->{desc} = $rep->describe($target, $o->{id});
  1187.         last if $o->{desc}->ok;
  1188.     }
  1189.     }
  1190.     $o->{desc};
  1191. }
  1192.  
  1193. sub getppd_obj {
  1194.     my $o = shift;
  1195.     my $target = PPM::UI::get_targ(shift)->result;
  1196.     return $o->{obj} if defined $o->{obj};
  1197.     for my $rep (@{$o->{reps}}) {
  1198.     $o->{current_rep} = $rep;
  1199.     $o->{obj} = $rep->getppd_obj($target, $o->{id});
  1200.     last if $o->{obj}->ok;
  1201.     }
  1202.     $o->{obj}
  1203. }
  1204.  
  1205. sub getppd {
  1206.     my $o = shift;
  1207.     my $target = PPM::UI::get_targ(shift)->result;
  1208.  
  1209.     # If the current object already has a complete PPD, use it
  1210.     return Ok($o->{obj}->result->ppd) if (
  1211.     $o->{obj} and
  1212.     $o->{obj}->ok and
  1213.     $o->{obj}->result->is_complete and
  1214.     $o->{obj}->result->ppd
  1215.     );
  1216.     $o->make_complete($target);
  1217.     return Ok($o->{obj}->result->ppd);
  1218. }
  1219.  
  1220. sub getppm {
  1221.     my $o = shift;
  1222.     my $target = PPM::UI::get_targ(shift)->result;
  1223.     my $ppm;
  1224.     for my $rep (@{$o->{reps}}) {
  1225.     $o->{current_rep} = $rep;
  1226.     $ppm = $rep->getppm($target, $o->{id}, @_);
  1227.     last if $ppm->ok;
  1228.     }
  1229.     $ppm;
  1230. }
  1231.  
  1232. # Find the correct target for this package. This means matching the
  1233. # LANGUAGE tag in the PPD. Basically we find out what LANGUAGE the PPD
  1234. # represents, and we search through the targets looking for a subset which
  1235. # implement that language. If more than one target implements the language
  1236. # and version, we pick the first. If none work, we fail. If the LANGUAGE
  1237. # tag is missing, or the LANGUAGE matches the given target, we use the
  1238. # given target.
  1239. # NOTE: because LANGUAGE is a child-node of IMPLEMENTATION, we _first_ have to
  1240. # search for an implementation that matches the target, _then_ we have to
  1241. # verify that the target supports the LANGUAGE tag. If it does, we return it,
  1242. # otherwise we go on to the next target.
  1243. sub choose_target {
  1244.     my $o = shift;
  1245.     for (@_) {
  1246.     # Load the target:
  1247.     my $target = PPM::UI::get_targ($_);
  1248.     next unless $target->ok;
  1249.     $target = $target->result;
  1250.  
  1251.     # Load the PPD and find a suitable implementation for this target:
  1252.     $o->make_complete($target);
  1253.     my $ppd = $o->getppd_obj($target);
  1254.     return $ppd unless $ppd->ok;    # the package doesn't exist.
  1255.     my $impl = $ppd->result->find_impl($target);
  1256.     next unless $impl->ok;
  1257.     my $lang = $impl->result->language;
  1258.  
  1259.     # Older PPDs didn't have a LANGUAGE tag, so we must assume a Perl
  1260.     # implementation. For old-times' sake, we'll assume version 5.6.0 is
  1261.     # required.
  1262.     unless (defined $lang) {
  1263.         $lang = PPM::PPD::Language->new({
  1264.         NAME    => 'Perl',
  1265.         VERSION    => '5.6.0',
  1266.         });
  1267.     }
  1268.  
  1269.     # Check if this implementation's language is understood by the target:
  1270.     my $match = $lang->matches_target($target);
  1271.     return $match unless $match->ok;
  1272.     return Ok($target) if $match->result;
  1273.     }
  1274.     return Error(
  1275.     "no suitable installation target found for package $o->{name}."
  1276.     );
  1277. }
  1278.  
  1279. 1;
  1280.