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