home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.8.3.809-MSWin32-x86.msi / _74176b65d6964e69c8deffc62f77b0b8 < prev    next >
Encoding:
Text File  |  2004-02-02  |  98.8 KB  |  3,714 lines
  1. @rem = '--*-Perl-*--
  2. @echo off
  3. if "%OS%" == "Windows_NT" goto WinNT
  4. perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
  5. goto endofperl
  6. :WinNT
  7. perl -x -S %0 %*
  8. if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
  9. if %errorlevel% == 9009 echo You do not have Perl in your PATH.
  10. if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
  11. goto endofperl
  12. @rem ';
  13. #!perl 
  14. #line 15
  15.  
  16. require 5.006;    # require 5.6.0
  17. use strict;
  18.  
  19. # A command-line shell implementation. The code which invokes it is at the
  20. # bottom of this file.
  21. package PPMShell;
  22. use base qw(PPM::Term::Shell);
  23.  
  24. use Data::Dumper;
  25. use Text::Autoformat qw(autoformat form);
  26. use Getopt::Long;
  27.  
  28. # These must come _after_ the options parsing.
  29. require PPM::UI;
  30. require PPM::Trace;
  31. PPM::Trace->import(qw(trace));
  32.  
  33. my $NAME    = q{PPM - Programmer's Package Manager};
  34. my $SHORT_NAME    = q{PPM};
  35. our $VERSION    = '3.1';
  36.  
  37. sub dictsort(@);
  38.  
  39. #=============================================================================
  40. # Output Methods
  41. #
  42. # PPM behaves differently under different calling circumstances. Here are the
  43. # various classes of messages it prints out:
  44. # 1. error/warning    - an error or "bad thing" has occurred
  45. # 2. informational    - required information like search results
  46. # 3. verbose        - verbose that's only needed in interactive mode
  47. #
  48. # Here are the cases:
  49. # 1. PPM is in interactive mode: everything gets printed.
  50. # 2. PPM is in batch mode: everything minus 'verbose' gets printed.
  51. #=============================================================================
  52. sub error {
  53.     my $o = shift;
  54.     return 1 unless $o->{SHELL}{output}{error};
  55.     CORE::print STDERR @_;
  56. }
  57. sub errorf {
  58.     my $o = shift;
  59.     return 1 unless $o->{SHELL}{output}{error};
  60.     CORE::printf STDERR @_;
  61. }
  62. sub warn { goto &error }
  63. sub warnf { goto &errorf }
  64. sub inform {
  65.     my $o = shift;
  66.     return 1 unless $o->{SHELL}{output}{inform};
  67.     CORE::print @_;
  68. }
  69. sub informf {
  70.     my $o = shift;
  71.     return 1 unless $o->{SHELL}{output}{inform};
  72.     CORE::printf @_;
  73. }
  74. sub verbose {
  75.     my $o = shift;
  76.     return 1 unless $o->{SHELL}{output}{verbose};
  77.     CORE::print @_;
  78. }
  79. sub verbosef {
  80.     my $o = shift;
  81.     return 1 unless $o->{SHELL}{output}{verbose};
  82.     CORE::printf @_;
  83. }
  84. sub assertw {
  85.     my $o = shift;
  86.     my $cond = shift;
  87.     my $msg = shift;
  88.     $o->warn("Warning: $msg\n") unless $cond;
  89.     return $cond;
  90. }
  91. sub assert {
  92.     my $o = shift;
  93.     my $cond = shift;
  94.     my $msg = shift;
  95.     $o->error("Error: $msg\n") unless $cond;
  96.     return $cond;
  97. }
  98.  
  99. sub mode {
  100.     my $o = shift;
  101.     $o->{SHELL}{mode};
  102. }
  103. sub setmode {
  104.     my $o = shift;
  105.     my $newmode = shift || '';
  106.     my $oldmode = $o->{SHELL}{mode};
  107.     if ($newmode eq 'SHELL') {
  108.     $o->{SHELL}{output}{error}   = 1;
  109.     $o->{SHELL}{output}{inform}  = 1;
  110.     $o->{SHELL}{output}{verbose} = 1;
  111.     }
  112.     elsif ($newmode eq 'BATCH') {
  113.     $o->{SHELL}{output}{error}   = 1;
  114.     $o->{SHELL}{output}{inform}  = 1;
  115.     $o->{SHELL}{output}{verbose} = 0;
  116.     }
  117.     elsif ($newmode eq 'SCRIPT') {
  118.     $o->{SHELL}{output}{error}   = 1;
  119.     $o->{SHELL}{output}{inform}  = 1;
  120.     $o->{SHELL}{output}{verbose} = 0;
  121.     }
  122.     elsif ($newmode eq 'SILENT') {
  123.     $o->{SHELL}{output}{error}   = 1;
  124.     $o->{SHELL}{output}{inform}  = 0;
  125.     $o->{SHELL}{output}{verbose} = 0;
  126.     }
  127.     $o->{SHELL}{mode} = $newmode;
  128.     return $oldmode;
  129. }
  130.  
  131. # Older versions of PPM3 had one "Active" repository. This code reads
  132. # $o->conf('repository') if it exists, and moves it into
  133. # $o->conf('active_reps'), which is a list. The old one is deleted -- old PPMs
  134. # will reset it if needed, but it will be ignored if 'active_reps' exists.
  135. sub init_active_reps {
  136.     my $o = shift;
  137.  
  138.     if ($o->conf('repository') and not $o->conf('active_reps')) {
  139.     my @active = $o->conf('repository');
  140.     delete $o->{SHELL}{conf}{DATA}{repository};
  141.     $o->conf('active_reps', \@active);
  142.     }
  143.     elsif (not defined $o->conf('active_reps')) {
  144.     my @active = $o->reps_all; # enable all repositories
  145.     $o->conf('active_reps', \@active);
  146.     }
  147. }
  148.  
  149. sub init {
  150.     my $o = shift;
  151.     $o->cache_clear('query');
  152.     $o->cache_clear('search');
  153.     $o->{API}{case_ignore} = 1;
  154.  
  155.     # Load the configuration;
  156.     $o->{SHELL}{conf} = PPM::Config::load_config_file('cmdline');
  157.     $o->init_active_reps;
  158.  
  159.     # check whether there's a target in the parent's perl that hasn't been
  160.     # installed in the "targets" file:
  161.     my $ppmsitelib = $ENV{PPM3_PERL_SITELIB};
  162.     if ($ppmsitelib and opendir(PPMDIR, "$ppmsitelib/ppm-conf")) {
  163.         my @files = map  { "$ppmsitelib/ppm-conf/$_" }
  164.                 grep { /^ppminst/i && !/(~|\.bak)\z/ } readdir PPMDIR;
  165.     closedir PPMDIR;
  166.     my $found = 0;
  167.     if (@files == 1) {
  168.         my @targets = PPM::UI::target_list()->result_l;
  169.         for my $target (@targets) {
  170.         my $info = PPM::UI::target_raw_info($target);
  171.         next unless $info and $info->is_success;
  172.         ++$found and last
  173.             if path_under($info->result->{path}, $files[0]);
  174.         }
  175.         unless ($found) {
  176.         # We're going to add a new target:
  177.         # 1. if we can find ppm3-bin.cfg, use that
  178.         # 2. if not, guess lots of stuff
  179.         my $ppm3_bin_cfg = "$ENV{PPM3_PERL_PREFIX}/bin/ppm3-bin.cfg";
  180.         my $r = PPM::UI::target_add(undef, From => $ppm3_bin_cfg)
  181.             if -f $ppm3_bin_cfg;
  182.         unless ($r and $r->is_success) {
  183.             PPM::UI::target_add(
  184.             'TEMP',
  185.             type => 'Local',
  186.             path => $files[0],
  187.             );
  188.         }
  189.         }
  190.     }
  191.     }
  192.  
  193.     # set the initial target:
  194.     if (defined $o->{API}{args}{target}) {
  195.     my $t = $o->{API}{args}{target};
  196.     my $prefix = $ENV{PPM3_PERL_PREFIX};
  197.     if ($t ne 'auto') {
  198.         # A full name or number given:
  199.         $o->run('target', 'select', $o->{API}{args}{target});
  200.     }
  201.     elsif ($prefix) {
  202.         # Auto-select target, based on where we came from:
  203.         my @l = $o->conf('target');
  204.         push @l, PPM::UI::target_list()->result_l;
  205.         for my $target (@l) {
  206.         next unless $target;
  207.         my $info = PPM::UI::target_raw_info($target);
  208.         next unless $info and $info->is_success;
  209.         next unless path_under($info->result->{path}, "$prefix/");
  210.         my $mode = $o->setmode('SILENT');
  211.         $o->run('target', 'select', $target);
  212.         $o->setmode($mode);
  213.         last;
  214.         }
  215.     }
  216.     }
  217. }
  218.  
  219. sub preloop {
  220.     my $o = shift;
  221.  
  222.     if ($o->conf('verbose-startup') and $o->mode eq 'SHELL') {
  223.     my $profile_track = $o->conf('profile-track');
  224.     chomp (my $startup = <<END);
  225. $NAME version $VERSION.
  226. Copyright (c) 2001 ActiveState SRL. All Rights Reserved.
  227.  
  228. Entering interactive shell.
  229. END
  230.  
  231.     my $file = PPM::Config::get_license_file();
  232.     my $license;
  233.     if (open (my $LICENSE, $file)) {
  234.         $license = do { local $/; <$LICENSE> };
  235.     }
  236.     my $aspn = $license =~ /ASPN/;
  237.     my $profile_tracking_warning = ($profile_track || !$aspn) ? '' : <<'END';
  238.  
  239. Profile tracking is not enabled. If you save and restore profiles manually,
  240. your profile may be out of sync with your computer. See 'help profile' for
  241. more information.
  242. END
  243.     $o->inform($startup);
  244.     $o->inform(<<END);
  245.  Using $o->{API}{readline} as readline library.
  246. $profile_tracking_warning
  247. Type 'help' to get started.
  248.  
  249. END
  250.     }
  251.     else {
  252.     $o->inform("$NAME ($VERSION). Type 'help' to get started.\n");
  253.     }
  254.  
  255.     $o->term->SetHistory(@{$o->conf('history') || []})
  256.     if $o->term->Features->{setHistory};
  257. }
  258.  
  259. sub postloop {
  260.     my $o = shift;
  261.     trace(1, "PPM: exiting...\n");
  262.     if ($o->mode eq 'SHELL' and $o->term->Features->{getHistory}) {
  263.     my @h = $o->term->GetHistory;
  264.     my $max_history = $o->conf('max_history') || 100;
  265.     splice @h, 0, (@h - $max_history)
  266.         if @h > $max_history;
  267.     my $old = $o->setmode('SILENT');
  268.     $o->conf('history', \@h);
  269.     $o->setmode($old);
  270.     }
  271. }
  272.  
  273. #============================================================================
  274. # Cache of search and query results
  275. #============================================================================
  276. sub cache_set_current {
  277.     my $o = shift;
  278.     my $type = shift;
  279.     my $set = shift;
  280.     $set = $o->{SHELL}{CACHE}{$type}{current} unless defined $set;
  281.     $o->{SHELL}{CACHE}{$type}{current} = $set;
  282.     return $o->{SHELL}{CACHE}{$type}{current};
  283. }
  284.  
  285. sub cache_set_index {
  286.     my $o = shift;
  287.     my $type = shift;
  288.     my $index = shift;
  289.     $index = $o->{SHELL}{CACHE}{$type}{index} unless defined $index;
  290.     $o->{SHELL}{CACHE}{$type}{index} = $index;
  291.     return $o->{SHELL}{CACHE}{$type}{index};
  292. }
  293.  
  294. sub cache_set_add {
  295.     my $o = shift;
  296.     my $type = shift;
  297.     my $query = shift;
  298.     my $entries = shift;
  299.     my $sort_field = $o->conf('sort-field');
  300.     my @sorted = $o->sort_pkgs($sort_field, @$entries);
  301.     my $set = {
  302.           query => $query,
  303.           raw => $entries,
  304.           $sort_field => \@sorted,
  305.         };
  306.     push @{$o->{SHELL}{CACHE}{$type}{sets}}, $set;
  307. }
  308.  
  309. sub cache_entry {
  310.     my $o = shift;
  311.     my $type = shift;        # 'query' or 'cache';
  312.     my $index = shift;        # defaults to currently selected index
  313.     my $set = shift;        # defaults to currently selected set
  314.  
  315.     $index = $o->{SHELL}{CACHE}{$type}{index} unless defined $index;
  316.  
  317.     my $src = $o->cache_set($type, $set);
  318.     return undef unless $src and bounded(0, $index, $#$src);
  319.  
  320.     # Make sure we display only valid entries:
  321.     my $tar = $o->conf('target');
  322.     $src->[$index]->make_complete($tar);
  323.     return $src->[$index];
  324. }
  325.  
  326. sub cache_set {
  327.     my $o = shift;
  328.     my $type = shift;        # 'query' or 'cache'
  329.     my $set = shift;        # defaults to currently selected set
  330.     my $entry = shift;        # defaults to 'results';
  331.  
  332.     $entry = $o->conf('sort-field') unless defined $entry;
  333.     return undef unless grep { lc($entry) eq $_ } (sort_fields(), 'query');
  334.  
  335.     $set = $o->{SHELL}{CACHE}{$type}{current} unless defined $set;
  336.     my $src = $o->{SHELL}{CACHE}{$type}{sets};
  337.  
  338.     return undef unless defined $set;
  339.     return undef unless bounded(0, $set, $#$src);
  340.  
  341.     # We've changed sort-field at some point -- make sure the sorted data
  342.     # exists, or else build it:
  343.     unless (defined $src->[$set]{$entry}) {
  344.     my $raw = $src->[$set]{raw};
  345.     my @sorted = $o->sort_pkgs($entry, @$raw);
  346.     $src->[$set]{$entry} = \@sorted;
  347.     }
  348.     
  349.     return wantarray ? @{$src->[$set]{$entry}} : $src->[$set]{$entry};
  350. }
  351.  
  352. sub cache_clear {
  353.     my $o = shift;
  354.     my $type = shift;        # 'query' or 'cache'
  355.     $o->{SHELL}{CACHE}{$type}{sets} = [];
  356.     $o->{SHELL}{CACHE}{$type}{current} = -1;
  357.     $o->{SHELL}{CACHE}{$type}{index} = -1;
  358. }
  359.  
  360. sub cache_sets {
  361.     my $o = shift;
  362.     my $type = shift;
  363.     @{$o->{SHELL}{CACHE}{$type}{sets}};
  364. }
  365.  
  366. # This sub searches for an entry in the cache whose name matches that thing
  367. # passed in. It searches in the current cache first. If the name isn't found,
  368. # it searches in all caches. If the name still isn't found, it returns undef.
  369. sub cache_find {
  370.     my $o = shift;
  371.     my $type = shift;
  372.     my $name = shift;
  373.  
  374.     my $ncaches = $o->cache_sets($type);
  375.     my $current = $o->cache_set_current($type);
  376.  
  377.     # First, search the current set:
  378.     my @pkgs = map { $_ ? $_->name : '' } $o->cache_set($type);
  379.     my $ind  = find_index($name, 0, @pkgs);
  380.     return ($current, $ind) if $ind >= 0;
  381.  
  382.     # Now try to find in all the sets:
  383.     for my $s (0 .. $ncaches - 1) {
  384.     next if $s == $current;
  385.     @pkgs = map { $_ ? $_->name : '' } $o->cache_set($type, $s);
  386.     $ind  = find_index($name, 0, @pkgs);
  387.     return ($s, $ind) if $ind >= 0;
  388.     }
  389.     return (-1, -1);
  390. }
  391.  
  392. # A pretty separator to print between logically separate items:
  393. my $SEP;
  394. BEGIN {
  395.     $SEP = '=' x 20;
  396. }
  397.  
  398. # Useful functions:
  399. sub max (&@) {
  400.     my $code = shift;
  401.     my $max;
  402.     local $_;
  403.     for (@_) {
  404.     my $res = $code->($_);
  405.     $max = $res if not defined $max or $max < $res;
  406.     }
  407.     $max || 0;
  408. }
  409.  
  410. sub min (&@) {
  411.     my $code = shift;
  412.     my $min;
  413.     local $_;
  414.     for (@_) {
  415.     my $res = $code->($_);
  416.     $min = $res if not defined $min or $min > $res;
  417.     }
  418.     $min || 0;
  419. }
  420.  
  421. sub sum (&@) {
  422.     my $code = shift;
  423.     my $sum = 0;
  424.     local $_;
  425.     for (@_) {
  426.     my $res = $code->($_);
  427.     $sum += $res if defined $res;
  428.     }
  429.     $sum || 0;
  430. }
  431.  
  432. #============================================================================
  433. # Repository:
  434. # rep            # displays repositories
  435. # rep add http://...    # adds a new repository
  436. # rep del <\d+>        # deletes the specified repository
  437. # rep [set] 1        # sets the specified repository active
  438. #============================================================================
  439. sub smry_repository { "adds, removes, or sets repositories" }
  440. sub help_repository { <<'END' }
  441.  
  442. END
  443. sub comp_repository {
  444.     my $o = shift;
  445.     my ($word, $line, $start) = @_;
  446.     my @words = $o->line_parsed($line);
  447.     my $words = scalar @words;
  448.     my @reps = PPM::UI::repository_list()->result_l;
  449.     my $reps = @reps;
  450.     my @compls = qw(add delete describe rename set select);
  451.     push @compls, ($reps ? (1 .. $reps) : ()); 
  452.  
  453.     if ($words == 1 or $words == 2 and $start != length($line)) {
  454.     return $o->completions($word, \@compls);
  455.     }
  456.     if ($words == 2 or $words == 3 and $start != length($line)) {
  457.     return (readline::rl_filename_list($word))
  458.       if $words[1] eq 'add';
  459.     return $o->completions($word, [1 .. $reps])
  460.       if $o->completions($words[1], [qw(delete describe rename set select)]) == 1;
  461.     }
  462.     ();
  463. }
  464. sub reps_all {
  465.     my $o = shift;
  466.     my $l = PPM::UI::repository_list();
  467.     unless ($l->is_success) {
  468.     $o->warn($l->msg);
  469.     return () unless $l->ok;
  470.     }
  471.     $l->result_l;
  472. }
  473. sub reps_on {
  474.     my $o = shift;
  475.     return @{$o->conf('active_reps')};
  476. }
  477. sub reps_off {
  478.     my $o = shift;
  479.     my @reps = $o->reps_all;
  480.     my @reps_on = $o->reps_on;
  481.     my @off;
  482.     for my $r (@reps) {
  483.     push @off, $r unless grep { $_ eq $r } @reps_on;
  484.     }
  485.     @off;
  486. }
  487. sub rep_on {
  488.     my $o = shift;
  489.     my $rep = shift;
  490.     my @reps = ($o->reps_on, $rep);
  491.     my $m = $o->setmode('SILENT');
  492.     $o->conf('active_reps', \@reps);
  493.     $o->setmode($m);
  494. }
  495. sub rep_off {
  496.     my $o = shift;
  497.     my $rep = shift;
  498.     my @reps = grep { $_ ne $rep } $o->reps_on;
  499.     my $m = $o->setmode('SILENT');
  500.     $o->conf('active_reps', \@reps);
  501.     $o->setmode($m);
  502. }
  503. sub rep_ison {
  504.     my $o = shift;
  505.     my $rep = shift;
  506.     scalar grep { $_ eq $rep } $o->reps_on;
  507. }
  508. sub rep_isoff {
  509.     my $o = shift;
  510.     my $rep = shift;
  511.     scalar grep { $_ eq $rep } $o->reps_off;
  512. }
  513. sub rep_exists {
  514.     my $o = shift;
  515.     my $rep = shift;
  516.     scalar grep { $_ eq $rep } $o->reps_all;
  517. }
  518. sub rep_uniq {
  519.     my $o = shift;
  520.     my $rep = shift;
  521.     unless ($o->rep_exists($rep) or $rep =~ /^\d+$/) {
  522.     /\Q$rep\E/i and return $_ for $o->reps_all;
  523.     }
  524.     $rep;
  525. }
  526. sub rep_up {
  527.     my $o = shift;
  528.     my $rep = shift;
  529.     my @reps = $o->reps_on;
  530.     my $ind = find_index($rep, 0, @reps);
  531.     if (bounded(1, $ind, $#reps)) {
  532.     @reps = (
  533.         @reps[0 .. $ind - 2],
  534.         $rep,
  535.         $reps[$ind - 1],
  536.         @reps[$ind + 1 .. $#reps]
  537.     );
  538.     }
  539.     my $m = $o->setmode('SILENT');
  540.     $o->conf('active_reps', \@reps);
  541.     $o->setmode($m);
  542. }
  543. sub rep_down {
  544.     my $o = shift;
  545.     my $rep = shift;
  546.     my @reps = $o->reps_on;
  547.     my $ind = find_index($rep, 0, @reps);
  548.     if (bounded(0, $ind, $#reps - 1)) {
  549.     @reps = (
  550.         @reps[0 .. $ind - 1],
  551.         $reps[$ind + 1],
  552.         $rep,
  553.         @reps[$ind + 2 .. $#reps]
  554.     );
  555.     }
  556.     my $m = $o->setmode('SILENT');
  557.     $o->conf('active_reps', \@reps);
  558.     $o->setmode($m);
  559. }
  560. sub run_repository {
  561.     my $o = shift;
  562.     my @args = @_;
  563.     my (@reps, @reps_off, @reps_on);
  564.     my $refresh = sub {
  565.     @reps = $o->reps_all;
  566.     @reps_off = $o->reps_off;
  567.     @reps_on = $o->reps_on;
  568.     };
  569.     &$refresh;
  570.     trace(1, "PPM: repository @args\n");
  571.  
  572.     if (@args) {
  573.     my $cmd = shift @args;
  574.     #=====================================================================
  575.     # add, delete, describe, rename commands:
  576.     #=====================================================================
  577.     if (matches($cmd, "add")) {
  578.         # Support for usernames and passwords.
  579.         my ($user, $pass);
  580.         {
  581.         local *ARGV;
  582.         @ARGV = @args;
  583.         GetOptions(
  584.             "username=s"    => \$user,
  585.             "password=s"    => \$pass,
  586.         );
  587.         @args = @ARGV;
  588.         }
  589.         $o->warn(<<END) and return unless @args;
  590. repository: invalid 'add' command arguments. See 'help repository'.
  591. END
  592.         my $url  = pop @args;
  593.         my $name = join(' ', @args);
  594.         unless ($name) {    # rep add http://...
  595.         $name = 'Autonamed';
  596.         for (my $i=1; $i<=@reps; $i++) {
  597.             my $tmp = "$name $i";
  598.             $name = $tmp and last
  599.               unless (grep { $tmp eq $_ } @reps);
  600.         }
  601.         }
  602.         my $ok = PPM::UI::repository_add($name, $url, $user, $pass);
  603.         unless ($ok->is_success) {
  604.         $o->warn($ok->msg);
  605.         return unless $ok->ok;
  606.         }
  607.         $o->rep_on($name);
  608.         $o->cache_clear('search');
  609.     }
  610.     elsif (matches($cmd, "del|ete")) {
  611.         my $arg = join(' ', @args);
  612.         my $gonner = $arg;
  613.         if ($arg =~ /^\d+$/) {
  614.         return unless $o->assert(
  615.             bounded(1, $arg, scalar @reps_on),
  616.             "no such active repository $arg"
  617.         );
  618.         $gonner = $reps_on[$arg - 1];
  619.         }
  620.         else {
  621.         $gonner = $o->rep_uniq($gonner);
  622.         return unless $o->assert(
  623.             $o->rep_exists($gonner),
  624.             "no such repository '$gonner'"
  625.         );
  626.         }
  627.         my $ok = PPM::UI::repository_del($gonner);
  628.         unless ($ok->is_success) {
  629.         $o->warn($ok->msg);
  630.         return unless $ok->ok;
  631.         }
  632.         $o->rep_off($gonner);
  633.         $o->cache_clear('search');
  634.     }
  635.     elsif (matches($cmd, "des|cribe")) {
  636.         my $arg = join(' ', @args) || 1;
  637.         my $rep = $arg;
  638.         if ($arg =~ /^\d+$/) {
  639.         return unless $o->assert(
  640.             bounded(1, $arg, scalar @reps_on),
  641.             "no such active repository $arg"
  642.         );
  643.         $rep = $reps_on[$arg - 1];
  644.         }
  645.         else {
  646.         $rep = $o->rep_uniq($rep);
  647.         return unless $o->assert(
  648.             $o->rep_exists($rep),
  649.             "no such repository '$rep'"
  650.         );
  651.         }
  652.         my $info = PPM::UI::repository_info($rep);
  653.         unless ($info->is_success) {
  654.         $o->warn($info->msg);
  655.         return unless $info->ok;
  656.         }
  657.         my $type = $o->rep_ison($rep) ? "Active" : "Inactive";
  658.         my $num  = (
  659.         $o->rep_ison($rep)
  660.         ? " " . find_index($rep, 1, @reps_on)
  661.         : ""
  662.         );
  663.         my @info = $info->result_l;
  664.         my @keys = qw(Name Location Type);
  665.         push @keys, qw(Username) if @info >= 4;
  666.         push @keys, qw(Password) if @info >= 5;
  667.         $o->inform("Describing $type Repository$num:\n");
  668.         $o->print_pairs(\@keys, \@info);
  669.         return 1;
  670.     }
  671.     elsif (matches($cmd, 'r|ename')) {
  672.         my $name = pop @args;
  673.         my $arg = join(' ', @args);
  674.         my $rep = $arg;
  675.         if ($arg =~ /^\d+$/) {
  676.         return unless $o->assert(
  677.             bounded(1, $arg, scalar @reps_on),
  678.             "no such active repository $arg"
  679.         );
  680.         $rep = $reps_on[$arg - 1];
  681.         }
  682.         else {
  683.         $rep = $o->rep_uniq($rep);
  684.         return unless $o->assert(
  685.             $o->rep_exists($rep),
  686.             "no such repository '$rep'"
  687.         );
  688.         }
  689.         my $ok = PPM::UI::repository_rename($rep, $name);
  690.         unless ($ok->is_success) {
  691.         $o->warn($ok->msg);
  692.         return unless $ok->ok;
  693.         }
  694.         $o->rep_on($name) if $o->rep_ison($rep);
  695.         $o->rep_off($rep);
  696.         $o->cache_clear('search');
  697.     }
  698.  
  699.     #=====================================================================
  700.     # On, off, up, and down commands:
  701.     #=====================================================================
  702.     elsif (matches($cmd, 'on')) {
  703.         my $rep = $o->rep_uniq(join(' ', @args));
  704.         return unless $o->assert(
  705.         $o->rep_isoff($rep),
  706.         "no such inactive repository '$rep'"
  707.         );
  708.         $o->rep_on($rep);
  709.         $o->cache_clear('search');
  710.     }
  711.     elsif (matches($cmd, 'of|f')) {
  712.         my $arg = join(' ', @args);
  713.         my $rep = $arg;
  714.         if ($arg =~ /^\d+$/) {
  715.         return unless $o->assert(
  716.             bounded(1, $arg, scalar @reps_on),
  717.             "no such active repository $arg"
  718.         );
  719.         $rep = $reps_on[$arg - 1];
  720.         }
  721.         else {
  722.         $rep = $o->rep_uniq($rep);
  723.         return unless $o->assert(
  724.             $o->rep_exists($rep),
  725.             "no such repository '$rep'"
  726.         );
  727.         }
  728.         $o->rep_off($rep);
  729.         $o->cache_clear('search');
  730.     }
  731.     elsif (matches($cmd, 'up')) {
  732.         my $arg = join(' ', @args);
  733.         my $rep = $arg;
  734.         if ($arg =~ /^\d+$/) {
  735.         return unless $o->assert(
  736.             bounded(1, $arg, scalar @reps_on),
  737.             "no such active repository $arg"
  738.         );
  739.         $rep = $reps_on[$arg - 1];
  740.         }
  741.         else {
  742.         $rep = $o->rep_uniq($rep);
  743.         return unless $o->assert(
  744.             $o->rep_exists($rep),
  745.             "no such repository '$rep'"
  746.         );
  747.         }
  748.         $o->rep_up($rep);
  749.     }
  750.     elsif (matches($cmd, 'do|wn')) {
  751.         my $arg = join(' ', @args);
  752.         my $rep = $arg;
  753.         if ($arg =~ /^\d+$/) {
  754.         return unless $o->assert(
  755.             bounded(1, $arg, scalar @reps_on),
  756.             "no such active repository $arg"
  757.         );
  758.         $rep = $reps_on[$arg - 1];
  759.         }
  760.         else {
  761.         $rep = $o->rep_uniq($rep);
  762.         return unless $o->assert(
  763.             $o->rep_exists($rep),
  764.             "no such repository '$rep'"
  765.         );
  766.         }
  767.         $o->rep_down($rep);
  768.     }
  769.  
  770.     else {
  771.         $o->warn(<<END) and return;
  772. No such repository command '$cmd'; see 'help repository'.
  773. END
  774.     }
  775.     }
  776.     &$refresh;
  777.     unless(@reps) {
  778.     $o->warn("No repositories. Use 'rep add' to add a repository.\n");
  779.     }
  780.     else {
  781.     my $i = 0;
  782.     my $count = @reps_on;
  783.     my $l = length($count);
  784.     $o->inform("Repositories:\n");
  785.     for my $r (@reps_on) {
  786.         my $n = sprintf("%${l}d", $i + 1);
  787.         $o->inform("[$n] $r\n");
  788.         $i++;
  789.     }
  790.     for my $r ($o->dictsort(@reps_off)) {
  791.         my $s = ' ' x $l;
  792.         $o->inform("[$s] $r\n");
  793.     }
  794.     }
  795.     1;
  796. }
  797.  
  798. #============================================================================
  799. # Search:
  800. # search        # displays previous searches
  801. # search <\d+>        # displays results of previous search
  802. # search <terms>    # executes a new search on the current repository
  803. #============================================================================
  804. sub smry_search { "searches for packages in a repository" }
  805. sub help_search { <<'END' }
  806.  
  807. END
  808. sub comp_search {()}
  809. sub run_search {
  810.     my $o = shift;
  811.     my @args = @_;
  812.     my $query = $o->raw_args || join ' ', @args;
  813.     trace(1, "PPM: search @args\n\tquery='$query'\n");
  814.     return unless $o->assert(
  815.     scalar $o->reps_on,
  816.     "you must activate a repository before searching."
  817.     );
  818.  
  819.     # No args: show cached result sets
  820.     unless (@args) {
  821.     my @search_results = $o->cache_sets('search');
  822.     my $search_result_current = $o->cache_set_current('search');
  823.     if (@search_results) {
  824.         $o->inform("Search Result Sets:\n");
  825.         my $i = 0;
  826.         for (@search_results) {
  827.         $o->informf("%s%2d",
  828.                $search_result_current == $i ? "*" : " ",
  829.                $i + 1);
  830.         $o->inform(". $_->{query}\n");
  831.         $i++;
  832.         }
  833.     }
  834.     else {
  835.         $o->warn("No search result sets -- provide a search term.\n");
  836.         return;
  837.     }
  838.     }
  839.  
  840.     # Args:
  841.     else {
  842.     # Show specified result set
  843.     if ($query =~ /^\d+/) {
  844.         my $set = int($query);
  845.         my $s = $o->cache_set('search', $set - 1);
  846.         unless ($set > 0 and defined $s) {
  847.         $o->warn("No such search result set '$set'.\n");
  848.         return;
  849.         }
  850.  
  851.         $query = $o->cache_set('search', $set-1, 'query');
  852.         $o->inform("Search Results Set $set ($query):\n");
  853.         $o->print_formatted($s, $o->cache_set_index('search'));
  854.         $o->cache_set_current('search', $set-1);
  855.         $o->cache_set_index('search', -1);
  856.     }
  857.        
  858.     # Query is the same as a previous query on the same repository: 
  859.     # Use cached results and set them as default
  860.     elsif(grep { $_->{query} eq $query } $o->cache_sets('search')) {
  861.         my @entries = $o->cache_sets('search');
  862.         for (my $i=0; $i<@entries; $i++) {
  863.         if ($o->cache_set('search', $i, 'query') eq $query) {
  864.             $o->inform("Using cached search result set ", $i+1, ".\n");
  865.             $o->cache_set_current('search', $i);
  866.             my $set = $o->cache_set('search');
  867.             $o->print_formatted($set);
  868.         }
  869.         }
  870.     }
  871.  
  872.     # Perform a new search
  873.     else {
  874.         my @rlist = $o->reps_on;
  875.         my $targ = $o->conf('target');
  876.         my $case = not $o->conf('case-sensitivity');
  877.  
  878.         $o->inform("Searching in Active Repositories\n");
  879.         my $ok = PPM::UI::search(\@rlist, $targ, $query, $case);
  880.         unless ($ok->is_success) {
  881.         $o->warn($ok->msg);
  882.         return unless $ok->ok;
  883.         }
  884.         my @matches = $ok->result_l;
  885.         unless (@matches) {
  886.         $o->warn("No matches for '$query'; see 'help search'.\n");
  887.         return 1;
  888.         }
  889.         $o->cache_set_index('search', -1);
  890.         $o->cache_set_add('search', $query, \@matches);
  891.         $o->cache_set_current('search', scalar($o->cache_sets('search')) - 1);
  892.         my @set = $o->cache_set('search');
  893.         $o->print_formatted(\@set);
  894.     }
  895.     }
  896.     1;
  897. }
  898. sub alias_search { qw(s) }
  899.  
  900. #============================================================================
  901. # tree
  902. # tree        # shows the dependency tree for the default/current pkg
  903. # tree <\d+>    # shows dep tree for numbered pkg in current search set
  904. # tree <pkg>    # shows dep tree for given package
  905. # tree <url>    # shows dep tree for package located at <url>
  906. # tree <glob>    # searches for matches
  907. #============================================================================
  908. sub smry_tree { "shows package dependency tree" }
  909. sub help_tree { <<'END' }
  910.  
  911. END
  912. sub comp_tree { goto &comp_describe }
  913. sub run_tree {
  914.     my $o = shift;
  915.     my @args = @_;
  916.     trace(1, "PPM: tree @args\n");
  917.  
  918.     # Check for anything that looks like a query. If it does, just
  919.     # send it to search() instead.
  920.     my $query = $o->raw_args || join ' ', @args;
  921.     $query ||= '';
  922.     if ($query and not PPM::UI::is_pkg($args[0]) and not parse_range($query)) {
  923.     $o->inform("Wildcards detected; using 'search' instead...\n");
  924.     return $o->run('search', @_);
  925.     }
  926.  
  927.     # No Args: describes current index of current result set, or 1.
  928.     unless (@args) {
  929.     my @search_results = $o->cache_sets('search');
  930.     my $search_result_current = $o->cache_set_current('search');
  931.     unless (@search_results and
  932.         bounded(0, $search_result_current, $#search_results)) {
  933.         $o->warn("No search results to show dependency tree for -- " . 
  934.           "use 'search' to find a package.\n");
  935.         return;
  936.     }
  937.     else {
  938.         my @res = $o->cache_set('search');
  939.         my $npkgs = @res;
  940.         $o->inform("$SEP\n");
  941.         if ($o->cache_entry('search')) {
  942.         my $n = $o->cache_set_index('search') + 1;
  943.         $o->inform("Package $n:\n");
  944.         $o->tree_pkg($o->cache_entry('search'));
  945.         }
  946.         elsif (defined $o->cache_entry('search', 0)) {
  947.         $o->inform("Package 1:\n");
  948.         $o->tree_pkg($o->cache_entry('search', 0));
  949.         $o->cache_set_index('search', 0);
  950.         }
  951.         else {
  952.         $o->inform("Search Results are empty -- use 'search' again.\n");
  953.         }
  954.         $o->inform("$SEP\n");
  955.     }
  956.     }
  957.  
  958.     # Args provided
  959.     else {
  960.  
  961.     # Describe a particular number:
  962.     if (my @r = parse_range(@args)) {
  963.         my @search_results = $o->cache_sets('search');
  964.         my $search_result_current = $o->cache_set_current('search');
  965.         unless (bounded(0, $search_result_current, $#search_results)) {
  966.         $o->inform("No search results to show dependency tree for -- " . 
  967.           "use 'search' to find a package.\n");
  968.         return;
  969.         }
  970.         else {
  971.         for my $n (@r) {
  972.             my $sr = $o->cache_set('search');
  973.             $o->inform("$SEP\n");
  974.             if (bounded(1, $n, scalar @$sr)) {
  975.             $o->inform("Package $n:\n");
  976.             $o->tree_pkg($o->cache_entry('search', $n-1));
  977.             }
  978.             else {
  979.             $o->inform("No such package $n in result set.\n");
  980.             }
  981.             $o->cache_set_index('search', $n - 1);
  982.         }
  983.         $o->inform("$SEP\n");
  984.         }
  985.     }
  986.  
  987.     # Describe a particular package
  988.     else {
  989.         return unless $o->assert(
  990.         scalar $o->reps_on,
  991.         "No repositories -- use 'rep add' to add a repository.\n"
  992.         );
  993.         my $pkg =
  994.           PPM::UI::describe([$o->reps_on], $o->conf('target'), $args[0]);
  995.         unless ($pkg->is_success) {
  996.         $o->warn($pkg->msg);
  997.         return unless $pkg->ok;
  998.         }
  999.         if ($pkg->ok) {
  1000.         $o->inform("$SEP\n");
  1001.         $o->tree_pkg($pkg->result);
  1002.         $o->inform("$SEP\n");
  1003.         }
  1004.     }
  1005.     }
  1006.     1;
  1007. }
  1008.  
  1009. #============================================================================
  1010. # Describe:
  1011. # des        # describes default or current package
  1012. # des <\d+>    # describes numbered package in the current search set
  1013. # des <pkg>    # describes the named package (bypasses cached results)
  1014. # des <url>    # describes the package located at <url>
  1015. #============================================================================
  1016. sub smry_describe { "describes packages in detail" }
  1017. sub help_describe { <<'END' }
  1018.  
  1019. END
  1020. sub comp_describe {
  1021.     my $o = shift;
  1022.     my ($word, $line, $start) = @_;
  1023.  
  1024.     # If no search results
  1025.     my $n_results = $o->cache_sets('search');
  1026.     my $n_current = $o->cache_set_current('search');
  1027.     return ()
  1028.       unless ($n_results and bounded(0, $n_current, $n_results - 1));
  1029.     my @words = $o->line_parsed($line);
  1030.  
  1031.     # If the previous word isn't a number or the command, stop.
  1032.     return ()
  1033.       if ($#words > 0 and
  1034.       $words[$#words] !~ /^\d+/ and
  1035.       $start == length($line) or 
  1036.       $#words > 1);
  1037.  
  1038.     # This is the most optimistic list:
  1039.     my @results = $o->cache_set('search');
  1040.     my $npkgs = @results;
  1041.     my @compls = (1 .. $npkgs);
  1042.  
  1043.     # If the previous word is a number, return only other numbers:
  1044.     return $o->completions($word, \@compls)
  1045.       if $words[$#words] =~ /^\d+/;
  1046.  
  1047.     # Either a number or the names of the packages
  1048.     push @compls, map { $_->name } @results;
  1049.     return $o->completions($word, \@compls);
  1050. }
  1051. sub run_describe {
  1052.     my $o = shift;
  1053.     my @args = @_;
  1054.     
  1055.     # Check for options:
  1056.     my $ppd;
  1057.     {
  1058.     local @ARGV = @args;
  1059.     GetOptions(ppd => \$ppd, dump => \$ppd);
  1060.     @args = @ARGV;
  1061.     }
  1062.  
  1063.     trace(1, "PPM: describe @args\n");
  1064.  
  1065.     # Check for anything that looks like a query. If it does, just
  1066.     # send it to search() instead.
  1067.     my $query = $o->raw_args || join ' ', @args;
  1068.     if ($query and not PPM::UI::is_pkg($args[0]) and not parse_range($query)) {
  1069.     $o->inform("Wildcards detected; using 'search' instead...\n");
  1070.     return $o->run('search', @_);
  1071.     }
  1072.  
  1073.     my $dumper = sub {
  1074.     my $o = shift;
  1075.     my $pkg_obj = shift;
  1076.     my $ppd = $pkg_obj->getppd($o->conf('target'))->result;
  1077.     $o->page($ppd);
  1078.     };
  1079.     my $displayer = $ppd ? $dumper : \&describe_pkg;
  1080.  
  1081.     # No Args: describes current index of current result set, or 1.
  1082.     unless (@args) {
  1083.     my @search_results = $o->cache_sets('search');
  1084.     my $search_result_current = $o->cache_set_current('search');
  1085.     unless (@search_results and
  1086.         bounded(0, $search_result_current, $#search_results)) {
  1087.         $o->warn("No search results to describe -- " . 
  1088.           "use 'search' to find a package.\n");
  1089.         return;
  1090.     }
  1091.     else {
  1092.         my @res = $o->cache_set('search');
  1093.         my $npkgs = @res;
  1094.         $o->inform("$SEP\n");
  1095.         if ($o->cache_entry('search')) {
  1096.         my $n = $o->cache_set_index('search') + 1;
  1097.         $o->inform("Package $n:\n");
  1098.         $o->$displayer($o->cache_entry('search'));
  1099.         }
  1100.         elsif (defined $o->cache_entry('search', 0)) {
  1101.         $o->inform("Package 1:\n");
  1102.         $o->$displayer($o->cache_entry('search', 0));
  1103.         $o->cache_set_index('search', 0);
  1104.         }
  1105.         else {
  1106.         $o->warn("Search Results are empty -- use 'search' again.\n");
  1107.         }
  1108.         $o->inform("$SEP\n");
  1109.     }
  1110.     }
  1111.  
  1112.     # Args provided
  1113.     else {
  1114.  
  1115.     # Describe a particular number:
  1116.     if (my @r = parse_range(@args)) {
  1117.         my @search_results = $o->cache_sets('search');
  1118.         my $search_result_current = $o->cache_set_current('search');
  1119.         unless (bounded(0, $search_result_current, $#search_results)) {
  1120.         $o->warn("No search results to describe -- " . 
  1121.           "use 'search' to find a package.\n");
  1122.         return;
  1123.         }
  1124.         else {
  1125.         for my $n (@r) {
  1126.             my $sr = $o->cache_set('search');
  1127.             $o->inform("$SEP\n");
  1128.             if (bounded(1, $n, scalar @$sr)) {
  1129.             $o->inform("Package $n:\n");
  1130.             $o->$displayer($o->cache_entry('search', $n-1));
  1131.             }
  1132.             else {
  1133.             $o->inform("No such package $n in result set.\n");
  1134.             }
  1135.             $o->cache_set_index('search', $n - 1);
  1136.         }
  1137.         $o->inform("$SEP\n");
  1138.         }
  1139.     }
  1140.  
  1141.     # Describe a particular package
  1142.     else {
  1143.         return unless $o->assert(
  1144.         scalar $o->reps_on,
  1145.         "No repositories -- use 'rep add' to add a repository.\n"
  1146.         );
  1147.         my ($set, $index) = $o->cache_find('search', $args[0]);
  1148.         my ($ok, $pkg);
  1149.         if ($index >= 0) {
  1150.         $o->cache_set_current('search', $set);
  1151.         $o->cache_set_index('search', $index);
  1152.         $pkg = $o->cache_entry('search');
  1153.         }
  1154.         else {
  1155.         $ok = PPM::UI::describe([$o->reps_on],
  1156.                     $o->conf('target'), $args[0]);
  1157.         unless ($ok->is_success) {
  1158.             $o->inform($ok->msg);
  1159.             return unless $ok->ok;
  1160.         }
  1161.         $pkg = $ok->result;
  1162.         $o->cache_set_add('search', $args[0], [$pkg]);
  1163.         my $last = $o->cache_sets('search') - 1;
  1164.         $o->cache_set_current('search', $last);
  1165.         $o->cache_set_index('search', 0);
  1166.         }
  1167.         $o->inform("$SEP\n");
  1168.         $o->$displayer($pkg);
  1169.         $o->inform("$SEP\n");
  1170.     }
  1171.     }
  1172.     1;
  1173. }
  1174.  
  1175. #============================================================================
  1176. # Install:
  1177. # i        # installs default or current package
  1178. # i <\d+>    # installs numbered package in current search set
  1179. # i <pkg>    # installs named package
  1180. # i <url>    # installs the package at <url>
  1181. #============================================================================
  1182. sub smry_install { "installs packages" }
  1183. sub help_install { <<'END' }
  1184.  
  1185. END
  1186. sub comp_install { goto &comp_describe }
  1187. sub run_install {
  1188.     my $o = shift;
  1189.     my @args = @_;
  1190.     trace(1, "PPM: install @args\n");
  1191.  
  1192.     # Get the install options
  1193.     my %opts = (
  1194.     force  => $o->conf('force-install'),
  1195.     follow => $o->conf('follow-install'),
  1196.     dryrun => 0,
  1197.     );
  1198.     {
  1199.     local @ARGV = @args;
  1200.     GetOptions('force!'  => \$opts{force},
  1201.            'follow!' => \$opts{follow},
  1202.            'dryrun'  => \$opts{dryrun},
  1203.           );
  1204.     @args = @ARGV;
  1205.     }
  1206.  
  1207.     # No Args -- installs default package
  1208.     unless (@args) {
  1209.     my @search_results = $o->cache_sets('search');
  1210.     my $search_result_current = $o->cache_set_current('search');
  1211.     unless (@search_results and
  1212.         bounded(0, $search_result_current, $#search_results)) {
  1213.         $o->warn("No search results to install -- " . 
  1214.           "use 'search' to find a package.\n");
  1215.         return;
  1216.     }
  1217.     else {
  1218.         my @results = $o->cache_set('search');
  1219.         my $npkgs = @results;
  1220.         my $pkg;
  1221.         if ($o->cache_entry('search')) {
  1222.         my $n = $o->cache_set_index('search') + 1;
  1223.         $o->inform("Package $n:\n");
  1224.         $pkg = $o->cache_entry('search');
  1225.         }
  1226.         else {
  1227.         $o->inform("Package 1:\n");
  1228.         $pkg = $o->cache_entry('search', 0);
  1229.         }
  1230.         return $o->install_pkg($pkg, \%opts);
  1231.     }
  1232.     }
  1233.  
  1234.     # Args provided
  1235.     else {
  1236.  
  1237.     # Install a particular number:
  1238.     if (my @r = parse_range(@args)) {
  1239.         my @search_results = $o->cache_sets('search');
  1240.         my $search_result_current = $o->cache_set_current('search');
  1241.         unless (@search_results and
  1242.             bounded(0, $search_result_current, $#search_results)) {
  1243.         $o->warn("No search results to install -- " . 
  1244.           "use 'search' to find a package.\n");
  1245.         return;
  1246.         }
  1247.         else {
  1248.         my $ok = 0;
  1249.         for my $n (@r) {
  1250.             my $sr = $o->cache_set('search');
  1251.             if (bounded(1, $n, scalar @$sr)) {
  1252.             $o->inform("Package $n:\n");
  1253.             my $pkg = $sr->[$n-1];
  1254.             $ok++ if $o->install_pkg($pkg, \%opts);
  1255.             }
  1256.             else {
  1257.             $o->inform("No such package $n in result set.\n");
  1258.             }
  1259.         }
  1260.         return unless $ok;
  1261.         }
  1262.     }
  1263.  
  1264.     # Install a particular package
  1265.     else {
  1266.         unless ($o->reps_all) {
  1267.         $o->warn("Can't install: no repositories defined.\n");
  1268.         }
  1269.         else {
  1270.         return $o->install_pkg($args[0], \%opts);
  1271.         }
  1272.         return;
  1273.     }
  1274.     }
  1275.     1;
  1276. }
  1277.  
  1278. #============================================================================
  1279. # Target:
  1280. # t        # displays a list of backend targets
  1281. # t [set] <\d+>    # sets numbered target as default backend target
  1282. # t des [<\d+>]    # describes the given (or default) target
  1283. #============================================================================
  1284. sub smry_targets { "views or sets target installer backends" }
  1285. sub help_targets { <<'END' }
  1286.  
  1287. END
  1288. sub comp_targets {
  1289.     my $o = shift;
  1290.     my ($word, $line, $start) = @_;
  1291.     my @words = $o->line_parsed($line);
  1292.     my $words = scalar @words;
  1293.     my @compls;
  1294.     my @targs = PPM::UI::target_list()->result_l;
  1295.  
  1296.     # only return 'set' and 'describe' when we're completing the second word
  1297.     if ($words == 1 or $words == 2 and $start != length($line)) {
  1298.     @compls = ('set', 'select', 'describe', 'rename', 1 .. scalar @targs);
  1299.     return $o->completions($word, \@compls);
  1300.     }
  1301.  
  1302.     if ($words == 2 or $words == 3 and $start != length($line)) {
  1303.     # complete 'set'
  1304.     if (matches($words[1], 's|et')) {
  1305.         my $targ = $o->conf('target');
  1306.         @compls = map { $_->[0] }
  1307.               grep { $_->[1] }
  1308.               PPM::UI::target_config_keys($targ)->result_l;
  1309.         return $o->completions($word, \@compls);
  1310.     }
  1311.     # complete 'describe' and 'rename'
  1312.     elsif (matches($words[1], 'd|escribe')
  1313.         or matches($words[1], 'r|ename')
  1314.         or matches($words[1], 's|elect')) {
  1315.         return $o->completions($word, [1 .. scalar @targs]);
  1316.     }
  1317.     }
  1318.     ();
  1319. }
  1320. sub run_targets {
  1321.     my $o = shift;
  1322.     my @args = @_;
  1323.     trace(1, "PPM: target @args\n");
  1324.  
  1325.     my @targets = PPM::UI::target_list()->result_l;
  1326.     my $targets = @targets;
  1327.  
  1328.     # No arguments: print targets
  1329.     if (@args) {
  1330.     my ($cmd, @rest) = @args;
  1331.     if ($cmd =~ /^\d+$/
  1332.         or matches($cmd, 'se|lect')) {
  1333.         my $num =     $cmd =~ /^\d+$/        ? $cmd        :
  1334.             $rest[0] =~ /^\d+$/    ? $rest[0]    :
  1335.             do {
  1336.                 my $n = find_index($rest[0], 1, @targets);
  1337.                 if ($n < 1) {
  1338.                 $o->warn("No such target '$rest[0]'.\n");
  1339.                 return;
  1340.                 }
  1341.                 $n;
  1342.             };
  1343.  
  1344.         # QA the number: is it too high/low?
  1345.         unless(bounded(1, $num, $targets)) {
  1346.         $o->warn("No such target number '$num'.\n");
  1347.         return;
  1348.         }
  1349.         else {
  1350.         $o->conf('target', $targets[$num-1]);
  1351.         $o->cache_clear('query');
  1352.         }
  1353.     }
  1354.     elsif (matches($cmd, 'r|ename')) {
  1355.         my ($oldnum, $newname) = @rest;
  1356.         $oldnum =    $oldnum =~ /^\d+$/ ? $oldnum :
  1357.             do {
  1358.                 my $n = find_index($oldnum, 1, @targets);
  1359.                 if ($n < 1) {
  1360.                 $o->warn("No such target '$oldnum'.\n");
  1361.                 return;
  1362.                 };
  1363.                 $n;
  1364.             };
  1365.         unless (defined $oldnum && $oldnum =~ /^\d+$/) {
  1366.         $o->warn(<<END);
  1367. target: '$cmd' requires a numeric argument. See 'help $cmd'.
  1368. END
  1369.         return;
  1370.         }
  1371.         unless (bounded(1, $oldnum, $targets)) {
  1372.         $o->warn("No such target number '$oldnum'.\n");
  1373.         return;
  1374.         }
  1375.         unless (defined $newname and $newname) {
  1376.         $newname = '' unless defined $newname;
  1377.         $o->warn(<<END);
  1378. Target names must be non-empty: '$newname' is not a valid name.
  1379. END
  1380.         return;
  1381.         }
  1382.         
  1383.         my $oldname = $targets[$oldnum - 1];
  1384.         my $ret = PPM::UI::target_rename($oldname, $newname);
  1385.         $o->warn($ret->msg) unless $ret->ok;
  1386.         $o->conf('target', $newname)
  1387.           if $o->conf('target') eq $oldname;
  1388.         @targets = PPM::UI::target_list()->result_l;
  1389.         $targets = scalar @targets;
  1390.     }
  1391.     elsif (matches($cmd, "s|et")) {
  1392.         my ($key, $value) = @rest;
  1393.         if (defined $key and $key =~ /=/ and not defined $value) {
  1394.         ($key, $value) = split /=/, $key;
  1395.         }
  1396.         unless(defined($key) && $key) {
  1397.         $o->warn(<<END);
  1398. You must specify what option to set. See 'help target'.
  1399. END
  1400.         return;
  1401.         }
  1402.         unless(defined($value)) {
  1403.         $o->warn(<<END);
  1404. You must provide a value for the option. See 'help target'.
  1405. END
  1406.         return;
  1407.         }
  1408.         my $targ = $o->conf('target');
  1409.         my %keys = map { @$_ }
  1410.                PPM::UI::target_config_keys($targ)->result_l;
  1411.         unless ($keys{$key}) {
  1412.         $o->warn("Invalid set key '$key'; these are the settable values:\n");
  1413.         $o->warn("    $_\n") for (grep { $keys{$_} } keys %keys);
  1414.         return;
  1415.         }
  1416.         my $ok = PPM::UI::target_config_set($targ, $key, $value);
  1417.         unless ($ok->is_success) {
  1418.         $o->warn($ok->msg);
  1419.         return unless $ok->ok;
  1420.         }
  1421.         $o->inform("Target attribute '$key' set to '$value'\n");
  1422.         return 1;
  1423.     }
  1424.     elsif (matches($cmd, "d|escribe")) {
  1425.         my %opts = (exec => 1);
  1426.         my $sel;
  1427.         if (@rest) {
  1428.         local @ARGV = @rest;
  1429.         GetOptions(\%opts, 'exec!');
  1430.         @rest = @ARGV;
  1431.         }
  1432.         if (@rest) {
  1433.         $sel =    $rest[0] =~ /^\d+$/ ? $rest[0] :
  1434.                 do {
  1435.                 my $n = find_index($rest[0], 1, @targets);
  1436.                 if ($n < 1) {
  1437.                     $o->warn("No such target '$rest[0]'.\n");
  1438.                     return;
  1439.                 };
  1440.                 $n;
  1441.                 };
  1442.         unless(bounded(1, $sel, $targets)) {
  1443.             $o->warn("No such target number '$sel'.\n");
  1444.         }
  1445.         }
  1446.         else {
  1447.         $sel = find_index($o->conf('target'), 1, @targets);
  1448.         }
  1449.         my $targ = $targets[$sel-1];
  1450.         my (@keys, @vals);
  1451.         my $res = $opts{exec}
  1452.         ? PPM::UI::target_info($targ)
  1453.         : PPM::UI::target_raw_info($targ);
  1454.         unless ($res->is_success) {
  1455.         $o->warn($res->msg);
  1456.         return unless $res->ok;
  1457.         }
  1458.         my %h = $res->result_h;
  1459.         my @h = sort keys %h;
  1460.         push @keys, @h;
  1461.         push @vals, $h{$_} for @h;
  1462.         if ($opts{exec}) {
  1463.         for (PPM::UI::target_config_info($targ)->result_l) {
  1464.             push @keys, $_->[0];
  1465.             push @vals, $_->[1];
  1466.         }
  1467.         }
  1468.         $_ = ucfirst $_ for @keys;
  1469.         $o->inform("Describing target $sel ($targ):\n");
  1470.         $o->print_pairs(\@keys, \@vals);
  1471.         return 1;
  1472.     }
  1473.     }
  1474.     unless($targets) {
  1475.     $o->warn("No targets. Install a PPM target.\n");
  1476.     return;
  1477.     }
  1478.     else {
  1479.     $o->conf('target', $targets[0])
  1480.         unless $o->conf('target');
  1481.     my $i = 0;
  1482.     $o->inform("Targets:\n");
  1483.     for (@targets) {
  1484.         $o->informf(
  1485.         "%s%2d",
  1486.         $o->conf('target') eq $targets[$i] ? "*" : " ",
  1487.         $i + 1
  1488.         );
  1489.         $o->inform(". $_\n");
  1490.         $i++;
  1491.     }
  1492.     }
  1493.     1;
  1494. }
  1495.  
  1496. #============================================================================
  1497. # Query:
  1498. # query        # displays list of previous queries
  1499. # query <\d+>    # displays results of previous query
  1500. # query <terms>    # performs a new query and displays results
  1501. #============================================================================
  1502. sub smry_query { "queries installed packages" }
  1503. sub help_query { <<'END' }
  1504.  
  1505. END
  1506. sub comp_query {()}
  1507. sub run_query {
  1508.     my $o = shift;
  1509.     my $query = $o->raw_args || join ' ', @_;
  1510.     trace(1, "PPM: query @_\n\tquery='$query'\n");
  1511.     my @targets = PPM::UI::target_list()->result_l;
  1512.     my $target = $o->conf('target');
  1513.     my $case = not $o->conf('case-sensitivity');
  1514.     $o->warn("You must install an installation target before using PPM.\n")
  1515.       and return unless @targets;
  1516.  
  1517.     # No args: show cached query sets
  1518.     unless ($query =~ /\S/) {
  1519.     my @query_results = $o->cache_sets('query');
  1520.     my $query_result_current = $o->cache_set_current('query');
  1521.     if (@query_results) {
  1522.         $o->inform("Query Result Sets:\n");
  1523.         my $i = 0;
  1524.         for (@query_results) {
  1525.         $o->informf("%s%2d",
  1526.                $query_result_current == $i ? "*" : " ",
  1527.                $i + 1);
  1528.         $o->inform(". $_->{query}\n");
  1529.         $i++;
  1530.         }
  1531.     }
  1532.     else {
  1533.         $o->warn("No query result sets -- provide a query term.\n");
  1534.         return;
  1535.     }
  1536.     }
  1537.  
  1538.     # Args:
  1539.     else {
  1540.     # Show specified result set 
  1541.     if ($query =~ /^\d+/) {
  1542.         my $set = int($query);
  1543.         unless (defined $o->cache_set('query', $set-1)) {
  1544.         $o->warn("No such query result set '$set'.\n");
  1545.         return;
  1546.         }
  1547.  
  1548.         $query = $o->cache_set('query', $set-1, 'query');
  1549.         $o->inform("Query Results Set $set ($query):\n");
  1550.         $o->print_formatted([$o->cache_set('query', $set-1)],
  1551.                 $o->cache_set_index('query'));
  1552.                 
  1553.         $o->cache_set_current('query', $set-1);
  1554.         $o->cache_set_index('query', -1);
  1555.     }
  1556.  
  1557.     # Query is the same a a previous query on the same target:
  1558.     # Use cached results and set them as default
  1559.     elsif (grep { $_->{query} eq $query } $o->cache_sets('query')) {
  1560.         for (my $i=0; $i<$o->cache_sets('query'); $i++) {
  1561.         if ($o->cache_set('query', $i, 'query') eq $query) {
  1562.             $o->inform("Using cached query result set ", $i+1, ".\n");
  1563.             $o->cache_set_current('query', $i);
  1564.             my $set = $o->cache_set('query');
  1565.             $o->print_formatted($set);
  1566.         }
  1567.         }
  1568.     }
  1569.  
  1570.     # Perform a new query.
  1571.     else {
  1572.         my $num = find_index($target, 1, @targets);
  1573.         $o->inform("Querying target $num (");
  1574.         if (length($target) > 30) {
  1575.         $o->inform(substr($target, 0, 30), "...");
  1576.         }
  1577.         else {
  1578.         $o->inform($target);
  1579.         }
  1580.         $o->inform(")\n");
  1581.  
  1582.         my $res = PPM::UI::query($target, $query, $case);
  1583.         unless ($res->ok) {
  1584.         $o->inform($res->msg);
  1585.         return;
  1586.         }
  1587.         my @matches = $res->result_l;
  1588.         if (@matches) {
  1589.         $o->cache_set_add('query', $query, \@matches);
  1590.         $o->cache_set_current('query', scalar($o->cache_sets('query')) - 1);
  1591.         my @set = $o->cache_set('query');
  1592.         $o->print_formatted(\@set);
  1593.         }
  1594.         else {
  1595.         $o->warn("No matches for '$query'; see 'help query'.\n");
  1596.         }
  1597.     }
  1598.     }
  1599.     1;
  1600. }
  1601.  
  1602. #============================================================================
  1603. # Properties:
  1604. # prop        # describes default installed package
  1605. # prop <\d+>    # describes numbered installed package
  1606. # prop <pkg>    # describes named installed package
  1607. # prop <url>    # describes installed package at location <url>
  1608. #============================================================================
  1609. sub smry_properties { "describes installed packages in detail" }
  1610. sub help_properties { <<'END' }
  1611.  
  1612. END
  1613. sub comp_properties {
  1614.     my $o = shift;
  1615.     my ($word, $line, $start) = @_;
  1616.  
  1617.     # If no query results
  1618.     my $n_results = scalar $o->cache_sets('query');
  1619.     my $n_current = $o->cache_set_current('query');
  1620.     unless ($n_results and bounded(0, $n_current, $n_results - 1)) {
  1621.     my $targ = $o->conf('target') or return ();
  1622.     my $r = PPM::UI::query($targ, '*');
  1623.     return () unless $r->ok;
  1624.     $o->cache_set_add('query', '*', $r->result);
  1625.     $o->cache_set_current('query', scalar($o->cache_sets('query')) - 1);
  1626.     }
  1627.     my @words = $o->line_parsed($line);
  1628.  
  1629.     # If the previous word isn't a number or the command, stop.
  1630.     return ()
  1631.       if ($#words > 0 and
  1632.       $words[$#words] !~ /^\d+/ and
  1633.       $start == length($line) or 
  1634.       $#words > 1);
  1635.  
  1636.     # This is the most optimistic list:
  1637.     my @results = $o->cache_set('query');
  1638.     my $npkgs = @results;
  1639.     my @compls = (1 .. $npkgs);
  1640.  
  1641.     # If the previous word is a number, return only other numbers:
  1642.     return $o->completions($word, \@compls)
  1643.       if ($words[$#words] =~ /^\d+/);
  1644.  
  1645.     # Either a number or the names of the packages
  1646.     push @compls, map { $_->name } @results;
  1647.     return $o->completions($word, \@compls);
  1648. }
  1649. sub run_properties {
  1650.     my $o = shift;
  1651.     my @args = @_;
  1652.     my $args = $args[0];
  1653.     trace(1, "PPM: properties @args\n");
  1654.  
  1655.     # Check for anything that looks like a query. If it does, send it
  1656.     # to query instead.
  1657.     my $query = $o->raw_args || join ' ', @args;
  1658.     $query ||= '';
  1659.     if ($query and not PPM::UI::is_pkg($args[0]) and not parse_range($query)) {
  1660.     $o->inform("Wildcards detected; using 'query' instead.\n");
  1661.     return $o->run('query', @_);
  1662.     }
  1663.     
  1664.     # No Args: describes current index of current result set, or 1.
  1665.     my $n_results = $o->cache_sets('query');
  1666.     my $n_current = $o->cache_set_current('query');
  1667.     my $ind = $o->cache_set_index('query');
  1668.     unless (@args) {
  1669.     unless ($n_results and bounded(0, $n_current, $n_results - 1)) {
  1670.         $o->inform("No query results to describe -- " . 
  1671.           "use 'query' to find a package.\n");
  1672.         return;
  1673.     }
  1674.     else {
  1675.         my @results = $o->cache_set('query');
  1676.         my $npkgs = @results;
  1677.         $o->inform("$SEP\n");
  1678.         if (bounded(0, $ind, $npkgs-1)) {
  1679.         my $n = $ind + 1;
  1680.         $o->inform("Package $n:\n");
  1681.         $o->describe_pkg($o->cache_entry('query', $ind));
  1682.         }
  1683.         else {
  1684.         $o->inform("Package 1:\n");
  1685.         $o->describe_pkg($results[0]);
  1686.         $o->cache_set_index('query', 0);
  1687.         }
  1688.         $o->inform("$SEP\n");
  1689.     }
  1690.     }
  1691.  
  1692.     # Args provided
  1693.     else {
  1694.  
  1695.     # Describe a particular number:
  1696.     if (my @r = parse_range(@args)) {
  1697.         unless ($n_results and bounded(0, $n_current, $n_results - 1)) {
  1698.         $o->inform("No query results to describe -- " . 
  1699.           "use 'query' to find a package.\n");
  1700.         return;
  1701.         }
  1702.         else {
  1703.         for my $n (@r) {
  1704.             my @results = $o->cache_set('query');
  1705.             my $npkgs = @results;
  1706.             $o->inform("$SEP\n");
  1707.             if (bounded(1, $n, $npkgs)) {
  1708.             $o->inform("Package $n:\n");
  1709.             $o->cache_set_index('query', $n-1);
  1710.             my $old = $o->cache_entry('query');
  1711.             my $prop =
  1712.               PPM::UI::properties($o->conf('target'), $old->name);
  1713.             unless ($prop->is_success) {
  1714.                 $o->warn($prop->msg);
  1715.                 next unless $prop->ok;
  1716.             }
  1717.             my ($pkg, $idate, $loc) = $prop->result_l;
  1718.             $o->describe_pkg($pkg,
  1719.                      [qw(InstDate Location)],
  1720.                      [$idate, $loc],
  1721.                     );
  1722.             }
  1723.             else {
  1724.             $o->inform("No such package $n in result set.\n");
  1725.             }
  1726.         }
  1727.         $o->inform("$SEP\n");
  1728.         }
  1729.     }
  1730.  
  1731.     # Query a particular package
  1732.     else {
  1733.         if ($o->conf('target')) {
  1734.         my $prop =
  1735.           PPM::UI::properties($o->conf('target'), $args);
  1736.         unless ($prop->is_success) {
  1737.             $o->warn($prop->msg);
  1738.             return unless $prop->ok;
  1739.         }
  1740.         my ($pkg, $idate, $loc) = $prop->result_l;
  1741.         my ($s, $index) = $o->cache_find('query', $args);
  1742.         $o->inform("$SEP\n") if $pkg;
  1743.         $o->describe_pkg($pkg,
  1744.                  [qw(InstDate Location)],
  1745.                  [$idate, $loc],
  1746.                 )
  1747.           if $pkg;
  1748.         $o->inform("$SEP\n") if $pkg;
  1749.         if ($index >= 0) {
  1750.             $o->cache_set_current('query', $s);
  1751.             $o->cache_set_index('query', $index);
  1752.         }
  1753.         elsif ($pkg) {
  1754.             $o->cache_set_add('query', $args[0], [$pkg]);
  1755.             my $last = $o->cache_sets('query') - 1;
  1756.             $o->cache_set_current('query', $last);
  1757.             $o->cache_set_index('query', 0);
  1758.         }
  1759.         $o->warn("Package '$args' not found; 'query' for it first.\n")
  1760.           and return unless $pkg;
  1761.         }
  1762.         else {
  1763.         # XXX: Change this output.
  1764.         $o->warn(
  1765.             "There are no targets installed.\n"
  1766.         );
  1767.         return;
  1768.         }
  1769.     }
  1770.     }
  1771.     1;
  1772. }
  1773.  
  1774. #============================================================================
  1775. # Uninstall:
  1776. # uninst    # removes default installed package
  1777. # uninst <\d+>    # removes specified package
  1778. # uninst <pkg>    # removes specified package
  1779. # uninst <url>    # removes the package located at <url>
  1780. #============================================================================
  1781. sub smry_uninstall { "uninstalls packages" }
  1782. sub help_uninstall { <<'END' }
  1783.  
  1784. END
  1785. sub comp_uninstall { goto &comp_properties; }
  1786. sub run_uninstall {
  1787.     my $o = shift;
  1788.     my @args = @_;
  1789.     trace(1, "PPM: uninstall @args\n");
  1790.  
  1791.     # Get the force option:
  1792.     my ($force);
  1793.     {
  1794.     local @ARGV = @args;
  1795.     GetOptions(
  1796.         'force!' => \$force,
  1797.     );
  1798.     @args = @ARGV;
  1799.     }
  1800.     
  1801.     my $args = $args[0];
  1802.  
  1803.     # No Args -- removes default package
  1804.     my $n_results = $o->cache_sets('query');
  1805.     my $n_current = $o->cache_set_current('query');
  1806.     my $ind = $o->cache_set_index('query');
  1807.     unless (@args) {
  1808.     unless ($n_results and bounded(0, $n_current, $n_results - 1)) {
  1809.         $o->warn("No query results to uninstall -- " . 
  1810.           "use 'query' to find a package.\n");
  1811.         return;
  1812.     }
  1813.     else {
  1814.         my @results = $o->cache_set('query');
  1815.         if (bounded(0, $ind, $#results)) {
  1816.         my $n = $ind + 1;
  1817.         $o->inform("Package $n:\n");
  1818.         $o->remove_pkg($o->cache_entry('query', $ind)->name, $force);
  1819.         }
  1820.         else {
  1821.         $o->inform("Package 1:\n");
  1822.         $o->remove_pkg($o->cache_entry('query', 0)->name, $force);
  1823.         }
  1824.     }
  1825.     }
  1826.  
  1827.     # Args provided
  1828.     else {
  1829.     # Uninstall a particular number:
  1830.     if (my @r = parse_range(@args)) {
  1831.         unless ($n_results and bounded(0, $n_current, $n_results - 1)) {
  1832.         $o->warn("No query results to uninstall -- " . 
  1833.           "use 'query' to find a package.\n");
  1834.         return;
  1835.         }
  1836.         else {
  1837.         my @results = $o->cache_set('query');
  1838.         my $npkgs = @results;
  1839.         my $ok = 0;
  1840.         for my $n (@r) {
  1841.             if (bounded(1, $n, $npkgs)) {
  1842.             $o->inform("Package $n:\n");
  1843.             $ok |=
  1844.               $o->remove_pkg($o->cache_entry('query', $n-1)->name,
  1845.                      $force, 1);
  1846.             }
  1847.             else {
  1848.             $o->warn("No such package $n in result set.\n");
  1849.             }
  1850.         }
  1851.         $o->cache_clear('query') if $ok;
  1852.         }
  1853.     }
  1854.  
  1855.     # Uninstall a particular package
  1856.     else {
  1857.         if ($o->conf('target')) {
  1858.         $o->remove_pkg($_, $force) for @args;
  1859.         }
  1860.         else {
  1861.         print
  1862.           "No targets -- use 'rep add' to add a target.\n";
  1863.         return;
  1864.         }
  1865.     }
  1866.     }
  1867.     1;
  1868. }
  1869. sub alias_uninstall { qw(remove) }
  1870.  
  1871. #============================================================================
  1872. # Settings:
  1873. #============================================================================
  1874. my (%lib_keys, @ui_keys);
  1875. my (@path_keys, @boolean_keys, @integer_keys);
  1876. my (%cache_clear_keys);
  1877. BEGIN {
  1878.     %lib_keys = ('download-chunksize' => 'downloadbytes',
  1879.         'tempdir' => 'tempdir',
  1880.         'rebuild-html' => 'rebuildhtml',
  1881.         'trace-file' => 'tracefile',
  1882.         'trace-level' => 'tracelvl',
  1883.         'profile-track' => 'profile_enable',
  1884.         );
  1885.     @ui_keys = qw(
  1886.     case-sensitivity
  1887.     pager
  1888.     fields
  1889.     follow-install
  1890.     force-install
  1891.     prompt-context
  1892.     prompt-slotsize
  1893.     prompt-verbose
  1894.     sort-field
  1895.     verbose-startup
  1896.  
  1897.     install-verbose
  1898.     upgrade-verbose
  1899.     remove-verbose
  1900.     );
  1901.     @boolean_keys = qw(case-sensitivity force-install follow-install
  1902.                prompt-context prompt-verbose profile-track
  1903.                verbose-startup install-verbose upgrade-verbose
  1904.                remove-verbose rebuild-html
  1905.               );
  1906.     @integer_keys = qw(download-chunksize prompt-slotsize trace-level);
  1907.     @path_keys = qw(tempdir pager trace-file);
  1908.     @cache_clear_keys{qw/
  1909.     case-sensitivity
  1910.     /} = ();
  1911. }
  1912. sub settings_getkeys {
  1913.     my $o = shift;
  1914.     my @keys = @ui_keys;
  1915.     push @keys, keys %lib_keys;
  1916.     @keys;
  1917. }
  1918. sub settings_getvals {
  1919.     my $o = shift;
  1920.     my @vals;
  1921.     push @vals, $o->settings_getkey($_) for $o->settings_getkeys;
  1922.     @vals;
  1923. }
  1924.  
  1925. sub conf {
  1926.     my $o   = shift;
  1927.     my $key = shift;
  1928.     my $val = shift;
  1929.     my $un  = shift;
  1930.     return $o->settings_setkey($key, $val, $un) if defined $val;
  1931.     return $o->settings_getkey($key);
  1932. }
  1933.  
  1934. sub settings_getkey {
  1935.     my $o = shift;
  1936.     my $key = shift;
  1937.     return PPM::UI::config_get($lib_keys{$key})->result if $lib_keys{$key};
  1938.     return $o->{SHELL}{conf}{DATA}{$key};
  1939. }
  1940. sub settings_setkey {
  1941.     my $o = shift;
  1942.     my ($key, $val, $un) = @_;
  1943.     if (grep { $key eq $_ } @boolean_keys) {
  1944.     $val = 0 if $un;
  1945.     unless ($val =~ /^\d+$/ && ($val == 0 || $val == 1)) {
  1946.         $o->warn(<<END);
  1947. Setting '$key' must be boolean: '0' or '1'. See 'help settings'.
  1948. END
  1949.         return;
  1950.     }
  1951.     }
  1952.     elsif (grep { $key eq $_ } @integer_keys) {
  1953.     $val = 0 if $un;
  1954.     unless ($val =~ /^\d+$/) {
  1955.         $o->warn(<<END);
  1956. Setting '$key' must be numeric. See 'help settings'.
  1957. END
  1958.         return;
  1959.     }
  1960.     }
  1961.     elsif ($key eq 'sort-field') {
  1962.     $val = 'name' if $un;
  1963.     my @fields = sort_fields();
  1964.     unless (grep { lc($val) eq $_ } @fields) {
  1965.         $o->warn(<<END);
  1966. Error setting '$key' to '$val': should be one of:
  1967. @fields.
  1968. END
  1969.         return;
  1970.     }
  1971.     else {
  1972.         $val = lc($val);
  1973.         $o->cache_set_index('search', -1); # invalidates current indices.
  1974.         $o->cache_set_index('query', -1);
  1975.     }
  1976.     }
  1977.     elsif ($key eq 'fields') {
  1978.     $val = 'name version abstract' if $un;
  1979.     my @fields = sort_fields();
  1980.     my @vals = split ' ', $val;
  1981.     for my $v (@vals) {
  1982.         unless (grep { lc $v eq lc $_ } @fields) {
  1983.         $o->warn(<<END);
  1984. Error adding field '$v': should be one of:
  1985. @fields.
  1986. END
  1987.         return;
  1988.         }
  1989.     }
  1990.     $val = lc $val;
  1991.     }
  1992.  
  1993.     if ($un and $key eq 'tempdir') {
  1994.     $o->warn("Can't unset 'tempdir': use 'set' instead.\n");
  1995.     return;
  1996.     }
  1997.  
  1998.     # Check for any cache-clearing that needs to happen:
  1999.     if (exists $cache_clear_keys{$key}) {
  2000.     $o->cache_clear('search');
  2001.     $o->cache_clear('query');
  2002.     }
  2003.  
  2004.     if ($lib_keys{$key}) { PPM::UI::config_set($lib_keys{$key}, $val) }
  2005.     else {
  2006.     $o->{SHELL}{conf}{DATA}{$key} = $val;
  2007.     $o->{SHELL}{conf}->save;
  2008.     }
  2009.     $o->inform(<<END);
  2010. Setting '$key' set to '$val'.
  2011. END
  2012. }
  2013.  
  2014. sub smry_settings { "view or set PPM options" }
  2015. sub help_settings { <<'END' }
  2016.  
  2017. END
  2018. sub comp_settings {
  2019.     my $o = shift;
  2020.     my ($word, $line, $start) = @_;
  2021.     my @words = $o->line_parsed($line);
  2022.  
  2023.     # To please the users of Bash, we'll allow 'set foo=bar' to work as well,
  2024.     # since it's really easy to do:
  2025.     if (defined $words[1] and $words[1] =~ /=/ and not defined $words[2]) {
  2026.     my @kv = split '=', $words[1];
  2027.     splice(@words, 1, 1, @kv);
  2028.     }
  2029.     my $words = @words;
  2030.     my @compls;
  2031.  
  2032.     # return the keys when we're completing the second word
  2033.     if ($words == 1 or $words == 2 and $start != length($line)) {
  2034.     @compls = $o->settings_getkeys();
  2035.     return $o->completions($word, \@compls);
  2036.     }
  2037.  
  2038.     # Return no completions for 'unset'.
  2039.     return () if matches($o->{API}{cmd}{run}{name}, 'u|nset');
  2040.  
  2041.     # provide intelligent completion for arguments:
  2042.     if ($words ==2 or $words == 3 and $start != length($line)) {
  2043.     # Completion for boolean values:
  2044.     my @bool = $o->completions($words[1], \@boolean_keys);
  2045.     my @path = $o->completions($words[1], \@path_keys);
  2046.     if (@bool == 1) {
  2047.         return $o->completions($word, [0, 1]);
  2048.     }
  2049.     elsif (@path == 1) {
  2050.         @compls = readline::rl_filename_list($word);
  2051.         return $o->completions($word, \@compls);
  2052.     }
  2053.     elsif (matches($words[1], 's|ort-field')) {
  2054.         @compls = sort_fields();
  2055.         return $o->completions(lc($word), \@compls);
  2056.     }
  2057.     }
  2058.  
  2059.     # Don't complete for anything else.
  2060.     ()
  2061. }
  2062. sub run_settings {
  2063.     my $o = shift;
  2064.     my @args = @_;
  2065.     my $key = $args[0];
  2066.     my $val = $args[1];
  2067.  
  2068.     # To please the users of Bash, we'll allow 'set foo=bar' to work as well,
  2069.     # since it's really easy to do:
  2070.     if (defined $key and $key =~ /=/ and not defined $val) {
  2071.     ($key, $val) = split '=', $key;
  2072.     }
  2073.  
  2074.     trace(1, "PPM: settings @args\n");
  2075.     my $unset = matches($o->{API}{cmd}{run}{name}, 'u|nset');
  2076.     my @stuff = $o->completions($key, [$o->settings_getkeys()])
  2077.       if $key;
  2078.     my $fullkey = $stuff[0] if @stuff == 1;
  2079.     if (defined $key and defined $val) {
  2080.     # validate the key:
  2081.     unless ($fullkey) {
  2082.         $key = '' unless defined $key;
  2083.         $o->warn("Unknown or ambiguous setting '$key'. See 'help settings'.\n");
  2084.         return;
  2085.     }
  2086.     $o->conf($fullkey, $val, $unset);
  2087.     }
  2088.     elsif (defined $key) {
  2089.     unless ($fullkey) {
  2090.         $key = '' unless defined $key;
  2091.         $o->warn("Unknown or ambiguous setting '$key'. See 'help settings'.\n");
  2092.         return;
  2093.     }
  2094.     if ($unset) {
  2095.         $o->conf($fullkey, '', $unset);
  2096.     }
  2097.     else {
  2098.         my $val = $o->conf($fullkey);
  2099.         $o->print_pairs([$fullkey], [$val]);
  2100.     }
  2101.     }
  2102.     else {
  2103.     my (@keys, @vals);
  2104.     @keys = $o->settings_getkeys();
  2105.     @vals = $o->settings_getvals();
  2106.     my %k;
  2107.     @k{@keys} = @vals;
  2108.     @keys = sort keys %k;
  2109.     @vals = map { $k{$_} } @keys;
  2110.     $o->print_pairs(\@keys, \@vals);
  2111.     }
  2112. }
  2113. sub alias_settings { qw(unset) }
  2114.  
  2115. sub help_help { <<'END' }
  2116.  
  2117. END
  2118.  
  2119. #============================================================================
  2120. # Version:
  2121. #============================================================================
  2122. sub smry_version { "displays the PPM version ($VERSION)" }
  2123. sub help_version { <<'END' }
  2124.  
  2125. END
  2126. sub comp_version {()}
  2127. sub run_version {
  2128.     my $o = shift;
  2129.     if ($o->mode eq 'SHELL') {
  2130.     $o->inform("$NAME version $VERSION\n");
  2131.     }
  2132.     else {
  2133.     $o->inform("$SHORT_NAME $VERSION\n");
  2134.     }
  2135.     1;
  2136. }
  2137.  
  2138. #============================================================================
  2139. # Exit:
  2140. #============================================================================
  2141. sub help_exit { <<'END' }
  2142.  
  2143. END
  2144. sub comp_exit {
  2145.     my $o = shift;
  2146.     return &comp_query
  2147.     if $o->{API}{cmd}{run}{name} eq 'q' and @_;
  2148.     ();
  2149. }
  2150. sub run_exit {
  2151.     my $o = shift;
  2152.     # Special case: 'q' with no arguments should mean 'quit', but 'q' with
  2153.     # arguments should mean 'query'.
  2154.     if ($o->{API}{cmd}{run}{name} eq 'q' and @_) {
  2155.     return $o->run('query', @_);
  2156.     }
  2157.     $o->stoploop;
  2158. }
  2159. sub alias_exit { qw(quit q) }
  2160.  
  2161. #============================================================================
  2162. # Upgrade
  2163. # upgrade    # lists upgrades available
  2164. # upgrade <\d+> # lists upgrades for specified package
  2165. # upgrade<pkg>    # lists upgrades for named package
  2166. #============================================================================
  2167. sub smry_upgrade { "shows availables upgrades for installed packages" }
  2168. sub help_upgrade { <<'END' }
  2169.  
  2170. END
  2171. sub comp_upgrade { goto &comp_properties; }
  2172. sub run_upgrade {
  2173.     my $o = shift;
  2174.     my @args = @_;
  2175.     trace(1, "PPM: upgrade @args\n");
  2176.  
  2177.     # Get options:
  2178.     my %opts = (
  2179.     install => 0,
  2180.     doprecious => 0,
  2181.     dryrun => 0,
  2182.     force => $o->conf('force-install'),
  2183.     follow => $o->conf('follow-install'),
  2184.     );
  2185.     {
  2186.     local @ARGV = @args;
  2187.     GetOptions(install => \$opts{install},
  2188.            precious => \$opts{doprecious},
  2189.            'force!' => \$opts{force},
  2190.            'follow!' => \$opts{follow},
  2191.            dryrun => \$opts{dryrun},
  2192.           );
  2193.     @args = @ARGV;
  2194.     }
  2195.  
  2196.     my $rlist = [$o->reps_on];
  2197.     my $targ  = $o->conf('target');
  2198.     my @pkgs;
  2199.  
  2200.     # Allow 'upgrade *';
  2201.     @args = grep { $_ ne '*' } @args;
  2202.  
  2203.     # List upgrades for a particular package
  2204.     if (@args) {
  2205.     my $pkg = $args[0];
  2206.     my @n = parse_range($o->raw_args);
  2207.     for my $n (@n) {
  2208.         my $ppd = $o->cache_entry('query', $n-1);
  2209.         unless($ppd) {
  2210.         $o->warn("No such query result '$pkg' in result set.\n");
  2211.         return;
  2212.         }
  2213.         else {
  2214.         push @pkgs, $ppd;
  2215.         }
  2216.     }
  2217.  
  2218.     # The name of the package:
  2219.     unless (@n) {
  2220.         my $ppd = PPM::UI::properties($o->conf('target'), $pkg);
  2221.         unless ($ppd->is_success) {
  2222.         $o->warn($ppd->msg);
  2223.         return unless $ppd->ok;
  2224.         }
  2225.         my $real_ppd = ($ppd->result_l)[0];
  2226.         push @pkgs, $real_ppd;
  2227.     }
  2228.     }
  2229.     # List upgrades for all packages
  2230.     else {
  2231.     @pkgs = PPM::UI::query($targ, '*', 0)->result_l;
  2232.     @pkgs = $o->sort_pkgs($o->conf('sort-field'), @pkgs);
  2233.     }
  2234.  
  2235.     my $verify = PPM::UI::verify_pkgs($rlist, $targ, @pkgs);
  2236.     unless ($verify->is_success) {
  2237.     $o->error("Error verifying packages: ", $verify->msg_raw, "\n");
  2238.     return;
  2239.     }
  2240.     my %bypackage;
  2241.     for my $result ($verify->result_l) {
  2242.     next unless $result->is_success; # ignore unfound packages
  2243.     my ($uptodate, $server_pkg, $inst_pkg, $b, $p) = $result->result_l;
  2244.     my $name = $server_pkg->name;
  2245.     my $nver = $server_pkg->version;
  2246.     my $over = $inst_pkg->version;
  2247.     my $repo = $server_pkg->repository->name;
  2248.     $bypackage{$name}{$repo} = {
  2249.         uptodate => $uptodate,
  2250.         oldver => $over,
  2251.         newver => $nver,
  2252.         repo => $repo,
  2253.         bundled => $b,
  2254.         precious => $p,
  2255.         pkg => $server_pkg,
  2256.     };
  2257.     }
  2258.     for my $pkg (sort keys %bypackage) {
  2259.     my $default;
  2260.     my @updates;
  2261.     my $p = $bypackage{$pkg};
  2262.     for my $rep (sort { $p->{$b}{newver} cmp $p->{$a}{newver} } keys %$p) {
  2263.         my $tmp = $default = $p->{$rep};
  2264.         push @updates, [@$tmp{qw(oldver newver repo)}] unless $tmp->{uptodate};
  2265.     }
  2266.     my $upgrade = $opts{install} ? 1 : 0;
  2267.         for (@updates) {
  2268.         $o->inform("$pkg $_->[0]: new version $_->[1] available in $_->[2]\n");
  2269.     }
  2270.     unless (@updates) {
  2271.         $o->inform("$pkg $default->{oldver}: up to date.\n");
  2272.         $upgrade &= $opts{force};
  2273.     }
  2274.     if ($upgrade) {
  2275.         my @k = keys %$p;
  2276.         my $ask = (@updates > 1 or @k > 1 and !@updates);
  2277.         if ($ask) {
  2278.         # Which one do they want to install?
  2279.         $o->inform(<<MANY);
  2280.  
  2281.    Note: $pkg version $default->{oldver} is available from more than one place.
  2282.    Which repository would you like to upgrade from?
  2283.  
  2284. MANY
  2285.         my @repos = map { $_->[2] } @updates;
  2286.         $o->print_pairs([ 1 .. @repos ], \@repos, '. ');
  2287.         $o->inform("\n");
  2288.         my $rep = $o->prompt(
  2289.             "Repository? [$default->{repo}] ",
  2290.             $default->{repo},
  2291.             [ 1 .. @repos, @repos ],
  2292.         );
  2293.         $rep = $repos[$rep - 1] if $rep =~ /^\d+$/;
  2294.         $default = $p->{$rep};
  2295.         }
  2296.         elsif (!@updates) {
  2297.         ($default) = values %$p;
  2298.         }
  2299.         if (not $default->{precious} or $default->{precious} && $opts{doprecious}) {
  2300.         $o->upgrade_pkg($default->{pkg}, \%opts);
  2301.         }
  2302.         else {
  2303.         $o->warn(<<END);
  2304. Use '-precious' to force precious packages to be upgraded.
  2305. END
  2306.         }
  2307.     }
  2308.     }
  2309.     1;
  2310. }
  2311.  
  2312. #============================================================================
  2313. # Profile:
  2314. # profile        # lists the profiles available on the repository
  2315. # profile N        # switches profiles
  2316. # profile add "name"    # adds a new profile
  2317. # profile delete N    # deletes the given profile
  2318. # profile describe N    # describes the given profile
  2319. # profile save        # saves the current state to the current profile
  2320. # profile restore    # restores the current profile
  2321. # profile rename    # renames the given profile
  2322. #============================================================================
  2323. sub smry_profiles { "manage PPM profiles" }
  2324. sub help_profiles { <<'END' }
  2325.  
  2326. END
  2327. sub comp_profiles {
  2328.     my $o = shift;
  2329.     my ($word, $line, $start) = @_;
  2330.     my @words = $o->line_parsed($line);
  2331.     my $words = scalar @words;
  2332.     my @profs = PPM::UI::profile_list();
  2333.     my @cmds = ('add', 'delete', 'describe', 'save', 'restore', 'rename');
  2334.  
  2335.     if ($words == 1 or $words == 2 and $start != length($line)) {
  2336.     my @compls = (@cmds, 1 .. scalar @profs);
  2337.     return $o->completions($word, \@compls);
  2338.     }
  2339.     if ($words == 2 or $words == 3 and $start != length($line)) {
  2340.     return ()
  2341.       if ($o->completions($words[1], [qw(add save restore)])==1);
  2342.     return $o->completions($word, [1 .. scalar @profs])
  2343.       if ($o->completions($words[1], [qw(delete describe rename)])==1);
  2344.     }
  2345.     ();
  2346. }
  2347. sub run_profiles {
  2348.     my $o = shift;
  2349.     my @args = @_;
  2350.     trace(1, "PPM: profile @args\n");
  2351.  
  2352.     my $ok = PPM::UI::profile_list();
  2353.     unless ($ok->is_success) {
  2354.     $o->warn($ok->msg);
  2355.     return unless $ok->ok;
  2356.     }
  2357.     my @profiles = dictsort $ok->result_l;
  2358.     $ok = PPM::UI::profile_get();
  2359.     unless ($ok->is_success) {
  2360.     $o->warn($ok->msg);
  2361.     return unless $ok->ok;
  2362.     }
  2363.     my $profile = $ok->result;
  2364.     my $which = find_index($profile, 0, @profiles);
  2365.     if ($which < 0 and @profiles) {
  2366.     $profile = $profiles[0];
  2367.     PPM::UI::profile_set($profile);
  2368.     }
  2369.  
  2370.     if (@args) {
  2371.     # Switch to profile N:
  2372.     if ($args[0] =~ /^\d+$/) {
  2373.         my $num = $args[0];
  2374.         if (bounded(1, $num, scalar @profiles)) {
  2375.         my $profile = $profiles[$num-1];
  2376.         PPM::UI::profile_set($profile);
  2377.         }
  2378.         else {
  2379.         $o->warn("No such profile number '$num'.\n");
  2380.         return;
  2381.         }
  2382.     }
  2383.  
  2384.     # Describe profile N:
  2385.     elsif (matches($args[0], "des|cribe")) {
  2386.         my $num =     $args[1] =~ /^\d+$/ ? $args[1] :
  2387.             do {
  2388.                 my $n = find_index($args[1], 1, @profiles);
  2389.                 if ($n < 1) {
  2390.                 $o->warn("No such profile '$args[1]'.\n");
  2391.                 return;
  2392.                 }
  2393.                 $n;
  2394.             } if defined $args[1];
  2395.         my $prof;
  2396.         if (defined $num and $num =~ /^\d+$/) {
  2397.         if (bounded(1, $num, scalar @profiles)) {
  2398.             $prof = $profiles[$num - 1];
  2399.         }
  2400.         else {
  2401.             $o->warn("No such profile number '$num'.\n");
  2402.             return;
  2403.         }
  2404.         }
  2405.         elsif (defined $num) {
  2406.         $o->warn("Argument to '$args[0]' must be numeric; see 'help profile'.\n");
  2407.         return;
  2408.         }
  2409.         else {
  2410.         $prof = $profile;
  2411.         }
  2412.  
  2413.         my $res = PPM::UI::profile_info($prof);
  2414.         $o->warn($res->msg) and return unless $res->ok;
  2415.         my @res = $res->result_l;
  2416.         {
  2417.         my ($pkg, $version, $target);
  2418.         my $picture = <<'END';
  2419. [[[[[[[[[[[[[[[[[[[    [[[[[[[[[[[    [[[[[[[[[[[[[[[[[[[[[[
  2420. END
  2421.         ($pkg, $version, $target) = qw(PACKAGE VERSION TARGET);
  2422.         my $text = '';
  2423.         $text .= form($picture, $pkg, $version, $target)
  2424.           if @res;
  2425.         for my $entity (@res) {
  2426.             ($pkg, $version, $target) = @$entity;
  2427.             $version = "[$version]";
  2428.             $text .= form($picture, $pkg, $version, $target);
  2429.         }
  2430.         if (@res) {
  2431.             $o->inform("Describing Profile '$prof':\n");
  2432.         }
  2433.         else {
  2434.             $o->inform("Profile '$prof' is empty.\n");
  2435.         }
  2436.         $o->page($text);
  2437.         }
  2438.         return 1;
  2439.     }
  2440.  
  2441.     # Add a profile "name":
  2442.     elsif (matches($args[0], "a|dd")) {
  2443.         my $name = $args[1];
  2444.         if ($name) {
  2445.         # Note: do some heavy-duty error-checking; XXX
  2446.         PPM::UI::profile_add($name);
  2447.         PPM::UI::profile_save($name)
  2448.           if $o->conf('profile-track');
  2449.         PPM::UI::profile_set($name)
  2450.           unless $which >= 0;
  2451.         @profiles = PPM::UI::profile_list()->result_l;
  2452.         }
  2453.         else {
  2454.         $o->warn("Invalid use of 'add' command; see 'help profile'.\n");
  2455.         return;
  2456.         }
  2457.     }
  2458.  
  2459.     # Remove profile N:
  2460.     elsif (matches($args[0], "del|ete")) {
  2461.         my $num =    $args[1] =~ /^\d+$/ ? $args[1] :
  2462.             do {
  2463.                 my $n = find_index($args[1], 1, @profiles);
  2464.                 if ($n < 1) {
  2465.                 $o->inform("No such profile '$args[1]'.\n");
  2466.                 return;
  2467.                 }
  2468.                 $n;
  2469.             } if defined $args[1];
  2470.         if (defined $num and $num =~ /^\d+$/) {
  2471.         my $dead_profile = $profiles[$num-1];
  2472.         if (bounded(1, $num, scalar @profiles)) {
  2473.             PPM::UI::profile_del($dead_profile);
  2474.             @profiles = dictsort PPM::UI::profile_list()->result_l;
  2475.             if (@profiles and $dead_profile eq $profile) {
  2476.             $profile = $profiles[0];
  2477.             PPM::UI::profile_set($profile);
  2478.             }
  2479.             elsif (not @profiles) {
  2480.             $o->conf('profile-track', 0);
  2481.             PPM::UI::profile_set('');
  2482.             }
  2483.         }
  2484.         else {
  2485.             $o->warn("No such profile '$num'.\n");
  2486.             return;
  2487.         }
  2488.         }
  2489.         elsif (defined $num) {
  2490.         $o->warn(<<END);
  2491. Argument to '$args[0]' must be numeric; see 'help profile'.
  2492. END
  2493.         return;
  2494.         }
  2495.         else {
  2496.         $o->warn(<<END);
  2497. Invalid use of '$args[0]' command; see 'help profile'.
  2498. END
  2499.         return;
  2500. }
  2501.     }
  2502.  
  2503.     # Save current profile:
  2504.     elsif (matches($args[0], "s|ave")) {
  2505.         unless (@profiles) {
  2506.         $o->warn(<<END);
  2507. No profiles on the server. Use 'profile add' to add a profile.
  2508. END
  2509.         return;
  2510.         }
  2511.         unless ($which >= 0) {
  2512.         $o->warn(<<END);
  2513. No profile selected. Use 'profile <number>' to select a profile.
  2514. END
  2515.         return;
  2516.         }
  2517.         my $ok = PPM::UI::profile_save($profile);
  2518.         if ($ok->ok) {
  2519.         $o->inform("Profile '$profile' saved.\n");
  2520.         }
  2521.         else {
  2522.         $o->warn($ok->msg);
  2523.         return;
  2524.         }
  2525.         return 1;
  2526.     }
  2527.  
  2528.     # Rename profile:
  2529.     elsif (matches($args[0], "ren|ame")) {
  2530.         unless (@profiles) {
  2531.         $o->warn(<<END);
  2532. No profiles on the server. Use 'profile add' to add a profile.
  2533. END
  2534.         return;
  2535.         }
  2536.  
  2537.         # Determine the old name:
  2538.         my $num =    $args[1] =~ /^\d+$/ ? $args[1] :
  2539.             do {
  2540.                 my $n = find_index($args[1], 1, @profiles);
  2541.                 if ($n < 1) {
  2542.                 $o->warn("No such profile '$args[1]'.\n");
  2543.                 return;
  2544.                 };
  2545.                 $n;
  2546.             } if defined $args[1];
  2547.         my $oldprof;
  2548.         if (defined $num and $num =~ /^\d+$/) {
  2549.         if (bounded(1, $num, scalar @profiles)) {
  2550.             $oldprof = $profiles[$num - 1];
  2551.         }
  2552.         else {
  2553.             $o->warn("No such profile number '$num'.\n");
  2554.             return;
  2555.         }
  2556.         }
  2557.         elsif (defined $num) {
  2558.         $o->warn("Argument to '$args[0]' must be numeric; see 'help profile'.\n");
  2559.         return;
  2560.         }
  2561.         else {
  2562.         $o->warn("profile: invalid use of '$args[0]' command: see 'help profile'.\n");
  2563.         return;
  2564.         }
  2565.  
  2566.         # Validate the new name:
  2567.         my $newprof = $args[2];
  2568.         unless (defined $newprof and length($newprof)) {
  2569.         $newprof = '' unless defined $newprof;
  2570.         $o->warn(<<END);
  2571. Profile names must be non-empty: '$newprof' is not a valid name.
  2572. END
  2573.         return;
  2574.         }
  2575.  
  2576.         # Actually do it:
  2577.         my $ok = PPM::UI::profile_rename($oldprof, $newprof);
  2578.         unless ($ok->is_success) {
  2579.         $o->warn($ok->msg);
  2580.         return unless $ok->ok;
  2581.         }
  2582.         if ($profile eq $oldprof) {
  2583.         $profile = $newprof;
  2584.         PPM::UI::profile_set($profile);
  2585.         }
  2586.         @profiles = dictsort PPM::UI::profile_list()->result_l;
  2587.     }
  2588.  
  2589.     # Restore current profile:
  2590.     elsif (matches($args[0], "res|tore")) {
  2591.         unless (@profiles) {
  2592.         $o->warn(<<END);
  2593. No profiles on this server. Use 'profile add' to add a profile.
  2594. END
  2595.         return;
  2596.         }
  2597.         unless ($which >= 0) {
  2598.         $o->warn(<<END);
  2599. No profile selected. Use 'profile <number>' to select a profile.
  2600. END
  2601.         return;
  2602.         }
  2603.         my ($clean_packages, $dry) = (0, 0);
  2604.         my ($force, $follow) = (1, 0);
  2605.         {
  2606.         local @ARGV = @args;
  2607.         GetOptions('clean!' => \$clean_packages,
  2608.                'force!' => \$force,
  2609.                'follow!' => \$follow,
  2610.                'dryrun' => \$dry,
  2611.               );
  2612.         @args = @ARGV;
  2613.         }
  2614.         my $cb_inst = $dry ? \&dr_install : \&cb_install;
  2615.         my $cb_rm   = $dry ? \&dr_remove  : \&cb_remove ;
  2616.         my $ok = PPM::UI::profile_restore($profile, sub {$o->$cb_inst(@_)},
  2617.                           sub {$o->$cb_rm(@_)}, $force, $follow,
  2618.                           $dry, $clean_packages);
  2619.         if ($ok->ok) {
  2620.         $o->cache_clear('query');
  2621.         $o->inform("Profile '$profile' restored.\n");
  2622.         }
  2623.         else {
  2624.         $o->warn($ok->msg);
  2625.         return;
  2626.         }
  2627.         return 1;
  2628.     }
  2629.  
  2630.     # Unrecognized subcommand:
  2631.     else {
  2632.         $o->warn("No such profile command '$args[0]'; see 'help profile'.\n");
  2633.         return;
  2634.     }
  2635.     }
  2636.     if (@profiles) {
  2637.     @profiles = dictsort @profiles;
  2638.     my $i = 0;
  2639.     $o->inform("Profiles:\n");
  2640.     my $profile = PPM::UI::profile_get()->result;
  2641.     for (@profiles) {
  2642.         $o->informf("%s%2d", $profile eq $profiles[$i] ? "*" : " ", $i + 1);
  2643.         $o->inform(". $_\n");
  2644.         $i++;
  2645.     }
  2646.     }
  2647.     elsif (defined $args[0] and matches($args[0], "del|ete")) {
  2648.     # assume that we just deleted the last profile
  2649.     $o->warn(<<END);
  2650. Profile deleted; no remaining profiles on the server.
  2651. END
  2652.     }
  2653.     else {
  2654.     $o->warn(<<END);
  2655. No profiles. Use 'profile add' to add a profile.
  2656. END
  2657.     }
  2658.     1;
  2659. }
  2660.  
  2661. #============================================================================
  2662. # Help-only topics:
  2663. #============================================================================
  2664. sub smry_prompt { "how to interpret the PPM prompt" }
  2665. sub help_prompt { <<'END' }
  2666.  
  2667. END
  2668.  
  2669. #sub run_quickstart  { $_[0]->run_help('quickstart') }
  2670. sub smry_quickstart { "a crash course in using PPM" }
  2671. sub help_quickstart { <<'END' }
  2672.  
  2673. END
  2674.  
  2675. sub smry_ppm_migration { "guide for those familiar with PPM" }
  2676. sub help_ppm_migration { <<'END' }
  2677.  
  2678. END
  2679.  
  2680. sub smry_unicode { "notes about unicode author names" }
  2681. sub help_unicode { <<'END' }
  2682.  
  2683. END
  2684.  
  2685. #============================================================================
  2686. # Utility Functions
  2687. #============================================================================
  2688. sub sort_fields { qw(name title author abstract version repository) }
  2689. sub sort_pkgs {
  2690.     my $o = shift;
  2691.     my $field = lc shift;
  2692.     my @pkgs = @_;
  2693.     my $targ = $o->conf('target');
  2694.     my $filt = sub { $_[0]->getppd_obj($targ)->result->$field };
  2695.     if ($field eq 'name') {
  2696.     return dictsort $filt, @pkgs;
  2697.     }
  2698.     if ($field eq 'title') {
  2699.     return dictsort $filt, @pkgs;
  2700.     }
  2701.     if ($field eq 'author') {
  2702.     return dictsort $filt, @pkgs;
  2703.     }
  2704.     if ($field eq 'abstract') {
  2705.     return dictsort $filt, @pkgs;
  2706.     }
  2707.     if ($field eq 'repository') {
  2708.     return dictsort sub { $_[0]->repository->name }, @pkgs;
  2709.     }
  2710.     if ($field eq 'version') {
  2711.     return sort {
  2712.         my $pa = $a->getppd_obj($targ)->result;
  2713.         my $pb = $b->getppd_obj($targ)->result;
  2714.         $pb->uptodate($pa->version_osd) <=> $pa->uptodate($pb->version_osd)
  2715.     } @pkgs;
  2716.     }
  2717.     @pkgs;
  2718. }
  2719.  
  2720. sub find_index {
  2721.     my $entry = shift || '';
  2722.     my $index = shift;
  2723.     $index = 0 unless defined $index;
  2724.     for (my $i=0; $i<@_; $i++) {
  2725.     return $index + $i if $entry eq $_[$i];
  2726.     }
  2727.     return $index - 1;
  2728. }
  2729.  
  2730. sub bounded {
  2731.     my $lb = shift;
  2732.     my $d = shift;
  2733.     my $ub = shift;
  2734.     return ($d >= $lb and $d <= $ub);
  2735. }
  2736.  
  2737. sub dictsort(@) {
  2738.     my $o = shift if eval { $_[0]->isa("PPMShell") };
  2739.     my $filt = ref($_[0]) eq 'CODE' ? shift @_ : undef;
  2740.     return map { $_->[0] }
  2741.        sort { lc $a->[1] cmp lc $b->[1] }
  2742.        map { [ $_, $filt ? $filt->($_) : $_ ] } @_;
  2743. }
  2744.  
  2745. sub path_under {
  2746.     my $path = shift;
  2747.     my $cmp  = shift;
  2748.     if ($^O eq 'MSWin32') {
  2749.     $path =~ s#\\#/#g;
  2750.     $cmp  =~ s#\\#/#g;
  2751.     return $path =~ /^\Q$cmp\E/i;
  2752.     }
  2753.     else {
  2754.     return $path =~ /^\Q$cmp\E/;
  2755.     }
  2756. }
  2757.  
  2758. sub prompt_str {
  2759.     my $o = shift;
  2760.  
  2761.     # Hack: set the pager here, instead of in settings_setkey()
  2762.     $o->{API}{pager} = $o->conf('pager');
  2763.  
  2764.     my @search_results = $o->cache_sets('search');
  2765.     my $search_result_current = $o->cache_set_current('search');
  2766.     my $search_result_index = $o->cache_set_index('search');
  2767.     my @query_results = $o->cache_sets('query');
  2768.     my $query_result_current = $o->cache_set_current('query');
  2769.     my $query_result_index = $o->cache_set_index('query');
  2770.  
  2771.     # Make sure a profile is selected if they turned tracking on.
  2772.     my $profile_track = $o->conf('profile-track');
  2773.     my $profile       = PPM::UI::profile_get()->result;
  2774.     $o->setup_profile()
  2775.     if $profile_track and not $profile and $o->mode eq 'SHELL';
  2776.  
  2777.     my @targs = PPM::UI::target_list()->result_l;
  2778.     if (@targs and not find_index($o->conf('target'), 1, @targs)) {
  2779.     $o->conf('target', $targs[0]);
  2780.     }
  2781.  
  2782.     if ($o->conf('prompt-context')) {
  2783.     my ($targ, $rep, $s, $sp, $q, $qp);
  2784.  
  2785.     if ($o->conf('prompt-verbose')) {
  2786.         my $sz = $o->conf('prompt-slotsize');
  2787.         $targ = substr($o->conf('target'), 0, $sz);
  2788.         $rep  = substr($o->conf('repository'), 0, $sz);
  2789.  
  2790.         my $sq_tmp = $o->cache_set('search', undef, 'query');
  2791.         my $ss_tmp = $o->cache_set('search');
  2792.         my $sp_tmp = $o->cache_entry('search');
  2793.         $s = (defined $sq_tmp)
  2794.           ? ":" . substr($sq_tmp, 0, $sz)
  2795.           : "";
  2796.         $sp = ($s and defined $sp_tmp and
  2797.            bounded(0, $search_result_index, $#$ss_tmp))
  2798.           ? ":" . substr($sp_tmp->name, 0, $sz)
  2799.           : "";
  2800.  
  2801.         my $qq_tmp = $o->cache_set('query', undef, 'query');
  2802.         my $qs_tmp = $o->cache_set('query');
  2803.         my $qp_tmp = $o->cache_entry('query');
  2804.         $q = (defined $qq_tmp)
  2805.           ? ":" . substr($qq_tmp, 0, $sz)
  2806.           : "";
  2807.         $qp = ($q and defined $qp_tmp and
  2808.            bounded(0, $query_result_index, $#$qs_tmp))
  2809.           ? ":" . substr($qp_tmp->name, 0, $sz)
  2810.           : "";
  2811.     }
  2812.     else {
  2813.         # Target and Repository:
  2814.         $targ = find_index($o->conf('target'), 1, @targs);
  2815.         $targ = '?' if $targ == 0;
  2816.     
  2817.         # Search number & package:
  2818.         $s = @search_results ? ":s".($search_result_current + 1) : "";
  2819.         my $sp_tmp = $o->cache_set('search');
  2820.         $sp = ($s and defined $sp_tmp and 
  2821.            bounded(0, $search_result_index, $#$sp_tmp))
  2822.           ? ":sp".($search_result_index + 1)
  2823.           : "";
  2824.     
  2825.         # Query number & package:
  2826.         $q = @query_results ? ":q".($query_result_current + 1) : "";
  2827.         my $qp_tmp = $o->cache_set('query');
  2828.         $qp = ($q and defined $qp_tmp and
  2829.            bounded(0, $query_result_index, $#$qp_tmp))
  2830.           ? ":qp".($query_result_index + 1)
  2831.           : "";
  2832.     }
  2833.     return "ppm:$targ$s$sp$q$qp> ";
  2834.     }
  2835.     else {
  2836.     return "ppm> ";
  2837.     }
  2838. }
  2839.  
  2840. {
  2841.     # Weights for particular fields: these are stored in percentage of the
  2842.     # screen width, based on the number of columns they use on an 80 column
  2843.     # terminal. They also have a minimum and maximum.
  2844.     use constant MIN    => 0;
  2845.     use constant MAX    => 1;
  2846.     my %weight = (
  2847.     name     => [12, 20],
  2848.     title    => [12, 20],
  2849.     abstract => [12, 20],
  2850.     author   => [12, 20],
  2851.     repository => [12, 20],
  2852.     version  => [ 4,  9],
  2853.     );
  2854.     my %meth = (
  2855.     name     => 'name',
  2856.     title    => 'title',
  2857.     version  => 'version',
  2858.     abstract => 'abstract',
  2859.     author   => 'author',
  2860.     repository => sub {
  2861.         my $o = shift;
  2862.         my $rep = $o->repository or return "Installed";
  2863.         my $name = $rep->name;
  2864.         my $id   = $o->id || $name;
  2865.         my $loc  = $rep->location;
  2866.         "$name [$loc]"
  2867.     },
  2868.     );
  2869.     # These are Text::Autoformat justification marks. They're actually used to
  2870.     # build a printf() format string, since it's so much more efficient for a
  2871.     # non-line-wrapping case.
  2872.     my %just = (
  2873.     name     => '<',
  2874.     title    => '<',
  2875.     abstract => '<',
  2876.     author   => '<',
  2877.     repository => '<',
  2878.     version  => '>',
  2879.     );
  2880.     my %plus = (
  2881.     name     => '0',
  2882.     title    => '0',
  2883.     abstract => '0',
  2884.     author   => '0',
  2885.     repository => '0',
  2886.     version  => '2',
  2887.     );
  2888.     my %filt = (
  2889.     version => q{"[$_]"},
  2890.     );
  2891.     sub picture_optimized {
  2892.     my $o = shift;
  2893.     my @items = @{shift(@_)};
  2894.     unless ($o->conf('fields')) {
  2895.         my $m = $o->setmode('SILENT');
  2896.         $o->conf('fields', '', 1);
  2897.         $o->setmode($m);
  2898.     }
  2899.     my @fields = split ' ', $o->conf('fields');
  2900.     $_ = lc $_ for @fields;
  2901.     my (%max_width, %width);
  2902.     my $cols = $o->termsize->{cols};
  2903.     for my $f (@fields) {
  2904.         my $meth = $meth{$f};
  2905.         $max_width{$f} = max { length($_->$meth) } @items;
  2906.         $max_width{$f} += $plus{$f};
  2907.         $width{$f} = $max_width{$f} / 80 * $cols;
  2908.         my $max_f  = $weight{$f}[MAX] / 80 * $cols;
  2909.         my $min_f  = $weight{$f}[MIN];
  2910.         my $gw     = $width{$f};
  2911.         $width{$f} = (
  2912.         $width{$f} > $max_width{$f} ? $max_width{$f} :
  2913.         $width{$f} > $max_f         ? $max_f         :
  2914.         $width{$f} < $min_f         ? $min_f         : $width{$f}
  2915.         );
  2916.     }
  2917.     my $right = $fields[-1];
  2918.     my $index_sz = length( scalar(@items) ) + 3; # index spaces
  2919.     my $space_sz = @fields + 1; # separator spaces
  2920.     my $room = $cols - $index_sz - $space_sz;
  2921.     $width{$right} = $room - sum { $width{$_} } @fields[0 .. $#fields-1];
  2922.     while ($width{$right} > $max_width{$right}) {
  2923.         my $smallest;
  2924.         my $n;
  2925.         for my $k (@fields[0 .. $#fields-1]) {
  2926.         my $max = $max_width{$k};
  2927.         my $sz  = $width{$k};
  2928.         $smallest = $k, $n = $max - $sz if $max - $sz > $n;
  2929.         }
  2930.         $width{$right}--;
  2931.         $width{$smallest}++;
  2932.     }
  2933.     while ($width{$right} < $weight{$right}[MIN]) {
  2934.         my $biggest;
  2935.         my $n;
  2936.         for my $k (@fields[0 .. $#fields-1]) {
  2937.         my $max = $max_width{$k};
  2938.         my $sz  = $width{$k};
  2939.         $biggest = $k, $n = $max - $sz if $max - $sz < $n;
  2940.         }
  2941.         $width{$right}++;
  2942.         $width{$biggest}--;
  2943.     }
  2944.     my $picture;
  2945.     $picture = "\%${index_sz}s "; # printf picture
  2946.     $picture .= join ' ', map {
  2947.         my $w = $width{$_};
  2948.         my $c = $just{$_};
  2949.         my $pad = $c eq '>' ? '' : '-';
  2950.         "\%${pad}${w}s" # printf picture
  2951.     } @fields;
  2952.     ($picture, \@fields, [@width{@fields}]);
  2953.     }
  2954.  
  2955.     sub print_formatted {
  2956.     my $o = shift;
  2957.     my $targ = $o->conf('target');
  2958.     my @items = map { $_->getppd_obj($targ)->result } @{shift(@_)};
  2959.     my $selected = shift;
  2960.     my $format;
  2961.  
  2962.     # Generate a picture and a list of fields for Text::Autoformat:
  2963.     my (@fields, %width);
  2964.     my ($picture, $f, $w) = $o->picture_optimized(\@items);
  2965.     $picture .= "\n";
  2966.     @fields = @$f;
  2967.     @width{@fields} = @$w;
  2968.  
  2969.     # The line-breaking sub: use '~' as hyphenation signal
  2970.     my $wrap = sub {
  2971.         my ($str, $maxlen, $width) = @_;
  2972.         my $field = substr($str, 0, $maxlen - 1) . '~';
  2973.         my $left  = substr($str, $maxlen - 1);
  2974.         ($field, $left);
  2975.     };
  2976.  
  2977.     my $lines = 0;
  2978.     my $i = 1;
  2979.     my @text;
  2980.     my %seen;
  2981.     for my $pkg (@items) {
  2982.         my $star = (defined $selected and $selected == $i - 1) ? "*" : " ";
  2983.         my $num  = "$star $i.";
  2984.         my @vals = (
  2985.         map {
  2986.             my $field  = $_;
  2987.             my $method = $meth{$field};
  2988.             local $_   = $pkg->$method;
  2989.             my $val = defined $filt{$field} ? eval $filt{$field} : $_;
  2990.             ($val) = $wrap->($val, $width{$field})
  2991.                 if length $val > $width{$field};
  2992.             $val;
  2993.         }
  2994.         @fields
  2995.         );
  2996. #        my $key = join '', @vals;
  2997. #        if (exists $seen{$key}) {
  2998. #        my $index = $seen{$key};
  2999. #        substr($text[$index], 0, 1) = '+';
  3000. #        next;
  3001. #        }
  3002. #        $seen{$key} = $i - 1;
  3003.         (my $inc = sprintf $picture, $num, @vals) =~ s/[ ]+$//;
  3004.         push @text, $inc;
  3005.         $i++;
  3006.     }
  3007.  
  3008.     # And, page it.
  3009.     $o->page(join '', @text);
  3010.     }
  3011. }
  3012.  
  3013. sub tree_pkg {
  3014.     my $o = shift;
  3015.     my @rlist = $o->reps_on;
  3016.     my $tar = $o->conf('target');
  3017.     my $pkg = shift;
  3018.     my $ppd;
  3019.     if (eval { $pkg->isa('PPM::Package') }) {
  3020.     $ppd = $pkg->getppd_obj($tar);
  3021.     unless ($ppd->ok) {
  3022.         $o->warn($ppd->msg);
  3023.         return;
  3024.     }
  3025.     $ppd = $ppd->result;
  3026.     }
  3027.     else {
  3028.     my ($s, $i) = $o->cache_find('search', $pkg);
  3029.     if ($i >= 0) {
  3030.         $ppd = $o->cache_entry('search', $i, $s);
  3031.     } 
  3032.     else {
  3033.         my $ok = PPM::UI::describe(\@rlist, $tar, $pkg);
  3034.         unless ($ok->is_success) {
  3035.         $o->warn($ok->msg);
  3036.         return unless $ok->ok;
  3037.         }
  3038.         $ppd = $ok->result->getppd_obj($tar);
  3039.         unless ($ppd->ok) {
  3040.         $o->warn($ppd->msg);
  3041.         return;
  3042.         }
  3043.         $ppd = $ppd->result;
  3044.     }
  3045.     }
  3046.  
  3047.     my $pad = "\n";
  3048.     $o->inform($ppd->name, " ", $ppd->version);
  3049.     $o->Tree(\@rlist, $tar, $ppd->name, $pad, {});
  3050.     $o->inform($pad);
  3051. }
  3052.  
  3053. my ($VER, $HOR, $COR, $TEE, $SIZ) = ('|', '_', '\\', '|', ' ');
  3054.  
  3055. sub Tree {
  3056.     my $o = shift;
  3057.     my $reps = shift;
  3058.     my $tar = shift;
  3059.     my $pkg = shift;
  3060.     my $ind = shift;
  3061.     my $seen = shift;
  3062.     my $pad = $ind . "  " . $VER;
  3063.  
  3064.     my $ppd;
  3065.     if (exists $seen->{$pkg}) {
  3066.     $ppd = $seen->{$pkg};
  3067.     }
  3068.     else {
  3069.     my ($s, $i) = $o->cache_find('search', $pkg);
  3070.     if ($i >= 0) {
  3071.         $ppd = $o->cache_entry('search', $i, $s);
  3072.     }
  3073.     else {
  3074.         my $ok = PPM::UI::describe($reps, $tar, $pkg);
  3075.         unless ($ok->is_success) {
  3076.         $o->inform(" -- package not found; skipping tree");
  3077.         return 0 unless $ok->ok;
  3078.         }
  3079.         $ppd = $ok->result;
  3080.     }
  3081.     $ppd->make_complete($tar);
  3082.     $ppd = $ppd->getppd_obj($tar);
  3083.     unless ($ppd->ok) {
  3084.         $o->warn($ppd->msg);
  3085.         return;
  3086.     }
  3087.     $ppd = $ppd->result;
  3088.     $seen->{$pkg} = $ppd;
  3089.     }
  3090.  
  3091.     my @impls   = $ppd->implementations;
  3092.     return 0 unless @impls;
  3093.     my @prereqs = $impls[0]->prereqs;
  3094.     return 0 unless @prereqs;
  3095.     my $nums = scalar @prereqs;
  3096.  
  3097.     for (1..$nums) {
  3098.     my $doneblank = 0;
  3099.     my $pre = $prereqs[$_-1];
  3100.     my $txt = $pre->name . " " . $pre->version;
  3101.     if ($_ == $nums) {
  3102.         substr($pad, -1) = $COR;
  3103.         $o->inform($pad, "$HOR$HOR", $txt);
  3104.         substr($pad, -1) = ' ';
  3105.     }
  3106.     else {
  3107.         substr($pad, -1) = $TEE;
  3108.         $o->inform($pad, "$HOR$HOR", $txt);
  3109.         substr($pad, -1) = $VER;
  3110.     }
  3111.     if ($o->Tree($reps, $tar, $pre->name, $pad, $seen) != 0 and
  3112.         $doneblank == 0) {
  3113.         $o->inform($pad); ++$doneblank;
  3114.     }
  3115.     }
  3116.     return $nums;
  3117. }
  3118.  
  3119. sub describe_pkg {
  3120.     my $o = shift;
  3121.     my $pkg = shift;
  3122.     my ($extra_keys, $extra_vals) = (shift || [], shift || []);
  3123.     my $n; 
  3124.  
  3125.     # Get the PPM::PPD object out of the PPM::Package object.
  3126.     my $pkg_des = $pkg->describe($o->conf('target'));
  3127.     unless ($pkg_des->ok) {
  3128.     $o->warn($pkg_des->msg);
  3129.     return;
  3130.     }
  3131.     $pkg_des = $pkg_des->result;
  3132.  
  3133.     # Basic information:
  3134.     $n = $o->print_pairs(
  3135.     [qw(Name Version Author Title Abstract), @$extra_keys],
  3136.     [(map { $pkg_des->$_ } qw(name version author title abstract)),
  3137.      @$extra_vals],
  3138.     undef,    # separator
  3139.     undef,    # left
  3140.     undef,    # indent
  3141.     undef,    # length
  3142.     1,    # wrap (yes, please wrap)
  3143.     );
  3144.  
  3145.     # The repository:
  3146.     if (my $rep = $pkg_des->repository) {
  3147.     $o->print_pairs(
  3148.         ["Location"],
  3149.         [$rep->name],
  3150.         undef,    # separator
  3151.         undef,    # left
  3152.         undef,    # indent
  3153.         $n,        # length
  3154.         1,        # wrap
  3155.     );
  3156.     }
  3157.     
  3158.     # Prerequisites:
  3159.     my @impls = grep { $_->architecture } $pkg_des->implementations;
  3160.     my @prereqs = @impls ? $impls[0]->prereqs : ();
  3161.     $o->inform("Prerequisites:\n") if @prereqs;
  3162.     $o->print_pairs(
  3163.     [ 1 .. @prereqs ],
  3164.     [ map { $_->name . ' ' . $_->version} @prereqs ],
  3165.     '. ',    # separator
  3166.     undef,    # left
  3167.     undef,    # indent
  3168.     $n,    # length
  3169.     0,    # wrap (no, please don't wrap)
  3170.     );
  3171.     
  3172.     # Implementations:
  3173.     $o->inform("Available Platforms:\n") if @impls;
  3174.     my @impl_strings;
  3175.     for (@impls) {
  3176.     my $arch  = $_->architecture;
  3177.     my $os    = $_->os;
  3178.     my $osver = $_->osversion;
  3179.     my $str   = $arch;
  3180.     $osver    =~ s/\Q(any version)\E//g;
  3181.     if ($os and $osver) {
  3182.         $str .= ", $os $osver";
  3183.     }
  3184.     push @impl_strings, $str;
  3185.     }
  3186.     @impl_strings = dictsort @impl_strings;
  3187.     $o->print_pairs(
  3188.     [ 1 .. @impls ],
  3189.     [ @impl_strings ],
  3190.     '. ', undef, undef, $n
  3191.     );
  3192. }
  3193.  
  3194. sub remove_pkg {
  3195.     my $o = shift;
  3196.     my $package = shift;
  3197.     my $target = $o->conf('target');
  3198.     my $force = shift;
  3199.     my $quell_clear = shift;
  3200.     my $verbose = $o->conf('remove-verbose');
  3201.     my $ok = PPM::UI::remove($target, $package, $force, sub { $o->cb_remove(@_) }, $verbose);
  3202.     unless ($ok->is_success) {
  3203.     $o->warn($ok->msg);
  3204.     return 0 unless $ok->ok;
  3205.     }
  3206.     else {
  3207.     $o->warn_profile_change($ok);
  3208.     }
  3209.     $o->cache_clear('query') if ($ok->ok and not $quell_clear);
  3210.     1;
  3211. }
  3212.  
  3213. sub upgrade_pkg {
  3214.     push @_, 'upgrade';
  3215.     goto &install_pkg;
  3216. }
  3217. sub install_pkg {
  3218.     my $o = shift;
  3219.     my $pkg = shift;
  3220.     my $opts = shift;
  3221.     my $action = shift;
  3222.     my $quell_clear = shift;
  3223.     $action = 'install' unless defined $action;
  3224.  
  3225.     # Find the package:
  3226.     while (1) {
  3227.     # 1. Return if they specified a full filename or URL:
  3228.     last if PPM::UI::is_pkg($pkg);
  3229.  
  3230.     # 2. Check if whatever they specified returns 1 search result:
  3231.     my $search =
  3232.       PPM::UI::search([$o->reps_on], $o->conf('target'), $pkg, 
  3233.               $o->conf('case-sensitivity'));
  3234.     unless ($search->is_success) {
  3235.         $o->warn($search->msg);
  3236.         return unless $search->ok;
  3237.     }
  3238.     my @ret = $search->result_l;
  3239.     if (@ret > 1) {
  3240.         $o->warn(<<END);
  3241. Searching for '$pkg' returned multiple results. Using 'search' instead...
  3242. END
  3243.         $o->run_search($pkg);
  3244.         return;
  3245.     }
  3246.     elsif (not @ret) {
  3247.         $o->warn(<<END);
  3248. Searching for '$pkg' returned no results. Try a broader search first.
  3249. END
  3250.         return;
  3251.     }
  3252.     $pkg = $ret[0]->name;
  3253.     last;
  3254.     }
  3255.  
  3256.     my $cb = (
  3257.     $opts->{dryrun}
  3258.     ? $action eq 'install' ? \&dr_install : \&dr_upgrade
  3259.     : $action eq 'install' ? \&cb_install : \&cb_upgrade
  3260.     );
  3261.  
  3262.     # Now, do the install
  3263.     my $ok;
  3264.     my @rlist = $o->reps_on;
  3265.     my $targ = $o->conf('target');
  3266.  
  3267.     my $prop = PPM::UI::properties($targ, $pkg);
  3268.     if ($prop->ok) {
  3269.     my $name = ($prop->result_l)[0]->name;
  3270.     if (ref $pkg) {
  3271.         $pkg->name($name);
  3272.     }
  3273.     else {
  3274.         $pkg = $name;
  3275.     }
  3276.     }
  3277.  
  3278.     if ($action eq 'install') {
  3279.     $opts->{verbose} = $o->conf('install-verbose');
  3280.     my $pkgname = ref $pkg ? $pkg->name : $pkg;
  3281.     if ($prop->ok) {
  3282.         $o->inform("Note: Package '$pkgname' is already installed.\n");
  3283.         return unless $opts->{force};
  3284.     }
  3285.     $ok = PPM::UI::install(\@rlist, $targ, $pkg, $opts, sub {$o->$cb(@_)});
  3286.     }
  3287.     else {
  3288.     $opts->{verbose} = $o->conf('upgrade-verbose');
  3289.     $ok = PPM::UI::upgrade(\@rlist, $targ, $pkg, $opts, sub {$o->$cb(@_)});
  3290.     }
  3291.  
  3292.     unless ($ok->is_success) {
  3293.     $o->warn($ok->msg);
  3294.     return unless $ok->ok;
  3295.     }
  3296.     else {
  3297.     $o->warn_profile_change($ok);
  3298.     $o->cache_clear('query') unless $quell_clear;
  3299.     }
  3300.     1;
  3301. }
  3302.  
  3303. # The dry run callback; just prints out package name and version:
  3304. sub dr_install {
  3305.     my $o = shift;
  3306.     my $pkg = shift;
  3307.     my $version = shift;
  3308.     my $target_name = shift;
  3309.     $o->inform(<<END);
  3310. Dry run install '$pkg' version $version in $target_name.
  3311. END
  3312. }
  3313.  
  3314. sub dr_upgrade {
  3315.     my $o = shift;
  3316.     my $pkg = shift;
  3317.     my $version = shift;
  3318.     my $target_name = shift;
  3319.     $o->inform(<<END);
  3320. Dry run upgrade '$pkg' version $version in $target_name.
  3321. END
  3322. }
  3323.  
  3324. sub dr_remove {
  3325.     my $o = shift;
  3326.     my $pkg = shift;
  3327.     my $version = shift;
  3328.     my $target_name = shift;
  3329.     $o->inform(<<END);
  3330. Dry run remove '$pkg' version $version from $target_name.
  3331. END
  3332. }
  3333.  
  3334. sub cb_remove {
  3335.     my $o = shift;
  3336.     my $pkg = shift;
  3337.     my $version = shift;
  3338.     my $target_name = shift;
  3339.     my $status = shift;
  3340.     if ($status eq 'COMPLETE') {
  3341.     $o->inform(
  3342.         "Successfully removed $pkg version $version from $target_name.\n"
  3343.     )
  3344.     }
  3345.     else {
  3346.     $o->inform(<<END);
  3347. $SEP
  3348. Remove '$pkg' version $version from $target_name.
  3349. $SEP
  3350. END
  3351.     }
  3352. }
  3353.  
  3354. sub cb_install {
  3355.     my $o = shift;
  3356.     unshift @_, $o, 'install';
  3357.     &cb_status;
  3358. }
  3359.  
  3360. sub cb_upgrade {
  3361.     my $o = shift;
  3362.     unshift @_, $o, 'upgrade';
  3363.     &cb_status;
  3364. }
  3365.  
  3366. sub cb_status {
  3367.     my $o = shift;
  3368.     my $ACTION = shift;
  3369.     my $pkg = shift;
  3370.     my $version = shift;
  3371.     my $target_name = shift;
  3372.     my $status = shift;
  3373.     my $bytes = shift;
  3374.     my $total = shift;
  3375.     my $secs = shift;
  3376.  
  3377.     my $cols = $ENV{COLUMNS} || 78;
  3378.  
  3379.     $o->inform(<<END) and return if ($status eq 'PRE-INSTALL');
  3380. $SEP
  3381. \u$ACTION '$pkg' version $version in $target_name.
  3382. $SEP
  3383. END
  3384.  
  3385.     # Print the output on one line, repeatedly:
  3386.     my ($line, $pad, $eol);
  3387.     if ($status eq 'DOWNLOAD') {
  3388.     if ($bytes < $total) {
  3389.         $line = "Transferring data: $bytes/$total bytes.";
  3390.         $eol = "\r";
  3391.     }
  3392.     else {
  3393.         $line = "Downloaded $bytes bytes.";
  3394.         $eol = "\n";
  3395.     }
  3396.     }
  3397.     elsif ($status eq 'PRE-EXPAND') {
  3398.     $line = ""; #"Extracting package. This may take a few seconds.";
  3399.     $eol = "\r";  #"\n";
  3400.     }
  3401.     elsif ($status eq 'EXPAND') {
  3402.     $line = "Extracting $bytes/$total: $secs";
  3403.     $eol = $bytes < $total ? "\r" : "\n";
  3404.     }
  3405.     elsif ($status eq 'COMPLETE') {
  3406.     my $verb = $ACTION eq 'install' ? 'installed' : 'upgraded';
  3407.     $o->inform(
  3408.         "Successfully $verb $pkg version $version in $target_name.\n"
  3409.     );
  3410.     return;
  3411.     }
  3412.     $pad = ' ' x ($cols - length($line));
  3413.     $o->verbose($line, $pad, $eol);
  3414. }
  3415.  
  3416. sub warn_profile_change {
  3417.     my $o = shift;
  3418.     my $ok = shift;
  3419.  
  3420.     my $profile_track = $o->conf('profile-track');
  3421.     my $profile = PPM::UI::profile_get()->result;
  3422.  
  3423.     if ($profile_track) {
  3424.     $o->verbose(<<END);
  3425. Tracking changes to profile '$profile'.
  3426. END
  3427.     }
  3428. }
  3429.  
  3430. sub parse_range {
  3431.     my @numbers;
  3432.     my $arg;
  3433.     while ($arg = shift) {
  3434.       while ($arg) {
  3435.     if ($arg =~ s/^\s*,?\s*(\d+)\s*-\s*(\d+)//) {
  3436.         push @numbers, ($1 .. $2);
  3437.     }
  3438.     elsif ($arg =~ s/^\s*,?\s*(\d+)//) {
  3439.         push @numbers, $1;
  3440.     }
  3441.     else {
  3442.         last;
  3443.     }
  3444.       }
  3445.     }
  3446.     @numbers;
  3447. }
  3448.  
  3449. sub raw_args {
  3450.     my $o = shift;
  3451.     strip($o->line_args);
  3452. }
  3453.  
  3454. sub strip {
  3455.     my $f = shift;
  3456.     $f =~ s/^\s*//;
  3457.     $f =~ s/\s*$//;
  3458.     $f;
  3459. }
  3460.  
  3461. # matches("neil", "ne|il") => 1
  3462. # matches("ne", "ne|il") => 1
  3463. # matches("n", "ne|il") => 0
  3464. sub matches {
  3465.     my $cmd = shift;
  3466.     my $pat = shift || "";
  3467.  
  3468.     my ($required, $extra) = split '\|', $pat;
  3469.     $extra ||= "";
  3470.     my $regex = "$required(?:";
  3471.     for (my $i=1; $i<=length($extra); $i++) {
  3472.     $regex .= '|' . substr($extra, 0, $i);
  3473.     }
  3474.     $regex .= ")";
  3475.     return $cmd =~ /^$regex$/i;
  3476. }
  3477.  
  3478. sub pause_exit {
  3479.     my $o = shift;
  3480.     my $exit_code = shift || 0;
  3481.     my $pause = shift || 0;
  3482.     if ($pause) {
  3483.     if ($o->have_readkey) {
  3484.         $o->inform("Hit any key to exit...");
  3485.     }
  3486.     else {
  3487.         $o->inform("Hit <ENTER> to exit...");
  3488.     }
  3489.     $o->readkey;
  3490.     }
  3491.     exit $exit_code;
  3492. }
  3493.  
  3494. #============================================================================
  3495. # Check if this is the first time we've ever used profiles. This can be
  3496. # guessed: if the 'profile' entry is not set, but the 'profile-track' flag
  3497. # is, then it's the first time profile-track has been set to '1'.
  3498. #============================================================================
  3499. sub setup_profile {
  3500.     my $o = shift;
  3501.     $o->inform(<<END);
  3502. $SEP
  3503. You have profile tracking turned on: now it's time to choose a profile name.
  3504. ActiveState's PPM 3 Server will track which packages you have installed on
  3505. your machine. This information is stored in a "profile", located on the
  3506. server.
  3507.  
  3508. Here are some features of profiles:
  3509.  o You can have as many profiles as you want;
  3510.  o Each profile can track an unlimited number of packages;
  3511.  o PPM defaults to "tracking" your profile (it updates your profile every time
  3512.    you add or remove a package;
  3513.  o You can disable profile tracking by modifying the 'profile-track' option;
  3514.  o You can manually select, save, and restore profiles;
  3515.  o You can view your profile from ASPN as well as inside PPM 3.
  3516. $SEP
  3517.  
  3518. END
  3519.  
  3520.     my $response = PPM::UI::profile_list();
  3521.     my @l;
  3522.     unless ($response->ok) {
  3523.     $o->warn("Failed to enable profile tracking: ".$response->msg);
  3524.     $o->warn(<<END);
  3525.  
  3526. You can still use PPM3, but profiles are not enabled. To try setting up
  3527. profiles again, enter 'set profile-track=1'. Or, you can set up profiles
  3528. by hand, using the 'profile add' command.
  3529.  
  3530. END
  3531.     $o->run('unset', 'profile-track');
  3532.     return;
  3533.     }
  3534.     else {
  3535.     @l = sort $response->result_l;
  3536.     $o->inform("It looks like you have profiles on the server already.\n")
  3537.       if @l;
  3538.     $o->print_pairs([1 .. @l], \@l, '. ', 1, ' ');
  3539.     $o->inform("\n") if @l;
  3540.     }
  3541.  
  3542.     require PPM::Sysinfo;
  3543.     (my $suggest = PPM::Sysinfo::hostname()) =~ s/\..*$//;
  3544.     $suggest ||= "Default Profile";
  3545.     my $profile_name = $o->prompt(
  3546.     "What profile name would you like? [$suggest] ", $suggest, @l
  3547.     );
  3548.  
  3549.     my $select_existing = grep { $profile_name eq $_ } $response->result_l
  3550.       if $response->ok;
  3551.     if ($select_existing) {
  3552.     $o->inform("Selecting profile '$profile_name'...\n");
  3553.     PPM::UI::profile_set($profile_name);
  3554.     $o->inform(<<END);
  3555. You should probably run either 'profile save' or 'profile restore' to bring
  3556. the profile in sync with your computer.
  3557. END
  3558.     }
  3559.     elsif ($response->ok) {
  3560.     $o->inform("Creating profile '$profile_name'...\n");
  3561.     $o->run('profile', 'add', $profile_name);
  3562.     $o->inform("Saving profile '$profile_name'...\n");
  3563.     $o->run('profile', 'save');
  3564.     $o->inform(<<END);
  3565. Congratulations! PPM is now set up to track your profile.
  3566. END
  3567.     }
  3568.     else {
  3569.     $o->warn($response->msg);
  3570.     $o->warn(<<END);
  3571.  
  3572. You can still use PPM3, but profiles will not be enabled. To try setting up
  3573. profiles again, enter 'set profile-track=1'. Or, you can set up profiles
  3574. yourself using the 'profile add' command.
  3575.  
  3576. END
  3577.     $o->run('unset', 'profile-track');
  3578.     }
  3579. }
  3580.  
  3581. package main;
  3582. use Getopt::Long;
  3583. use Data::Dumper;
  3584.  
  3585. $ENV{PERL_READLINE_NOWARN} = "1";
  3586. $ENV{PERL_RL} = $^O eq 'MSWin32' ? "0" : "Perl";
  3587.  
  3588. my ($pause, $input_file, $target);
  3589.  
  3590. BEGIN {
  3591.     my ($shared_config_files, @fixpath, $gen_inst_key);
  3592.  
  3593.     Getopt::Long::Configure('pass_through');
  3594.     $target = 'auto';
  3595.     GetOptions(
  3596.     'file=s' => \$input_file,
  3597.     'shared' => \$shared_config_files,
  3598.     'target:s' => \$target,
  3599.     'fixpath=s' => \@fixpath,
  3600.     'generate-inst-key' => \$gen_inst_key,
  3601.     pause => \$pause,
  3602.     );
  3603.     Getopt::Long::Configure('no_pass_through');
  3604.  
  3605.     if ($shared_config_files) {
  3606.     $ENV{PPM3_shared_config} = 1;
  3607.     }
  3608.  
  3609.     if (@fixpath) {
  3610.     PPM::UI::target_fix_paths(@fixpath);
  3611.     exit;
  3612.     }
  3613.     if ($gen_inst_key) {
  3614.     require PPM::Config;
  3615.     PPM::Config::load_config_file('instkey');
  3616.     exit;
  3617.     }
  3618. }
  3619.  
  3620. # If we're being run from a file, tell Term::Shell about it:
  3621. if ($input_file) {
  3622.     my $line = 0;
  3623.     open SCRIPT, $input_file or die "$0: can't open $input_file: $!";
  3624.     my $shell = PPMShell->new(
  3625.     term => ['PPM3', \*SCRIPT, \*STDOUT],
  3626.     target => $target,
  3627.     pager => 'none',
  3628.     );
  3629.     $shell->setmode('SCRIPT');
  3630.     while (<SCRIPT>) {
  3631.     $line++;
  3632.     next if /^\s*#/ or /^\s*$/;
  3633.     my ($cmd, @args) = $shell->line_parsed($_);
  3634.     my $ret = $shell->run($cmd, @args);
  3635.     my $warn = <<END;
  3636. $0: $input_file:$line: fatal error: unknown or ambiguous command '$cmd'. 
  3637. END
  3638.     $shell->warn($warn) and $shell->pause_exit(2, $pause)
  3639.         unless $shell->{API}{cmd}{run}{found};
  3640.     $shell->pause_exit(1, $pause) unless $ret;
  3641.     }
  3642.     close SCRIPT;
  3643.     $shell->pause_exit(0, $pause);
  3644. }
  3645.  
  3646. # If we've been told what to do from the command-line, do it right away:
  3647. elsif (@ARGV) {
  3648.     my $shell = PPMShell->new(target => $target, pager => 'none');
  3649.     $shell->setmode('BATCH');
  3650.     my $ret = $shell->run($ARGV[0], @ARGV[1..$#ARGV]);
  3651.     my $warn = <<END;
  3652. Unknown or ambiguous command '$ARGV[0]'; type 'help' for commands.
  3653. END
  3654.     $shell->warn($warn) and $shell->pause_exit(2, $pause)
  3655.     unless $shell->{API}{cmd}{run}{found};
  3656.     $shell->pause_exit(0, $pause) if $ret;
  3657.     $shell->pause_exit(1, $pause);
  3658. }
  3659.  
  3660. # Just run the command loop
  3661. if (-t STDIN and -t STDOUT) {
  3662.     my $shell = PPMShell->new(target => $target);
  3663.     $shell->setmode('SHELL');
  3664.     $shell->cmdloop;
  3665. }
  3666. else {
  3667.     die <<END;
  3668.  
  3669. Error:
  3670.     PPM3 cannot be run in interactive shell mode unless both STDIN and
  3671.     STDOUT are connected to a terminal or console. If you want to
  3672.     capture the output of a command, use PPM3 in batch mode like this:
  3673.  
  3674.        ppm3 search IO-stringy > results.txt
  3675.  
  3676.     Type 'perldoc ppm3' for more information.
  3677.  
  3678. END
  3679. }
  3680.  
  3681.  
  3682. =head1 NAME
  3683.  
  3684. ppm3-bin - ppm3 executable
  3685.  
  3686. =head1 SYNOPSIS
  3687.  
  3688. Do not run I<ppm3-bin> manually. It is meant to be called by the wrapper
  3689. program I<ppm3>. See L<ppm3>.
  3690.  
  3691. =head1 DESCRIPTION
  3692.  
  3693. I<ppm3> runs I<ppm3-bin> after setting up a few environment variables. You
  3694. should run I<ppm3> instead.
  3695.  
  3696. For information about I<ppm3> commands, see L<ppm3>.
  3697.  
  3698. =head1 SEE ALSO
  3699.  
  3700. See L<ppm3>.
  3701.  
  3702. =head1 AUTHOR
  3703.  
  3704. ActiveState Corporation (support@ActiveState.com)
  3705.  
  3706. =head1 COPYRIGHT
  3707.  
  3708. Copyright (C) 2001, 2002, ActiveState Corporation. All Rights Reserved.
  3709.  
  3710. =cut
  3711.  
  3712. __END__
  3713. :endofperl
  3714.