home *** CD-ROM | disk | FTP | other *** search
/ PC World 2004 November / PCWorld_2004-11_cd.bin / software / topware / activeperl / ActivePerl-5.8.4.810-MSWin32-x86.exe / ActivePerl-5.8.4.810 / Perl / bin / ppm3-bin.bat < prev    next >
DOS Batch File  |  2004-06-01  |  147KB  |  4,905 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 Corp. All Rights Reserved.
  227. ActiveState is a devision of Sophos.
  228.  
  229. Entering interactive shell.
  230. END
  231.  
  232.     my $file = PPM::Config::get_license_file();
  233.     my $license;
  234.     if (open (my $LICENSE, $file)) {
  235.         $license = do { local $/; <$LICENSE> };
  236.     }
  237.     my $aspn = $license =~ /ASPN/;
  238.     my $profile_tracking_warning = ($profile_track || !$aspn) ? '' : <<'END';
  239.  
  240. Profile tracking is not enabled. If you save and restore profiles manually,
  241. your profile may be out of sync with your computer. See 'help profile' for
  242. more information.
  243. END
  244.     $o->inform($startup);
  245.     $o->inform(<<END);
  246.  Using $o->{API}{readline} as readline library.
  247. $profile_tracking_warning
  248. Type 'help' to get started.
  249.  
  250. END
  251.     }
  252.     else {
  253.     $o->inform("$NAME ($VERSION). Type 'help' to get started.\n");
  254.     }
  255.  
  256.     $o->term->SetHistory(@{$o->conf('history') || []})
  257.     if $o->term->Features->{setHistory};
  258. }
  259.  
  260. sub postloop {
  261.     my $o = shift;
  262.     trace(1, "PPM: exiting...\n");
  263.     if ($o->mode eq 'SHELL' and $o->term->Features->{getHistory}) {
  264.     my @h = $o->term->GetHistory;
  265.     my $max_history = $o->conf('max_history') || 100;
  266.     splice @h, 0, (@h - $max_history)
  267.         if @h > $max_history;
  268.     my $old = $o->setmode('SILENT');
  269.     $o->conf('history', \@h);
  270.     $o->setmode($old);
  271.     }
  272. }
  273.  
  274. #============================================================================
  275. # Cache of search and query results
  276. #============================================================================
  277. sub cache_set_current {
  278.     my $o = shift;
  279.     my $type = shift;
  280.     my $set = shift;
  281.     $set = $o->{SHELL}{CACHE}{$type}{current} unless defined $set;
  282.     $o->{SHELL}{CACHE}{$type}{current} = $set;
  283.     return $o->{SHELL}{CACHE}{$type}{current};
  284. }
  285.  
  286. sub cache_set_index {
  287.     my $o = shift;
  288.     my $type = shift;
  289.     my $index = shift;
  290.     $index = $o->{SHELL}{CACHE}{$type}{index} unless defined $index;
  291.     $o->{SHELL}{CACHE}{$type}{index} = $index;
  292.     return $o->{SHELL}{CACHE}{$type}{index};
  293. }
  294.  
  295. sub cache_set_add {
  296.     my $o = shift;
  297.     my $type = shift;
  298.     my $query = shift;
  299.     my $entries = shift;
  300.     my $sort_field = $o->conf('sort-field');
  301.     my @sorted = $o->sort_pkgs($sort_field, @$entries);
  302.     my $set = {
  303.           query => $query,
  304.           raw => $entries,
  305.           $sort_field => \@sorted,
  306.         };
  307.     push @{$o->{SHELL}{CACHE}{$type}{sets}}, $set;
  308. }
  309.  
  310. sub cache_entry {
  311.     my $o = shift;
  312.     my $type = shift;        # 'query' or 'cache';
  313.     my $index = shift;        # defaults to currently selected index
  314.     my $set = shift;        # defaults to currently selected set
  315.  
  316.     $index = $o->{SHELL}{CACHE}{$type}{index} unless defined $index;
  317.  
  318.     my $src = $o->cache_set($type, $set);
  319.     return undef unless $src and bounded(0, $index, $#$src);
  320.  
  321.     # Make sure we display only valid entries:
  322.     my $tar = $o->conf('target');
  323.     $src->[$index]->make_complete($tar);
  324.     return $src->[$index];
  325. }
  326.  
  327. sub cache_set {
  328.     my $o = shift;
  329.     my $type = shift;        # 'query' or 'cache'
  330.     my $set = shift;        # defaults to currently selected set
  331.     my $entry = shift;        # defaults to 'results';
  332.  
  333.     $entry = $o->conf('sort-field') unless defined $entry;
  334.     return undef unless grep { lc($entry) eq $_ } (sort_fields(), 'query');
  335.  
  336.     $set = $o->{SHELL}{CACHE}{$type}{current} unless defined $set;
  337.     my $src = $o->{SHELL}{CACHE}{$type}{sets};
  338.  
  339.     return undef unless defined $set;
  340.     return undef unless bounded(0, $set, $#$src);
  341.  
  342.     # We've changed sort-field at some point -- make sure the sorted data
  343.     # exists, or else build it:
  344.     unless (defined $src->[$set]{$entry}) {
  345.     my $raw = $src->[$set]{raw};
  346.     my @sorted = $o->sort_pkgs($entry, @$raw);
  347.     $src->[$set]{$entry} = \@sorted;
  348.     }
  349.     
  350.     return wantarray ? @{$src->[$set]{$entry}} : $src->[$set]{$entry};
  351. }
  352.  
  353. sub cache_clear {
  354.     my $o = shift;
  355.     my $type = shift;        # 'query' or 'cache'
  356.     $o->{SHELL}{CACHE}{$type}{sets} = [];
  357.     $o->{SHELL}{CACHE}{$type}{current} = -1;
  358.     $o->{SHELL}{CACHE}{$type}{index} = -1;
  359. }
  360.  
  361. sub cache_sets {
  362.     my $o = shift;
  363.     my $type = shift;
  364.     @{$o->{SHELL}{CACHE}{$type}{sets}};
  365. }
  366.  
  367. # This sub searches for an entry in the cache whose name matches that thing
  368. # passed in. It searches in the current cache first. If the name isn't found,
  369. # it searches in all caches. If the name still isn't found, it returns undef.
  370. sub cache_find {
  371.     my $o = shift;
  372.     my $type = shift;
  373.     my $name = shift;
  374.  
  375.     my $ncaches = $o->cache_sets($type);
  376.     my $current = $o->cache_set_current($type);
  377.  
  378.     # First, search the current set:
  379.     my @pkgs = map { $_ ? $_->name : '' } $o->cache_set($type);
  380.     my $ind  = find_index($name, 0, @pkgs);
  381.     return ($current, $ind) if $ind >= 0;
  382.  
  383.     # Now try to find in all the sets:
  384.     for my $s (0 .. $ncaches - 1) {
  385.     next if $s == $current;
  386.     @pkgs = map { $_ ? $_->name : '' } $o->cache_set($type, $s);
  387.     $ind  = find_index($name, 0, @pkgs);
  388.     return ($s, $ind) if $ind >= 0;
  389.     }
  390.     return (-1, -1);
  391. }
  392.  
  393. # A pretty separator to print between logically separate items:
  394. my $SEP;
  395. BEGIN {
  396.     $SEP = '=' x 20;
  397. }
  398.  
  399. # Useful functions:
  400. sub max (&@) {
  401.     my $code = shift;
  402.     my $max;
  403.     local $_;
  404.     for (@_) {
  405.     my $res = $code->($_);
  406.     $max = $res if not defined $max or $max < $res;
  407.     }
  408.     $max || 0;
  409. }
  410.  
  411. sub min (&@) {
  412.     my $code = shift;
  413.     my $min;
  414.     local $_;
  415.     for (@_) {
  416.     my $res = $code->($_);
  417.     $min = $res if not defined $min or $min > $res;
  418.     }
  419.     $min || 0;
  420. }
  421.  
  422. sub sum (&@) {
  423.     my $code = shift;
  424.     my $sum = 0;
  425.     local $_;
  426.     for (@_) {
  427.     my $res = $code->($_);
  428.     $sum += $res if defined $res;
  429.     }
  430.     $sum || 0;
  431. }
  432.  
  433. #============================================================================
  434. # Repository:
  435. # rep            # displays repositories
  436. # rep add http://...    # adds a new repository
  437. # rep del <\d+>        # deletes the specified repository
  438. # rep [set] 1        # sets the specified repository active
  439. #============================================================================
  440. sub smry_repository { "adds, removes, or sets repositories" }
  441. sub help_repository { <<'END' }
  442. repository -- Repository Control
  443.   Synopsis
  444.      rep                        Displays all repositories
  445.      rep add [name] <location>  Adds a new repository; makes it active
  446.      rep delete <name or num>   Deletes specified repository
  447.      rep describe <name or num> Displays information about the specified
  448.                                 repository
  449.      rep rename <name or num> <name>
  450.                                 Renames the specified repository to
  451.                                 the given name
  452.      rep on <name>              Activates the specified repository
  453.      rep off <name or num>      Removes the repository from the active list
  454.      rep up <name or num>       Moves the specified repository up one
  455.      rep down <name or num>     Moves the specified repository down one
  456.  
  457.     The <name> needs to be put inside doublequotes if it contains any
  458.     spaces.
  459.  
  460.   Description
  461.     The *repository* (or *rep*) command controls two lists or repositories:
  462.  
  463.     1   The list of "active" repositories. This is the list of repositories
  464.         used by *search*, *install*, and *upgrade*.
  465.  
  466.     2   The list of all known repositories. You can designate a repository
  467.         "inactive", which means PPM will not use it in any commands.
  468.  
  469.     If no arguments are given, the rep command will list the active
  470.     repositories defined in the PPM settings. The order is significant: when
  471.     installing a package, PPM will try the first repository, then the
  472.     second, and so on, until it find the package you asked for. When
  473.     searching, PPM merges the results of all the repositories together, so
  474.     the order is less important (see the *search* command).
  475.  
  476.     For example, when you enter:
  477.  
  478.         rep
  479.  
  480.     PPM3 will return something resembling this:
  481.  
  482.         Repositories:
  483.         [1] ActiveCD
  484.         [2] ActiveState Package Repository
  485.         [ ] An inactive repository
  486.  
  487.     In the example above, entering 'rep off 2' will disable the second
  488.     repository (the ActiveStat Package Repository). To add another
  489.     repository:
  490.  
  491.         rep add [options] <NAME> <LOCATION>
  492.  
  493.     The following options are available for the 'add' command:
  494.  
  495.     *   -username
  496.  
  497.     *   -password
  498.  
  499.     These options allow you to specify a username and password to be used
  500.     when logging into a repository. Currently, these are only used for FTP
  501.     and WWW repositories.
  502.  
  503.     For example:
  504.  
  505.         rep add "EZE" http://foo.com/MyPPMPackages
  506.  
  507.     with "EZE" being the name of the repository (for easy reference) and the
  508.     location noted by the http location. If you were to enter the rep
  509.     command again, you would see:
  510.  
  511.         ppm> rep
  512.         Repositories:
  513.         [1] ActiveCD
  514.         [2] ActiveState Package Repository
  515.         [3] EZE
  516.         [ ] An inactive repository
  517.  
  518.     To move the new repository to the top of the Active list, you would
  519.     type:
  520.  
  521.         ppm> rep up EZE
  522.         Repositories:
  523.         [1] ActiveCD
  524.         [2] EZE
  525.         [3] ActiveState Package Repository
  526.         [ ] An inactive repository
  527.         ppm> rep up EZE
  528.         Repositories:
  529.         [1] EZE
  530.         [2] ActiveCD
  531.         [3] ActiveState Package Repository
  532.         [ ] An inactive repository
  533.  
  534.     To disable the ActiveCD repository temporarily, enter the following:
  535.  
  536.         ppm> rep off ActiveCD
  537.         Repositories:
  538.         [1] EZE
  539.         [2] ActiveState Package Repository
  540.         [ ] ActiveCD
  541.         [ ] An inactive repository
  542.  
  543.     To describe a repository, refer to it either by name, or by the number
  544.     displayed next to the repository in the Active Repositories list. You
  545.     must refer to inactive repositories by their full name.
  546.  
  547.         ppm> rep describe 2
  548.         Describing Active Repository 2:
  549.             Name: ActiveState Package Repository
  550.         Location: http://ppm.ActiveState.com/cgibin/PPM/...
  551.             Type: PPMServer 2.00
  552.         ppm> rep describe ActiveCD
  553.         Describing Inactive Repository:
  554.             Name: ActiveCD
  555.         Location: F:\PPMPackages\5.8plus
  556.             Type: Local Directory
  557.  
  558.     To re-activate the ActiveCD repository, use the *rep on* command. You
  559.     must refer to inactive repositories by name, not number.
  560.  
  561.         ppm> rep on ActiveCD
  562.         Active Repositories:
  563.         [1] EZE
  564.         [2] ActiveState Package Repository
  565.         [3] ActiveCD
  566.         [ ] An inactive repository
  567.  
  568.   Repository Types
  569.     PPM3 supports several types of package repositories:
  570.  
  571.     1.  PPM Server 3
  572.  
  573.         ActiveState's SOAP-driven package server. Because all searches are
  574.         done server-side, the server can deliver much richer information
  575.         about packages than other repositories.
  576.  
  577.     2.  PPM Server 2
  578.  
  579.         The SOAP server designed for PPM version 2. PPM 3.1 ships with the
  580.         PPM2 repository as well as the PPM3 repository, so you can use
  581.         either. Simple searches are performed server-side. If your search is
  582.         too complicated for the server, PPM 3.1 will download the package
  583.         summary and search by itself.
  584.  
  585.     3.  Web Repositories
  586.  
  587.         Older versions of PPM used non-SOAP repositories (directories full
  588.         of PPD files accessible using a web browser). Over the history of
  589.         PPM, there have been several different ways of organising the files
  590.         so that PPM can search for packages properly. PPM3 tries to download
  591.         a summary file first -- if that fails, it gets the directory index.
  592.         It parses the summary or the index, and caches it. Searches are done
  593.         from the cache.
  594.  
  595.     4.  FTP Repositories
  596.  
  597.         FTP is another way of exposing a directory full of PPD files. PPM3
  598.         consideres FTP repositories a subset of Web repositories. Treat them
  599.         as identical: PPM3 downloads the summary or the "index" (file
  600.         listing in this case), parses it, and then searches from it.
  601.  
  602.     5.  Local Repositories
  603.  
  604.         To support installing packages from the ActiveCD, a local directory
  605.         can be a repository. PPM searches the files in the directory. All
  606.         valid path formats are supported, including UNC paths.
  607. END
  608. sub comp_repository {
  609.     my $o = shift;
  610.     my ($word, $line, $start) = @_;
  611.     my @words = $o->line_parsed($line);
  612.     my $words = scalar @words;
  613.     my @reps = PPM::UI::repository_list()->result_l;
  614.     my $reps = @reps;
  615.     my @compls = qw(add delete describe rename set select);
  616.     push @compls, ($reps ? (1 .. $reps) : ()); 
  617.  
  618.     if ($words == 1 or $words == 2 and $start != length($line)) {
  619.     return $o->completions($word, \@compls);
  620.     }
  621.     if ($words == 2 or $words == 3 and $start != length($line)) {
  622.     return (readline::rl_filename_list($word))
  623.       if $words[1] eq 'add';
  624.     return $o->completions($word, [1 .. $reps])
  625.       if $o->completions($words[1], [qw(delete describe rename set select)]) == 1;
  626.     }
  627.     ();
  628. }
  629. sub reps_all {
  630.     my $o = shift;
  631.     my $l = PPM::UI::repository_list();
  632.     unless ($l->is_success) {
  633.     $o->warn($l->msg);
  634.     return () unless $l->ok;
  635.     }
  636.     $l->result_l;
  637. }
  638. sub reps_on {
  639.     my $o = shift;
  640.     return @{$o->conf('active_reps')};
  641. }
  642. sub reps_off {
  643.     my $o = shift;
  644.     my @reps = $o->reps_all;
  645.     my @reps_on = $o->reps_on;
  646.     my @off;
  647.     for my $r (@reps) {
  648.     push @off, $r unless grep { $_ eq $r } @reps_on;
  649.     }
  650.     @off;
  651. }
  652. sub rep_on {
  653.     my $o = shift;
  654.     my $rep = shift;
  655.     my @reps = ($o->reps_on, $rep);
  656.     my $m = $o->setmode('SILENT');
  657.     $o->conf('active_reps', \@reps);
  658.     $o->setmode($m);
  659. }
  660. sub rep_off {
  661.     my $o = shift;
  662.     my $rep = shift;
  663.     my @reps = grep { $_ ne $rep } $o->reps_on;
  664.     my $m = $o->setmode('SILENT');
  665.     $o->conf('active_reps', \@reps);
  666.     $o->setmode($m);
  667. }
  668. sub rep_ison {
  669.     my $o = shift;
  670.     my $rep = shift;
  671.     scalar grep { $_ eq $rep } $o->reps_on;
  672. }
  673. sub rep_isoff {
  674.     my $o = shift;
  675.     my $rep = shift;
  676.     scalar grep { $_ eq $rep } $o->reps_off;
  677. }
  678. sub rep_exists {
  679.     my $o = shift;
  680.     my $rep = shift;
  681.     scalar grep { $_ eq $rep } $o->reps_all;
  682. }
  683. sub rep_uniq {
  684.     my $o = shift;
  685.     my $rep = shift;
  686.     unless ($o->rep_exists($rep) or $rep =~ /^\d+$/) {
  687.     /\Q$rep\E/i and return $_ for $o->reps_all;
  688.     }
  689.     $rep;
  690. }
  691. sub rep_up {
  692.     my $o = shift;
  693.     my $rep = shift;
  694.     my @reps = $o->reps_on;
  695.     my $ind = find_index($rep, 0, @reps);
  696.     if (bounded(1, $ind, $#reps)) {
  697.     @reps = (
  698.         @reps[0 .. $ind - 2],
  699.         $rep,
  700.         $reps[$ind - 1],
  701.         @reps[$ind + 1 .. $#reps]
  702.     );
  703.     }
  704.     my $m = $o->setmode('SILENT');
  705.     $o->conf('active_reps', \@reps);
  706.     $o->setmode($m);
  707. }
  708. sub rep_down {
  709.     my $o = shift;
  710.     my $rep = shift;
  711.     my @reps = $o->reps_on;
  712.     my $ind = find_index($rep, 0, @reps);
  713.     if (bounded(0, $ind, $#reps - 1)) {
  714.     @reps = (
  715.         @reps[0 .. $ind - 1],
  716.         $reps[$ind + 1],
  717.         $rep,
  718.         @reps[$ind + 2 .. $#reps]
  719.     );
  720.     }
  721.     my $m = $o->setmode('SILENT');
  722.     $o->conf('active_reps', \@reps);
  723.     $o->setmode($m);
  724. }
  725. sub run_repository {
  726.     my $o = shift;
  727.     my @args = @_;
  728.     my (@reps, @reps_off, @reps_on);
  729.     my $refresh = sub {
  730.     @reps = $o->reps_all;
  731.     @reps_off = $o->reps_off;
  732.     @reps_on = $o->reps_on;
  733.     };
  734.     &$refresh;
  735.     trace(1, "PPM: repository @args\n");
  736.  
  737.     if (@args) {
  738.     my $cmd = shift @args;
  739.     #=====================================================================
  740.     # add, delete, describe, rename commands:
  741.     #=====================================================================
  742.     if (matches($cmd, "add")) {
  743.         # Support for usernames and passwords.
  744.         my ($user, $pass);
  745.         {
  746.         local *ARGV;
  747.         @ARGV = @args;
  748.         GetOptions(
  749.             "username=s"    => \$user,
  750.             "password=s"    => \$pass,
  751.         );
  752.         @args = @ARGV;
  753.         }
  754.         $o->warn(<<END) and return unless @args;
  755. repository: invalid 'add' command arguments. See 'help repository'.
  756. END
  757.         my $url  = pop @args;
  758.         my $name = join(' ', @args);
  759.         unless ($name) {    # rep add http://...
  760.         $name = 'Autonamed';
  761.         for (my $i=1; $i<=@reps; $i++) {
  762.             my $tmp = "$name $i";
  763.             $name = $tmp and last
  764.               unless (grep { $tmp eq $_ } @reps);
  765.         }
  766.         }
  767.         my $ok = PPM::UI::repository_add($name, $url, $user, $pass);
  768.         unless ($ok->is_success) {
  769.         $o->warn($ok->msg);
  770.         return unless $ok->ok;
  771.         }
  772.         $o->rep_on($name);
  773.         $o->cache_clear('search');
  774.     }
  775.     elsif (matches($cmd, "del|ete")) {
  776.         my $arg = join(' ', @args);
  777.         my $gonner = $arg;
  778.         if ($arg =~ /^\d+$/) {
  779.         return unless $o->assert(
  780.             bounded(1, $arg, scalar @reps_on),
  781.             "no such active repository $arg"
  782.         );
  783.         $gonner = $reps_on[$arg - 1];
  784.         }
  785.         else {
  786.         $gonner = $o->rep_uniq($gonner);
  787.         return unless $o->assert(
  788.             $o->rep_exists($gonner),
  789.             "no such repository '$gonner'"
  790.         );
  791.         }
  792.         my $ok = PPM::UI::repository_del($gonner);
  793.         unless ($ok->is_success) {
  794.         $o->warn($ok->msg);
  795.         return unless $ok->ok;
  796.         }
  797.         $o->rep_off($gonner);
  798.         $o->cache_clear('search');
  799.     }
  800.     elsif (matches($cmd, "des|cribe")) {
  801.         my $arg = join(' ', @args) || 1;
  802.         my $rep = $arg;
  803.         if ($arg =~ /^\d+$/) {
  804.         return unless $o->assert(
  805.             bounded(1, $arg, scalar @reps_on),
  806.             "no such active repository $arg"
  807.         );
  808.         $rep = $reps_on[$arg - 1];
  809.         }
  810.         else {
  811.         $rep = $o->rep_uniq($rep);
  812.         return unless $o->assert(
  813.             $o->rep_exists($rep),
  814.             "no such repository '$rep'"
  815.         );
  816.         }
  817.         my $info = PPM::UI::repository_info($rep);
  818.         unless ($info->is_success) {
  819.         $o->warn($info->msg);
  820.         return unless $info->ok;
  821.         }
  822.         my $type = $o->rep_ison($rep) ? "Active" : "Inactive";
  823.         my $num  = (
  824.         $o->rep_ison($rep)
  825.         ? " " . find_index($rep, 1, @reps_on)
  826.         : ""
  827.         );
  828.         my @info = $info->result_l;
  829.         my @keys = qw(Name Location Type);
  830.         push @keys, qw(Username) if @info >= 4;
  831.         push @keys, qw(Password) if @info >= 5;
  832.         $o->inform("Describing $type Repository$num:\n");
  833.         $o->print_pairs(\@keys, \@info);
  834.         return 1;
  835.     }
  836.     elsif (matches($cmd, 'r|ename')) {
  837.         my $name = pop @args;
  838.         my $arg = join(' ', @args);
  839.         my $rep = $arg;
  840.         if ($arg =~ /^\d+$/) {
  841.         return unless $o->assert(
  842.             bounded(1, $arg, scalar @reps_on),
  843.             "no such active repository $arg"
  844.         );
  845.         $rep = $reps_on[$arg - 1];
  846.         }
  847.         else {
  848.         $rep = $o->rep_uniq($rep);
  849.         return unless $o->assert(
  850.             $o->rep_exists($rep),
  851.             "no such repository '$rep'"
  852.         );
  853.         }
  854.         my $ok = PPM::UI::repository_rename($rep, $name);
  855.         unless ($ok->is_success) {
  856.         $o->warn($ok->msg);
  857.         return unless $ok->ok;
  858.         }
  859.         $o->rep_on($name) if $o->rep_ison($rep);
  860.         $o->rep_off($rep);
  861.         $o->cache_clear('search');
  862.     }
  863.  
  864.     #=====================================================================
  865.     # On, off, up, and down commands:
  866.     #=====================================================================
  867.     elsif (matches($cmd, 'on')) {
  868.         my $rep = $o->rep_uniq(join(' ', @args));
  869.         return unless $o->assert(
  870.         $o->rep_isoff($rep),
  871.         "no such inactive repository '$rep'"
  872.         );
  873.         $o->rep_on($rep);
  874.         $o->cache_clear('search');
  875.     }
  876.     elsif (matches($cmd, 'of|f')) {
  877.         my $arg = join(' ', @args);
  878.         my $rep = $arg;
  879.         if ($arg =~ /^\d+$/) {
  880.         return unless $o->assert(
  881.             bounded(1, $arg, scalar @reps_on),
  882.             "no such active repository $arg"
  883.         );
  884.         $rep = $reps_on[$arg - 1];
  885.         }
  886.         else {
  887.         $rep = $o->rep_uniq($rep);
  888.         return unless $o->assert(
  889.             $o->rep_exists($rep),
  890.             "no such repository '$rep'"
  891.         );
  892.         }
  893.         $o->rep_off($rep);
  894.         $o->cache_clear('search');
  895.     }
  896.     elsif (matches($cmd, 'up')) {
  897.         my $arg = join(' ', @args);
  898.         my $rep = $arg;
  899.         if ($arg =~ /^\d+$/) {
  900.         return unless $o->assert(
  901.             bounded(1, $arg, scalar @reps_on),
  902.             "no such active repository $arg"
  903.         );
  904.         $rep = $reps_on[$arg - 1];
  905.         }
  906.         else {
  907.         $rep = $o->rep_uniq($rep);
  908.         return unless $o->assert(
  909.             $o->rep_exists($rep),
  910.             "no such repository '$rep'"
  911.         );
  912.         }
  913.         $o->rep_up($rep);
  914.     }
  915.     elsif (matches($cmd, 'do|wn')) {
  916.         my $arg = join(' ', @args);
  917.         my $rep = $arg;
  918.         if ($arg =~ /^\d+$/) {
  919.         return unless $o->assert(
  920.             bounded(1, $arg, scalar @reps_on),
  921.             "no such active repository $arg"
  922.         );
  923.         $rep = $reps_on[$arg - 1];
  924.         }
  925.         else {
  926.         $rep = $o->rep_uniq($rep);
  927.         return unless $o->assert(
  928.             $o->rep_exists($rep),
  929.             "no such repository '$rep'"
  930.         );
  931.         }
  932.         $o->rep_down($rep);
  933.     }
  934.  
  935.     else {
  936.         $o->warn(<<END) and return;
  937. No such repository command '$cmd'; see 'help repository'.
  938. END
  939.     }
  940.     }
  941.     &$refresh;
  942.     unless(@reps) {
  943.     $o->warn("No repositories. Use 'rep add' to add a repository.\n");
  944.     }
  945.     else {
  946.     my $i = 0;
  947.     my $count = @reps_on;
  948.     my $l = length($count);
  949.     $o->inform("Repositories:\n");
  950.     for my $r (@reps_on) {
  951.         my $n = sprintf("%${l}d", $i + 1);
  952.         $o->inform("[$n] $r\n");
  953.         $i++;
  954.     }
  955.     for my $r ($o->dictsort(@reps_off)) {
  956.         my $s = ' ' x $l;
  957.         $o->inform("[$s] $r\n");
  958.     }
  959.     }
  960.     1;
  961. }
  962.  
  963. #============================================================================
  964. # Search:
  965. # search        # displays previous searches
  966. # search <\d+>        # displays results of previous search
  967. # search <terms>    # executes a new search on the current repository
  968. #============================================================================
  969. sub smry_search { "searches for packages in a repository" }
  970. sub help_search { <<'END' }
  971. search -- Search for Packages
  972.   Synopsis
  973.      search                Displays list of previous searches
  974.      search <number>       Displays results of search <number>
  975.      search <glob pattern> Performs a new search
  976.      search <field>=<glob> Searches for all packages matching the field.
  977.      search *              Displays all packages in the current repository
  978.  
  979.     The available fields are 'ABSTRACT', 'NAME', 'TITLE', 'AUTHOR', and
  980.     'VERSION'. 'NAME' is used when you do not specify a field.
  981.  
  982.   Description
  983.     Use the search command to look through the repository for packages. PPM
  984.     version 3 provides powerful search functionality. For example:
  985.  
  986.     1.  Search for 'CGI' anywhere in the name:
  987.  
  988.           search CGI
  989.  
  990.         Example results:
  991.  
  992.           Apache-CGI
  993.           CGI-Application
  994.           CGI-ArgChecker
  995.  
  996.     2.  Search for 'CGI' at the beginning of the name:
  997.  
  998.           search CGI*
  999.  
  1000.         Example results:
  1001.  
  1002.           CGI-ArgChecker
  1003.           CGI-Application
  1004.  
  1005.     3.  Search for all modules authored by someone with 'smith' in their
  1006.         name or email:
  1007.  
  1008.           search AUTHOR=smith 
  1009.  
  1010.         Example results:
  1011.  
  1012.           Apache-ProxyPass
  1013.           Business-ISBN
  1014.  
  1015.     4.  Search for 'compress' anywhere in the abstract:
  1016.  
  1017.           search ABSTRACT=compress
  1018.  
  1019.         Example results:
  1020.  
  1021.           Apache-GzipChain
  1022.           IO-Zlib
  1023.  
  1024.     5.  Search for 'CGI' in the name, or 'web' in the abstract:
  1025.  
  1026.           search CGI or ABSTRACT=web
  1027.  
  1028.         Example results:
  1029.  
  1030.           CGI-XMLForm
  1031.           HTML-Clean
  1032.  
  1033.     6.  Search for 'XML' in the name and either 'parser' in the name or
  1034.         'pars' in the abstract, but not with 'XPath' in the name:
  1035.  
  1036.           search XML and (parser or ABSTRACT=pars) and not XPath
  1037.  
  1038.         Example results:
  1039.  
  1040.           XML-Node
  1041.           XML-Parser-EasyTree
  1042.  
  1043.     7.  PPM Server 3 repositories only: search by module name, even if
  1044.         unrelated to the containing package:
  1045.  
  1046.           search Data::Grove
  1047.                                 
  1048.         Example results:
  1049.  
  1050.           libxml-perl
  1051.  
  1052.     8.  Browse all packages in the repository:
  1053.  
  1054.           search *
  1055.  
  1056.         Example results:
  1057.  
  1058.           Affix-Infix2Postfix
  1059.           AI-Fuzzy
  1060.           [many more...]
  1061.  
  1062.     Recall previous searches using the 'search <number>' command. PPM stores
  1063.     searches for each session until you exit PPM.
  1064.  
  1065.     Some package names or versions are too long to be displayed in the
  1066.     search results. If a name is too long, you will see a '~' (tilde) as the
  1067.     last visible character in the column. You can use *describe* to view
  1068.     detailed information about such packages.
  1069.  
  1070.   Search Results
  1071.     When you type a command like "search XML", PPM searches in each of the
  1072.     Active Repositories (see the *repository* command) for your package. The
  1073.     results are merged into one list, and duplicates (packages found in more
  1074.     than one repository) are hidden.
  1075.  
  1076.     You can control what fields PPM shows for each package. The fields each
  1077.     have a built-in weight, which is used to calculate how wide to make each
  1078.     field based on the width of your screen. Information that doesn't fit
  1079.     into a field is truncated, and a tilde ("~") character is displayed in
  1080.     the last column of the field.
  1081.  
  1082.     Let's get down to an example:
  1083.  
  1084.         ppm> search XML
  1085.         Searching in Active Repositories
  1086.             1. CGI-XMLForm           [0.10] Extension to CGI.pm which
  1087.             2. Data-DumpXML          [1.01] Dump arbitrary data structures
  1088.             3. DBIx-XML_RDB          [0.05] Perl extension for creating XML
  1089.             4. DBIx-XMLMessage       [0.03] XML Message exchange between DBI
  1090.             5. GoXML-XQI            [1.1.4] Perl extension for the XML Query
  1091.             6. Language-DATR-DATR2~ [0.901] manipulate DATR .dtr, XML, HTML,
  1092.             7. libxml-perl           [0.07] support for deeply nested
  1093.             8. Mail-FilterXML         [0.1] Undetermined
  1094.             9. Mail-XML              [0.03] Adds a toXML() method to
  1095.            10. Pod-XML               [0.93] Module to convert POD to XML
  1096.  
  1097.     As you can see, the three fields being displayed are:
  1098.  
  1099.     1   NAME
  1100.  
  1101.         The package name
  1102.  
  1103.     2   VERSION
  1104.  
  1105.         The package version
  1106.  
  1107.     3   ABSTRACT
  1108.  
  1109.         The package abstract
  1110.  
  1111.     You can customize the view somewhat. If you want to view the authors,
  1112.     but not the abstract, you can run the same *search* command after using
  1113.     *set* to change the fields:
  1114.  
  1115.         ppm> set fields="NAME VERSION AUTHOR"
  1116.         Setting 'fields' set to 'name version author'.
  1117.         ppm> search XML
  1118.         Using cached search result set 1.
  1119.             1. CGI-XMLForm         [0.10] Matt Sergeant (matt@sergeant.org)
  1120.             2. Data-DumpXML        [1.01] Gisle Aas (gisle@aas.no)
  1121.             3. DBIx-XML_RDB        [0.05] Matt Sergeant (matt@sergeant.org)
  1122.             4. DBIx-XMLMessage     [0.03] Andrei Nossov (andrein@andrein.com)
  1123.             5. GoXML-XQI          [1.1.4] Matthew MacKenzie (matt@goxml.com)
  1124.             6. Language-DATR-DAT~ [0.901] Lee Goddard (lgoddard@cpan.org)
  1125.             7. libxml-perl         [0.07] Ken MacLeod (ken@bitsko.slc.ut.us)
  1126.             8. Mail-FilterXML       [0.1] Matthew MacKenzie (matt@goxml.com)
  1127.             9. Mail-XML            [0.03] Matthew MacKenzie (matt@goxml.com)
  1128.            10. Pod-XML             [0.93] Matt Sergeant (matt@sergeant.org)
  1129.  
  1130.     You can change the order in which the results are sorted, and what
  1131.     columns are displayed. The settings *fields* and *sort-field* changes
  1132.     this. You can sort by any valid field name (even fields which are not
  1133.     displayed). See the *settings* command for the valid field names.
  1134.  
  1135.     PPM always hides "duplicate" results. It decides whether a result is
  1136.     duplicated based on the fields being displayed. If the same package is
  1137.     found in more than one repository, but you don't have the REPOSITORY
  1138.     field showing, PPM will only list the package once.
  1139. END
  1140. sub comp_search {()}
  1141. sub run_search {
  1142.     my $o = shift;
  1143.     my @args = @_;
  1144.     my $query = $o->raw_args || join ' ', @args;
  1145.     trace(1, "PPM: search @args\n\tquery='$query'\n");
  1146.     return unless $o->assert(
  1147.     scalar $o->reps_on,
  1148.     "you must activate a repository before searching."
  1149.     );
  1150.  
  1151.     # No args: show cached result sets
  1152.     unless (@args) {
  1153.     my @search_results = $o->cache_sets('search');
  1154.     my $search_result_current = $o->cache_set_current('search');
  1155.     if (@search_results) {
  1156.         $o->inform("Search Result Sets:\n");
  1157.         my $i = 0;
  1158.         for (@search_results) {
  1159.         $o->informf("%s%2d",
  1160.                $search_result_current == $i ? "*" : " ",
  1161.                $i + 1);
  1162.         $o->inform(". $_->{query}\n");
  1163.         $i++;
  1164.         }
  1165.     }
  1166.     else {
  1167.         $o->warn("No search result sets -- provide a search term.\n");
  1168.         return;
  1169.     }
  1170.     }
  1171.  
  1172.     # Args:
  1173.     else {
  1174.     # Show specified result set
  1175.     if ($query =~ /^\d+/) {
  1176.         my $set = int($query);
  1177.         my $s = $o->cache_set('search', $set - 1);
  1178.         unless ($set > 0 and defined $s) {
  1179.         $o->warn("No such search result set '$set'.\n");
  1180.         return;
  1181.         }
  1182.  
  1183.         $query = $o->cache_set('search', $set-1, 'query');
  1184.         $o->inform("Search Results Set $set ($query):\n");
  1185.         $o->print_formatted($s, $o->cache_set_index('search'));
  1186.         $o->cache_set_current('search', $set-1);
  1187.         $o->cache_set_index('search', -1);
  1188.     }
  1189.        
  1190.     # Query is the same as a previous query on the same repository: 
  1191.     # Use cached results and set them as default
  1192.     elsif(grep { $_->{query} eq $query } $o->cache_sets('search')) {
  1193.         my @entries = $o->cache_sets('search');
  1194.         for (my $i=0; $i<@entries; $i++) {
  1195.         if ($o->cache_set('search', $i, 'query') eq $query) {
  1196.             $o->inform("Using cached search result set ", $i+1, ".\n");
  1197.             $o->cache_set_current('search', $i);
  1198.             my $set = $o->cache_set('search');
  1199.             $o->print_formatted($set);
  1200.         }
  1201.         }
  1202.     }
  1203.  
  1204.     # Perform a new search
  1205.     else {
  1206.         my @rlist = $o->reps_on;
  1207.         my $targ = $o->conf('target');
  1208.         my $case = not $o->conf('case-sensitivity');
  1209.  
  1210.         $o->inform("Searching in Active Repositories\n");
  1211.         my $ok = PPM::UI::search(\@rlist, $targ, $query, $case);
  1212.         unless ($ok->is_success) {
  1213.         $o->warn($ok->msg);
  1214.         return unless $ok->ok;
  1215.         }
  1216.         my @matches = $ok->result_l;
  1217.         unless (@matches) {
  1218.         $o->warn("No matches for '$query'; see 'help search'.\n");
  1219.         return 1;
  1220.         }
  1221.         $o->cache_set_index('search', -1);
  1222.         $o->cache_set_add('search', $query, \@matches);
  1223.         $o->cache_set_current('search', scalar($o->cache_sets('search')) - 1);
  1224.         my @set = $o->cache_set('search');
  1225.         $o->print_formatted(\@set);
  1226.     }
  1227.     }
  1228.     1;
  1229. }
  1230. sub alias_search { qw(s) }
  1231.  
  1232. #============================================================================
  1233. # tree
  1234. # tree        # shows the dependency tree for the default/current pkg
  1235. # tree <\d+>    # shows dep tree for numbered pkg in current search set
  1236. # tree <pkg>    # shows dep tree for given package
  1237. # tree <url>    # shows dep tree for package located at <url>
  1238. # tree <glob>    # searches for matches
  1239. #============================================================================
  1240. sub smry_tree { "shows package dependency tree" }
  1241. sub help_tree { <<'END' }
  1242. tree -- Show Dependency Tree for Packages
  1243.   Synopsis
  1244.      tree                Displays the dependency-tree of the current
  1245.                          or default package
  1246.      tree <number>       Displays the dependency-tree of the given <number>
  1247.      tree <range>        Displays a <range> of dependency-trees
  1248.      tree <package name> Displays the dependency-tree of the named package
  1249.      tree <url>          Displays the dependency-tree for the
  1250.                          package at <url>
  1251.      tree <glob pattern> Performs a new search using <glob pattern>
  1252.  
  1253.   Description
  1254.     The tree command is used to show the "dependency tree" of a given
  1255.     package (additional packages that are required by the current package).
  1256.     For example:
  1257.  
  1258.         tree SOAP-lite
  1259.  
  1260.     returns:
  1261.  
  1262.         ====================
  1263.         SOAP-Lite 0.51
  1264.         |__MIME-tools 5.316
  1265.         |   |__MailTools 1.15
  1266.         |   \__IO-stringy 1.216
  1267.         |
  1268.         \__MIME-Lite 2.105
  1269.         ====================
  1270.  
  1271.     SOAP-Lite requires four other packages.
  1272.  
  1273.     When tree is called without a <name> or <number> switch, the command
  1274.     will return the dependency tree of the first package in the default
  1275.     search result. If there is no default search, you will be requested to
  1276.     use search to find a package.
  1277. END
  1278. sub comp_tree { goto &comp_describe }
  1279. sub run_tree {
  1280.     my $o = shift;
  1281.     my @args = @_;
  1282.     trace(1, "PPM: tree @args\n");
  1283.  
  1284.     # Check for anything that looks like a query. If it does, just
  1285.     # send it to search() instead.
  1286.     my $query = $o->raw_args || join ' ', @args;
  1287.     $query ||= '';
  1288.     if ($query and not PPM::UI::is_pkg($args[0]) and not parse_range($query)) {
  1289.     $o->inform("Wildcards detected; using 'search' instead...\n");
  1290.     return $o->run('search', @_);
  1291.     }
  1292.  
  1293.     # No Args: describes current index of current result set, or 1.
  1294.     unless (@args) {
  1295.     my @search_results = $o->cache_sets('search');
  1296.     my $search_result_current = $o->cache_set_current('search');
  1297.     unless (@search_results and
  1298.         bounded(0, $search_result_current, $#search_results)) {
  1299.         $o->warn("No search results to show dependency tree for -- " . 
  1300.           "use 'search' to find a package.\n");
  1301.         return;
  1302.     }
  1303.     else {
  1304.         my @res = $o->cache_set('search');
  1305.         my $npkgs = @res;
  1306.         $o->inform("$SEP\n");
  1307.         if ($o->cache_entry('search')) {
  1308.         my $n = $o->cache_set_index('search') + 1;
  1309.         $o->inform("Package $n:\n");
  1310.         $o->tree_pkg($o->cache_entry('search'));
  1311.         }
  1312.         elsif (defined $o->cache_entry('search', 0)) {
  1313.         $o->inform("Package 1:\n");
  1314.         $o->tree_pkg($o->cache_entry('search', 0));
  1315.         $o->cache_set_index('search', 0);
  1316.         }
  1317.         else {
  1318.         $o->inform("Search Results are empty -- use 'search' again.\n");
  1319.         }
  1320.         $o->inform("$SEP\n");
  1321.     }
  1322.     }
  1323.  
  1324.     # Args provided
  1325.     else {
  1326.  
  1327.     # Describe a particular number:
  1328.     if (my @r = parse_range(@args)) {
  1329.         my @search_results = $o->cache_sets('search');
  1330.         my $search_result_current = $o->cache_set_current('search');
  1331.         unless (bounded(0, $search_result_current, $#search_results)) {
  1332.         $o->inform("No search results to show dependency tree for -- " . 
  1333.           "use 'search' to find a package.\n");
  1334.         return;
  1335.         }
  1336.         else {
  1337.         for my $n (@r) {
  1338.             my $sr = $o->cache_set('search');
  1339.             $o->inform("$SEP\n");
  1340.             if (bounded(1, $n, scalar @$sr)) {
  1341.             $o->inform("Package $n:\n");
  1342.             $o->tree_pkg($o->cache_entry('search', $n-1));
  1343.             }
  1344.             else {
  1345.             $o->inform("No such package $n in result set.\n");
  1346.             }
  1347.             $o->cache_set_index('search', $n - 1);
  1348.         }
  1349.         $o->inform("$SEP\n");
  1350.         }
  1351.     }
  1352.  
  1353.     # Describe a particular package
  1354.     else {
  1355.         return unless $o->assert(
  1356.         scalar $o->reps_on,
  1357.         "No repositories -- use 'rep add' to add a repository.\n"
  1358.         );
  1359.         my $pkg =
  1360.           PPM::UI::describe([$o->reps_on], $o->conf('target'), $args[0]);
  1361.         unless ($pkg->is_success) {
  1362.         $o->warn($pkg->msg);
  1363.         return unless $pkg->ok;
  1364.         }
  1365.         if ($pkg->ok) {
  1366.         $o->inform("$SEP\n");
  1367.         $o->tree_pkg($pkg->result);
  1368.         $o->inform("$SEP\n");
  1369.         }
  1370.     }
  1371.     }
  1372.     1;
  1373. }
  1374.  
  1375. #============================================================================
  1376. # Describe:
  1377. # des        # describes default or current package
  1378. # des <\d+>    # describes numbered package in the current search set
  1379. # des <pkg>    # describes the named package (bypasses cached results)
  1380. # des <url>    # describes the package located at <url>
  1381. #============================================================================
  1382. sub smry_describe { "describes packages in detail" }
  1383. sub help_describe { <<'END' }
  1384. describe -- Describe Packages
  1385.   Synopsis
  1386.      des                Describes default/current package
  1387.      des <number>       Describes package <number> in the
  1388.                         current search set
  1389.      des <range>        Describes packages in the given 
  1390.                         <range> from the current search
  1391.      des <package name> Describes named package
  1392.      des <url>          Describes package located at <url>
  1393.      des <glob pattern> Performes a new search using <glob pattern>
  1394.  
  1395.   Description
  1396.     The describe command returns information about a package, including the
  1397.     name of the package, the author's name and a brief description (called
  1398.     an "Abstract") about the package. For example:
  1399.  
  1400.         describe libnet
  1401.  
  1402.     returns:
  1403.  
  1404.         ===============================
  1405.         Package 1
  1406.         Name: libnet
  1407.         Version: 1.07.03
  1408.         Author: Graham Barr
  1409.         Abstract: Collection of Network protocol modules
  1410.         Implementations:
  1411.                 1.sun4-solaris-thread-multi
  1412.                 2.i686-linux-thread-multi
  1413.                 3.MSWIn32-x86-multi-thread
  1414.         ===============================
  1415.  
  1416.     There are two modifiers to the describe command:
  1417.  
  1418.     -ppd
  1419.         Displays the raw PPD of the package.
  1420.  
  1421.     -dump
  1422.         The same as -ppd.
  1423.  
  1424.     When the describe command is called without arguments, it returns
  1425.     information about the first package in the current search. If there is
  1426.     no default search set, you will be prompted to use the search command to
  1427.     find a package.
  1428.  
  1429.     If describe is called with a numeric argument, that number is set as the
  1430.     default package and the information about that package is returned. If
  1431.     the number given doesn't exist, you will be prompted to use search to
  1432.     find a package. Also, you can use describe to get descriptions of
  1433.     several packages. For example:
  1434.  
  1435.         describe 4-7
  1436.  
  1437.     will return descriptions of packages 4 through 7 in the current search
  1438.     request. You can also enter:
  1439.  
  1440.         describe 3-4,10
  1441.  
  1442.     to get information on packages 3, 4 and 10.
  1443.  
  1444.     If you specify a URL as the argument to describe, PPM will describe the
  1445.     package located at the URL. The URL must point to a PPD file. The URL
  1446.     can also point to a PPD file on your computer.
  1447.  
  1448.     When the describe command is given a name with a wildcard (such as "*"
  1449.     or "?") it executes the search command with the given argument. For
  1450.     example, describe Tk* will return the name(s) of any packages that match
  1451.     the search parameters.
  1452.  
  1453.   See Also
  1454.     properties
  1455. END
  1456. sub comp_describe {
  1457.     my $o = shift;
  1458.     my ($word, $line, $start) = @_;
  1459.  
  1460.     # If no search results
  1461.     my $n_results = $o->cache_sets('search');
  1462.     my $n_current = $o->cache_set_current('search');
  1463.     return ()
  1464.       unless ($n_results and bounded(0, $n_current, $n_results - 1));
  1465.     my @words = $o->line_parsed($line);
  1466.  
  1467.     # If the previous word isn't a number or the command, stop.
  1468.     return ()
  1469.       if ($#words > 0 and
  1470.       $words[$#words] !~ /^\d+/ and
  1471.       $start == length($line) or 
  1472.       $#words > 1);
  1473.  
  1474.     # This is the most optimistic list:
  1475.     my @results = $o->cache_set('search');
  1476.     my $npkgs = @results;
  1477.     my @compls = (1 .. $npkgs);
  1478.  
  1479.     # If the previous word is a number, return only other numbers:
  1480.     return $o->completions($word, \@compls)
  1481.       if $words[$#words] =~ /^\d+/;
  1482.  
  1483.     # Either a number or the names of the packages
  1484.     push @compls, map { $_->name } @results;
  1485.     return $o->completions($word, \@compls);
  1486. }
  1487. sub run_describe {
  1488.     my $o = shift;
  1489.     my @args = @_;
  1490.     
  1491.     # Check for options:
  1492.     my $ppd;
  1493.     {
  1494.     local @ARGV = @args;
  1495.     GetOptions(ppd => \$ppd, dump => \$ppd);
  1496.     @args = @ARGV;
  1497.     }
  1498.  
  1499.     trace(1, "PPM: describe @args\n");
  1500.  
  1501.     # Check for anything that looks like a query. If it does, just
  1502.     # send it to search() instead.
  1503.     my $query = $o->raw_args || join ' ', @args;
  1504.     if ($query and not PPM::UI::is_pkg($args[0]) and not parse_range($query)) {
  1505.     $o->inform("Wildcards detected; using 'search' instead...\n");
  1506.     return $o->run('search', @_);
  1507.     }
  1508.  
  1509.     my $dumper = sub {
  1510.     my $o = shift;
  1511.     my $pkg_obj = shift;
  1512.     my $ppd = $pkg_obj->getppd($o->conf('target'))->result;
  1513.     $o->page($ppd);
  1514.     };
  1515.     my $displayer = $ppd ? $dumper : \&describe_pkg;
  1516.  
  1517.     # No Args: describes current index of current result set, or 1.
  1518.     unless (@args) {
  1519.     my @search_results = $o->cache_sets('search');
  1520.     my $search_result_current = $o->cache_set_current('search');
  1521.     unless (@search_results and
  1522.         bounded(0, $search_result_current, $#search_results)) {
  1523.         $o->warn("No search results to describe -- " . 
  1524.           "use 'search' to find a package.\n");
  1525.         return;
  1526.     }
  1527.     else {
  1528.         my @res = $o->cache_set('search');
  1529.         my $npkgs = @res;
  1530.         $o->inform("$SEP\n");
  1531.         if ($o->cache_entry('search')) {
  1532.         my $n = $o->cache_set_index('search') + 1;
  1533.         $o->inform("Package $n:\n");
  1534.         $o->$displayer($o->cache_entry('search'));
  1535.         }
  1536.         elsif (defined $o->cache_entry('search', 0)) {
  1537.         $o->inform("Package 1:\n");
  1538.         $o->$displayer($o->cache_entry('search', 0));
  1539.         $o->cache_set_index('search', 0);
  1540.         }
  1541.         else {
  1542.         $o->warn("Search Results are empty -- use 'search' again.\n");
  1543.         }
  1544.         $o->inform("$SEP\n");
  1545.     }
  1546.     }
  1547.  
  1548.     # Args provided
  1549.     else {
  1550.  
  1551.     # Describe a particular number:
  1552.     if (my @r = parse_range(@args)) {
  1553.         my @search_results = $o->cache_sets('search');
  1554.         my $search_result_current = $o->cache_set_current('search');
  1555.         unless (bounded(0, $search_result_current, $#search_results)) {
  1556.         $o->warn("No search results to describe -- " . 
  1557.           "use 'search' to find a package.\n");
  1558.         return;
  1559.         }
  1560.         else {
  1561.         for my $n (@r) {
  1562.             my $sr = $o->cache_set('search');
  1563.             $o->inform("$SEP\n");
  1564.             if (bounded(1, $n, scalar @$sr)) {
  1565.             $o->inform("Package $n:\n");
  1566.             $o->$displayer($o->cache_entry('search', $n-1));
  1567.             }
  1568.             else {
  1569.             $o->inform("No such package $n in result set.\n");
  1570.             }
  1571.             $o->cache_set_index('search', $n - 1);
  1572.         }
  1573.         $o->inform("$SEP\n");
  1574.         }
  1575.     }
  1576.  
  1577.     # Describe a particular package
  1578.     else {
  1579.         return unless $o->assert(
  1580.         scalar $o->reps_on,
  1581.         "No repositories -- use 'rep add' to add a repository.\n"
  1582.         );
  1583.         my ($set, $index) = $o->cache_find('search', $args[0]);
  1584.         my ($ok, $pkg);
  1585.         if ($index >= 0) {
  1586.         $o->cache_set_current('search', $set);
  1587.         $o->cache_set_index('search', $index);
  1588.         $pkg = $o->cache_entry('search');
  1589.         }
  1590.         else {
  1591.         $ok = PPM::UI::describe([$o->reps_on],
  1592.                     $o->conf('target'), $args[0]);
  1593.         unless ($ok->is_success) {
  1594.             $o->inform($ok->msg);
  1595.             return unless $ok->ok;
  1596.         }
  1597.         $pkg = $ok->result;
  1598.         $o->cache_set_add('search', $args[0], [$pkg]);
  1599.         my $last = $o->cache_sets('search') - 1;
  1600.         $o->cache_set_current('search', $last);
  1601.         $o->cache_set_index('search', 0);
  1602.         }
  1603.         $o->inform("$SEP\n");
  1604.         $o->$displayer($pkg);
  1605.         $o->inform("$SEP\n");
  1606.     }
  1607.     }
  1608.     1;
  1609. }
  1610.  
  1611. #============================================================================
  1612. # Install:
  1613. # i        # installs default or current package
  1614. # i <\d+>    # installs numbered package in current search set
  1615. # i <pkg>    # installs named package
  1616. # i <url>    # installs the package at <url>
  1617. #============================================================================
  1618. sub smry_install { "installs packages" }
  1619. sub help_install { <<'END' }
  1620. install -- Install Packages
  1621.   Synopsis
  1622.      install           Installs default package
  1623.      install <number>  Installs packages by a specific <number>
  1624.      install <range>   Installs packages in the given numeric <range>
  1625.      install <name>    Installs named package
  1626.      install <url>     Installs the package located at <url>
  1627.  
  1628.   Description
  1629.     The install command is used to install packages from the repository.
  1630.     Install packages by name or number (the number is given by the
  1631.     repository or search request), or set a default package using the
  1632.     describe command. You can specify a full URL to a PPD file; the URL may
  1633.     point to a PPD file on your computer.
  1634.  
  1635.     If you have profile tracking enabled, (see 'help profile') the current
  1636.     profile will be updated to include the newly installed package(s).
  1637.  
  1638.     The following modifiers can be used with the install command:
  1639.  
  1640.     *   -force
  1641.  
  1642.     *   -noforce
  1643.  
  1644.     *   -follow
  1645.  
  1646.     *   -nofollow
  1647.  
  1648.     The force and follow switches determine how packages are installed:
  1649.  
  1650.      FORCE       FOLLOW          RESULT
  1651.      false       false           Checks to see if the package is installed and
  1652.                                  if it is, installation stops. If there are any
  1653.                                  missing prerequisites, the installation will
  1654.                                  fail.
  1655.  
  1656.      false       true            Checks to see if the package is installed and
  1657.                                  if it is, installation stops. If there are any
  1658.                                  missing prerequisites, they are automatically
  1659.                                  installed. NOTE: this is the default setting
  1660.                                  when PPM is first installed.
  1661.  
  1662.      true        false           If the package is installed, PPM will
  1663.                                  reinstall the package. If there are any
  1664.                                  missing prerequisites, the installation will
  1665.                                  fail.
  1666.  
  1667.      true        true            If the package is installed, PPM will
  1668.                                  reinstall the package. All prerequisites are
  1669.                                  installed, missing or not.
  1670.     
  1671.     If you do not specify any options, install uses the default settings.
  1672.     Set or view the current defaults using the 'settings' command.
  1673.  
  1674.     For example:
  1675.  
  1676.         install foo
  1677.  
  1678.     will install the package named "foo", using the default settings.
  1679.     Over-ride the defaults using the install modifiers described above.
  1680.  
  1681.     For example:
  1682.  
  1683.         install foo -force
  1684.  
  1685.     will install the "foo" package, even if it has already been installed.
  1686.     If both -force and -follow are set to "true", all the prerequisites for
  1687.     any package you install will also be installed. For example, the
  1688.     installation of a tk-related package, like "tk-ach" which is 8.4 kB will
  1689.     be preceded by the installation of Tk, which is 1.7 MB.
  1690.  
  1691.     You can also install by package number. Package numbers are based on the
  1692.     current repository or current search request. For example:
  1693.  
  1694.         install 6
  1695.  
  1696.     installs package number 6. You can install more than one package at one
  1697.     time:
  1698.  
  1699.         install 3-5
  1700.  
  1701.     installs packages 3, 4 and 5. You can also type install 3-6,8 to install
  1702.     packages 3,4,5,6 and 8.
  1703.  
  1704.   See Also
  1705.     profile
  1706. END
  1707. sub comp_install { goto &comp_describe }
  1708. sub run_install {
  1709.     my $o = shift;
  1710.     my @args = @_;
  1711.     trace(1, "PPM: install @args\n");
  1712.  
  1713.     # Get the install options
  1714.     my %opts = (
  1715.     force  => $o->conf('force-install'),
  1716.     follow => $o->conf('follow-install'),
  1717.     dryrun => 0,
  1718.     );
  1719.     {
  1720.     local @ARGV = @args;
  1721.     GetOptions('force!'  => \$opts{force},
  1722.            'follow!' => \$opts{follow},
  1723.            'dryrun'  => \$opts{dryrun},
  1724.           );
  1725.     @args = @ARGV;
  1726.     }
  1727.  
  1728.     # No Args -- installs default package
  1729.     unless (@args) {
  1730.     my @search_results = $o->cache_sets('search');
  1731.     my $search_result_current = $o->cache_set_current('search');
  1732.     unless (@search_results and
  1733.         bounded(0, $search_result_current, $#search_results)) {
  1734.         $o->warn("No search results to install -- " . 
  1735.           "use 'search' to find a package.\n");
  1736.         return;
  1737.     }
  1738.     else {
  1739.         my @results = $o->cache_set('search');
  1740.         my $npkgs = @results;
  1741.         my $pkg;
  1742.         if ($o->cache_entry('search')) {
  1743.         my $n = $o->cache_set_index('search') + 1;
  1744.         $o->inform("Package $n:\n");
  1745.         $pkg = $o->cache_entry('search');
  1746.         }
  1747.         else {
  1748.         $o->inform("Package 1:\n");
  1749.         $pkg = $o->cache_entry('search', 0);
  1750.         }
  1751.         return $o->install_pkg($pkg, \%opts);
  1752.     }
  1753.     }
  1754.  
  1755.     # Args provided
  1756.     else {
  1757.  
  1758.     # Install a particular number:
  1759.     if (my @r = parse_range(@args)) {
  1760.         my @search_results = $o->cache_sets('search');
  1761.         my $search_result_current = $o->cache_set_current('search');
  1762.         unless (@search_results and
  1763.             bounded(0, $search_result_current, $#search_results)) {
  1764.         $o->warn("No search results to install -- " . 
  1765.           "use 'search' to find a package.\n");
  1766.         return;
  1767.         }
  1768.         else {
  1769.         my $ok = 0;
  1770.         for my $n (@r) {
  1771.             my $sr = $o->cache_set('search');
  1772.             if (bounded(1, $n, scalar @$sr)) {
  1773.             $o->inform("Package $n:\n");
  1774.             my $pkg = $sr->[$n-1];
  1775.             $ok++ if $o->install_pkg($pkg, \%opts);
  1776.             }
  1777.             else {
  1778.             $o->inform("No such package $n in result set.\n");
  1779.             }
  1780.         }
  1781.         return unless $ok;
  1782.         }
  1783.     }
  1784.  
  1785.     # Install a particular package
  1786.     else {
  1787.         unless ($o->reps_all) {
  1788.         $o->warn("Can't install: no repositories defined.\n");
  1789.         }
  1790.         else {
  1791.         return $o->install_pkg($args[0], \%opts);
  1792.         }
  1793.         return;
  1794.     }
  1795.     }
  1796.     1;
  1797. }
  1798.  
  1799. #============================================================================
  1800. # Target:
  1801. # t        # displays a list of backend targets
  1802. # t [set] <\d+>    # sets numbered target as default backend target
  1803. # t des [<\d+>]    # describes the given (or default) target
  1804. #============================================================================
  1805. sub smry_targets { "views or sets target installer backends" }
  1806. sub help_targets { <<'END' }
  1807. targets -- View Target Installer Backends
  1808.   Synopsis
  1809.      target                      Displays a list of backend targets
  1810.      target <number>             Sets <number> as default backend target
  1811.      target [select] <name or num>
  1812.                                  Sets <name or num> as default backend target
  1813.      target describe [name or num]
  1814.                                  Describes the given (or default) target
  1815.      target set <key> <val>      Sets the target's <key> to <val> 
  1816.      target rename <name or num> <name>
  1817.                                  Renames the given target to <name>
  1818.  
  1819.   Description
  1820.     The target is the destination location of the install routine, such as
  1821.     the directory where the packages are installed when they're downloaded
  1822.     from the repository. For example:
  1823.  
  1824.         target
  1825.  
  1826.     returns:
  1827.  
  1828.         Targets:
  1829.           1. ActivePerl 618
  1830.         * 2. ActivePerl 629
  1831.  
  1832.     This shows that there are two available targets, and that the second
  1833.     target (ActivePerl 629) is currently the default (as shown by the
  1834.     asterisk). Using multiple targets, you can manage multiple installations
  1835.     of Perl from a single command-line.
  1836. END
  1837. sub comp_targets {
  1838.     my $o = shift;
  1839.     my ($word, $line, $start) = @_;
  1840.     my @words = $o->line_parsed($line);
  1841.     my $words = scalar @words;
  1842.     my @compls;
  1843.     my @targs = PPM::UI::target_list()->result_l;
  1844.  
  1845.     # only return 'set' and 'describe' when we're completing the second word
  1846.     if ($words == 1 or $words == 2 and $start != length($line)) {
  1847.     @compls = ('set', 'select', 'describe', 'rename', 1 .. scalar @targs);
  1848.     return $o->completions($word, \@compls);
  1849.     }
  1850.  
  1851.     if ($words == 2 or $words == 3 and $start != length($line)) {
  1852.     # complete 'set'
  1853.     if (matches($words[1], 's|et')) {
  1854.         my $targ = $o->conf('target');
  1855.         @compls = map { $_->[0] }
  1856.               grep { $_->[1] }
  1857.               PPM::UI::target_config_keys($targ)->result_l;
  1858.         return $o->completions($word, \@compls);
  1859.     }
  1860.     # complete 'describe' and 'rename'
  1861.     elsif (matches($words[1], 'd|escribe')
  1862.         or matches($words[1], 'r|ename')
  1863.         or matches($words[1], 's|elect')) {
  1864.         return $o->completions($word, [1 .. scalar @targs]);
  1865.     }
  1866.     }
  1867.     ();
  1868. }
  1869. sub run_targets {
  1870.     my $o = shift;
  1871.     my @args = @_;
  1872.     trace(1, "PPM: target @args\n");
  1873.  
  1874.     my @targets = PPM::UI::target_list()->result_l;
  1875.     my $targets = @targets;
  1876.  
  1877.     # No arguments: print targets
  1878.     if (@args) {
  1879.     my ($cmd, @rest) = @args;
  1880.     if ($cmd =~ /^\d+$/
  1881.         or matches($cmd, 'se|lect')) {
  1882.         my $num =     $cmd =~ /^\d+$/        ? $cmd        :
  1883.             $rest[0] =~ /^\d+$/    ? $rest[0]    :
  1884.             do {
  1885.                 my $n = find_index($rest[0], 1, @targets);
  1886.                 if ($n < 1) {
  1887.                 $o->warn("No such target '$rest[0]'.\n");
  1888.                 return;
  1889.                 }
  1890.                 $n;
  1891.             };
  1892.  
  1893.         # QA the number: is it too high/low?
  1894.         unless(bounded(1, $num, $targets)) {
  1895.         $o->warn("No such target number '$num'.\n");
  1896.         return;
  1897.         }
  1898.         else {
  1899.         $o->conf('target', $targets[$num-1]);
  1900.         $o->cache_clear('query');
  1901.         }
  1902.     }
  1903.     elsif (matches($cmd, 'r|ename')) {
  1904.         my ($oldnum, $newname) = @rest;
  1905.         $oldnum =    $oldnum =~ /^\d+$/ ? $oldnum :
  1906.             do {
  1907.                 my $n = find_index($oldnum, 1, @targets);
  1908.                 if ($n < 1) {
  1909.                 $o->warn("No such target '$oldnum'.\n");
  1910.                 return;
  1911.                 };
  1912.                 $n;
  1913.             };
  1914.         unless (defined $oldnum && $oldnum =~ /^\d+$/) {
  1915.         $o->warn(<<END);
  1916. target: '$cmd' requires a numeric argument. See 'help $cmd'.
  1917. END
  1918.         return;
  1919.         }
  1920.         unless (bounded(1, $oldnum, $targets)) {
  1921.         $o->warn("No such target number '$oldnum'.\n");
  1922.         return;
  1923.         }
  1924.         unless (defined $newname and $newname) {
  1925.         $newname = '' unless defined $newname;
  1926.         $o->warn(<<END);
  1927. Target names must be non-empty: '$newname' is not a valid name.
  1928. END
  1929.         return;
  1930.         }
  1931.         
  1932.         my $oldname = $targets[$oldnum - 1];
  1933.         my $ret = PPM::UI::target_rename($oldname, $newname);
  1934.         $o->warn($ret->msg) unless $ret->ok;
  1935.         $o->conf('target', $newname)
  1936.           if $o->conf('target') eq $oldname;
  1937.         @targets = PPM::UI::target_list()->result_l;
  1938.         $targets = scalar @targets;
  1939.     }
  1940.     elsif (matches($cmd, "s|et")) {
  1941.         my ($key, $value) = @rest;
  1942.         if (defined $key and $key =~ /=/ and not defined $value) {
  1943.         ($key, $value) = split /=/, $key;
  1944.         }
  1945.         unless(defined($key) && $key) {
  1946.         $o->warn(<<END);
  1947. You must specify what option to set. See 'help target'.
  1948. END
  1949.         return;
  1950.         }
  1951.         unless(defined($value)) {
  1952.         $o->warn(<<END);
  1953. You must provide a value for the option. See 'help target'.
  1954. END
  1955.         return;
  1956.         }
  1957.         my $targ = $o->conf('target');
  1958.         my %keys = map { @$_ }
  1959.                PPM::UI::target_config_keys($targ)->result_l;
  1960.         unless ($keys{$key}) {
  1961.         $o->warn("Invalid set key '$key'; these are the settable values:\n");
  1962.         $o->warn("    $_\n") for (grep { $keys{$_} } keys %keys);
  1963.         return;
  1964.         }
  1965.         my $ok = PPM::UI::target_config_set($targ, $key, $value);
  1966.         unless ($ok->is_success) {
  1967.         $o->warn($ok->msg);
  1968.         return unless $ok->ok;
  1969.         }
  1970.         $o->inform("Target attribute '$key' set to '$value'\n");
  1971.         return 1;
  1972.     }
  1973.     elsif (matches($cmd, "d|escribe")) {
  1974.         my %opts = (exec => 1);
  1975.         my $sel;
  1976.         if (@rest) {
  1977.         local @ARGV = @rest;
  1978.         GetOptions(\%opts, 'exec!');
  1979.         @rest = @ARGV;
  1980.         }
  1981.         if (@rest) {
  1982.         $sel =    $rest[0] =~ /^\d+$/ ? $rest[0] :
  1983.                 do {
  1984.                 my $n = find_index($rest[0], 1, @targets);
  1985.                 if ($n < 1) {
  1986.                     $o->warn("No such target '$rest[0]'.\n");
  1987.                     return;
  1988.                 };
  1989.                 $n;
  1990.                 };
  1991.         unless(bounded(1, $sel, $targets)) {
  1992.             $o->warn("No such target number '$sel'.\n");
  1993.         }
  1994.         }
  1995.         else {
  1996.         $sel = find_index($o->conf('target'), 1, @targets);
  1997.         }
  1998.         my $targ = $targets[$sel-1];
  1999.         my (@keys, @vals);
  2000.         my $res = $opts{exec}
  2001.         ? PPM::UI::target_info($targ)
  2002.         : PPM::UI::target_raw_info($targ);
  2003.         unless ($res->is_success) {
  2004.         $o->warn($res->msg);
  2005.         return unless $res->ok;
  2006.         }
  2007.         my %h = $res->result_h;
  2008.         my @h = sort keys %h;
  2009.         push @keys, @h;
  2010.         push @vals, $h{$_} for @h;
  2011.         if ($opts{exec}) {
  2012.         for (PPM::UI::target_config_info($targ)->result_l) {
  2013.             push @keys, $_->[0];
  2014.             push @vals, $_->[1];
  2015.         }
  2016.         }
  2017.         $_ = ucfirst $_ for @keys;
  2018.         $o->inform("Describing target $sel ($targ):\n");
  2019.         $o->print_pairs(\@keys, \@vals);
  2020.         return 1;
  2021.     }
  2022.     }
  2023.     unless($targets) {
  2024.     $o->warn("No targets. Install a PPM target.\n");
  2025.     return;
  2026.     }
  2027.     else {
  2028.     $o->conf('target', $targets[0])
  2029.         unless $o->conf('target');
  2030.     my $i = 0;
  2031.     $o->inform("Targets:\n");
  2032.     for (@targets) {
  2033.         $o->informf(
  2034.         "%s%2d",
  2035.         $o->conf('target') eq $targets[$i] ? "*" : " ",
  2036.         $i + 1
  2037.         );
  2038.         $o->inform(". $_\n");
  2039.         $i++;
  2040.     }
  2041.     }
  2042.     1;
  2043. }
  2044.  
  2045. #============================================================================
  2046. # Query:
  2047. # query        # displays list of previous queries
  2048. # query <\d+>    # displays results of previous query
  2049. # query <terms>    # performs a new query and displays results
  2050. #============================================================================
  2051. sub smry_query { "queries installed packages" }
  2052. sub help_query { <<'END' }
  2053. query -- Query Installed Packages
  2054.   Synopsis
  2055.      query                   Displays list of previous queries
  2056.      query <number>          Displays results of previous query
  2057.      query <glob pattern>    Performs a new query using <glob pattern>
  2058.      query *                 Displays a list of all installed packages
  2059.  
  2060.   Description
  2061.     The query command displays a list of all installed packages, or a list
  2062.     based on the <glob pattern> switch. You can also check the list of past
  2063.     queries, or the results of a past query.
  2064.  
  2065.     With PPM 3.1, you can now perform much more powerful queries. The syntax
  2066.     is identical to the 'search' command, and almost all the search switches
  2067.     are also available for querying installed packages.
  2068.  
  2069.     Recall previous queries with the 'query <number>' command. PPM3 stores
  2070.     all queries from the current PPM session.
  2071.  
  2072.     Note: Depending on the value of the "case-sensitivity" setting, the
  2073.     query may or may not be case-sensitive. See "help settings" for
  2074.     instructions on setting the default case sensitivity.
  2075.  
  2076.   See Also
  2077.     search, settings
  2078. END
  2079. sub comp_query {()}
  2080. sub run_query {
  2081.     my $o = shift;
  2082.     my $query = $o->raw_args || join ' ', @_;
  2083.     trace(1, "PPM: query @_\n\tquery='$query'\n");
  2084.     my @targets = PPM::UI::target_list()->result_l;
  2085.     my $target = $o->conf('target');
  2086.     my $case = not $o->conf('case-sensitivity');
  2087.     $o->warn("You must install an installation target before using PPM.\n")
  2088.       and return unless @targets;
  2089.  
  2090.     # No args: show cached query sets
  2091.     unless ($query =~ /\S/) {
  2092.     my @query_results = $o->cache_sets('query');
  2093.     my $query_result_current = $o->cache_set_current('query');
  2094.     if (@query_results) {
  2095.         $o->inform("Query Result Sets:\n");
  2096.         my $i = 0;
  2097.         for (@query_results) {
  2098.         $o->informf("%s%2d",
  2099.                $query_result_current == $i ? "*" : " ",
  2100.                $i + 1);
  2101.         $o->inform(". $_->{query}\n");
  2102.         $i++;
  2103.         }
  2104.     }
  2105.     else {
  2106.         $o->warn("No query result sets -- provide a query term.\n");
  2107.         return;
  2108.     }
  2109.     }
  2110.  
  2111.     # Args:
  2112.     else {
  2113.     # Show specified result set 
  2114.     if ($query =~ /^\d+/) {
  2115.         my $set = int($query);
  2116.         unless (defined $o->cache_set('query', $set-1)) {
  2117.         $o->warn("No such query result set '$set'.\n");
  2118.         return;
  2119.         }
  2120.  
  2121.         $query = $o->cache_set('query', $set-1, 'query');
  2122.         $o->inform("Query Results Set $set ($query):\n");
  2123.         $o->print_formatted([$o->cache_set('query', $set-1)],
  2124.                 $o->cache_set_index('query'));
  2125.                 
  2126.         $o->cache_set_current('query', $set-1);
  2127.         $o->cache_set_index('query', -1);
  2128.     }
  2129.  
  2130.     # Query is the same a a previous query on the same target:
  2131.     # Use cached results and set them as default
  2132.     elsif (grep { $_->{query} eq $query } $o->cache_sets('query')) {
  2133.         for (my $i=0; $i<$o->cache_sets('query'); $i++) {
  2134.         if ($o->cache_set('query', $i, 'query') eq $query) {
  2135.             $o->inform("Using cached query result set ", $i+1, ".\n");
  2136.             $o->cache_set_current('query', $i);
  2137.             my $set = $o->cache_set('query');
  2138.             $o->print_formatted($set);
  2139.         }
  2140.         }
  2141.     }
  2142.  
  2143.     # Perform a new query.
  2144.     else {
  2145.         my $num = find_index($target, 1, @targets);
  2146.         $o->inform("Querying target $num (");
  2147.         if (length($target) > 30) {
  2148.         $o->inform(substr($target, 0, 30), "...");
  2149.         }
  2150.         else {
  2151.         $o->inform($target);
  2152.         }
  2153.         $o->inform(")\n");
  2154.  
  2155.         my $res = PPM::UI::query($target, $query, $case);
  2156.         unless ($res->ok) {
  2157.         $o->inform($res->msg);
  2158.         return;
  2159.         }
  2160.         my @matches = $res->result_l;
  2161.         if (@matches) {
  2162.         $o->cache_set_add('query', $query, \@matches);
  2163.         $o->cache_set_current('query', scalar($o->cache_sets('query')) - 1);
  2164.         my @set = $o->cache_set('query');
  2165.         $o->print_formatted(\@set);
  2166.         }
  2167.         else {
  2168.         $o->warn("No matches for '$query'; see 'help query'.\n");
  2169.         }
  2170.     }
  2171.     }
  2172.     1;
  2173. }
  2174.  
  2175. #============================================================================
  2176. # Properties:
  2177. # prop        # describes default installed package
  2178. # prop <\d+>    # describes numbered installed package
  2179. # prop <pkg>    # describes named installed package
  2180. # prop <url>    # describes installed package at location <url>
  2181. #============================================================================
  2182. sub smry_properties { "describes installed packages in detail" }
  2183. sub help_properties { <<'END' }
  2184. properties -- Describe Installed Packages
  2185.   Synopsis
  2186.      prop                    Describes default installed package
  2187.      prop <number>           Describes installed package <number>
  2188.      prop <range>            Describes a <range> of installed packages
  2189.      prop <package name>     Describes named installed package
  2190.      prop <url>              Describes installed package located at <url>
  2191.      prop <glob pattern>     Performs a new query using <glob pattern>
  2192.  
  2193.   Description
  2194.     The properties command is an verbose form of the describe command. In
  2195.     addition to summary information, properties will display the
  2196.     installation date and a URL showing the location of the package within
  2197.     the repository.
  2198.  
  2199.     If you specify the package as a URL, PPM determines the package name
  2200.     from the URL and searches for that.
  2201.  
  2202.     When the properties command is used with wildcard arguments, the text
  2203.     entered at the PPM prompt is passed to the query command.
  2204.  
  2205.     For example, typing 'properties libnet' will give you:
  2206.  
  2207.         ====================
  2208.             Name: libnet
  2209.          Version: 1.07.03
  2210.           Author: Graham Barr
  2211.            Title: libnet
  2212.         Abstract: Collection of Network protocol modules
  2213.         InstDate: Fri Oct  2 16:15:15 1998
  2214.         Location: http://ppm.ActiveState.com/PPM/...
  2215.         ====================
  2216.  
  2217.   See Also
  2218.     describe
  2219. END
  2220. sub comp_properties {
  2221.     my $o = shift;
  2222.     my ($word, $line, $start) = @_;
  2223.  
  2224.     # If no query results
  2225.     my $n_results = scalar $o->cache_sets('query');
  2226.     my $n_current = $o->cache_set_current('query');
  2227.     unless ($n_results and bounded(0, $n_current, $n_results - 1)) {
  2228.     my $targ = $o->conf('target') or return ();
  2229.     my $r = PPM::UI::query($targ, '*');
  2230.     return () unless $r->ok;
  2231.     $o->cache_set_add('query', '*', $r->result);
  2232.     $o->cache_set_current('query', scalar($o->cache_sets('query')) - 1);
  2233.     }
  2234.     my @words = $o->line_parsed($line);
  2235.  
  2236.     # If the previous word isn't a number or the command, stop.
  2237.     return ()
  2238.       if ($#words > 0 and
  2239.       $words[$#words] !~ /^\d+/ and
  2240.       $start == length($line) or 
  2241.       $#words > 1);
  2242.  
  2243.     # This is the most optimistic list:
  2244.     my @results = $o->cache_set('query');
  2245.     my $npkgs = @results;
  2246.     my @compls = (1 .. $npkgs);
  2247.  
  2248.     # If the previous word is a number, return only other numbers:
  2249.     return $o->completions($word, \@compls)
  2250.       if ($words[$#words] =~ /^\d+/);
  2251.  
  2252.     # Either a number or the names of the packages
  2253.     push @compls, map { $_->name } @results;
  2254.     return $o->completions($word, \@compls);
  2255. }
  2256. sub run_properties {
  2257.     my $o = shift;
  2258.     my @args = @_;
  2259.     my $args = $args[0];
  2260.     trace(1, "PPM: properties @args\n");
  2261.  
  2262.     # Check for anything that looks like a query. If it does, send it
  2263.     # to query instead.
  2264.     my $query = $o->raw_args || join ' ', @args;
  2265.     $query ||= '';
  2266.     if ($query and not PPM::UI::is_pkg($args[0]) and not parse_range($query)) {
  2267.     $o->inform("Wildcards detected; using 'query' instead.\n");
  2268.     return $o->run('query', @_);
  2269.     }
  2270.     
  2271.     # No Args: describes current index of current result set, or 1.
  2272.     my $n_results = $o->cache_sets('query');
  2273.     my $n_current = $o->cache_set_current('query');
  2274.     my $ind = $o->cache_set_index('query');
  2275.     unless (@args) {
  2276.     unless ($n_results and bounded(0, $n_current, $n_results - 1)) {
  2277.         $o->inform("No query results to describe -- " . 
  2278.           "use 'query' to find a package.\n");
  2279.         return;
  2280.     }
  2281.     else {
  2282.         my @results = $o->cache_set('query');
  2283.         my $npkgs = @results;
  2284.         $o->inform("$SEP\n");
  2285.         if (bounded(0, $ind, $npkgs-1)) {
  2286.         my $n = $ind + 1;
  2287.         $o->inform("Package $n:\n");
  2288.         $o->describe_pkg($o->cache_entry('query', $ind));
  2289.         }
  2290.         else {
  2291.         $o->inform("Package 1:\n");
  2292.         $o->describe_pkg($results[0]);
  2293.         $o->cache_set_index('query', 0);
  2294.         }
  2295.         $o->inform("$SEP\n");
  2296.     }
  2297.     }
  2298.  
  2299.     # Args provided
  2300.     else {
  2301.  
  2302.     # Describe a particular number:
  2303.     if (my @r = parse_range(@args)) {
  2304.         unless ($n_results and bounded(0, $n_current, $n_results - 1)) {
  2305.         $o->inform("No query results to describe -- " . 
  2306.           "use 'query' to find a package.\n");
  2307.         return;
  2308.         }
  2309.         else {
  2310.         for my $n (@r) {
  2311.             my @results = $o->cache_set('query');
  2312.             my $npkgs = @results;
  2313.             $o->inform("$SEP\n");
  2314.             if (bounded(1, $n, $npkgs)) {
  2315.             $o->inform("Package $n:\n");
  2316.             $o->cache_set_index('query', $n-1);
  2317.             my $old = $o->cache_entry('query');
  2318.             my $prop =
  2319.               PPM::UI::properties($o->conf('target'), $old->name);
  2320.             unless ($prop->is_success) {
  2321.                 $o->warn($prop->msg);
  2322.                 next unless $prop->ok;
  2323.             }
  2324.             my ($pkg, $idate, $loc) = $prop->result_l;
  2325.             $o->describe_pkg($pkg,
  2326.                      [qw(InstDate Location)],
  2327.                      [$idate, $loc],
  2328.                     );
  2329.             }
  2330.             else {
  2331.             $o->inform("No such package $n in result set.\n");
  2332.             }
  2333.         }
  2334.         $o->inform("$SEP\n");
  2335.         }
  2336.     }
  2337.  
  2338.     # Query a particular package
  2339.     else {
  2340.         if ($o->conf('target')) {
  2341.         my $prop =
  2342.           PPM::UI::properties($o->conf('target'), $args);
  2343.         unless ($prop->is_success) {
  2344.             $o->warn($prop->msg);
  2345.             return unless $prop->ok;
  2346.         }
  2347.         my ($pkg, $idate, $loc) = $prop->result_l;
  2348.         my ($s, $index) = $o->cache_find('query', $args);
  2349.         $o->inform("$SEP\n") if $pkg;
  2350.         $o->describe_pkg($pkg,
  2351.                  [qw(InstDate Location)],
  2352.                  [$idate, $loc],
  2353.                 )
  2354.           if $pkg;
  2355.         $o->inform("$SEP\n") if $pkg;
  2356.         if ($index >= 0) {
  2357.             $o->cache_set_current('query', $s);
  2358.             $o->cache_set_index('query', $index);
  2359.         }
  2360.         elsif ($pkg) {
  2361.             $o->cache_set_add('query', $args[0], [$pkg]);
  2362.             my $last = $o->cache_sets('query') - 1;
  2363.             $o->cache_set_current('query', $last);
  2364.             $o->cache_set_index('query', 0);
  2365.         }
  2366.         $o->warn("Package '$args' not found; 'query' for it first.\n")
  2367.           and return unless $pkg;
  2368.         }
  2369.         else {
  2370.         # XXX: Change this output.
  2371.         $o->warn(
  2372.             "There are no targets installed.\n"
  2373.         );
  2374.         return;
  2375.         }
  2376.     }
  2377.     }
  2378.     1;
  2379. }
  2380.  
  2381. #============================================================================
  2382. # Uninstall:
  2383. # uninst    # removes default installed package
  2384. # uninst <\d+>    # removes specified package
  2385. # uninst <pkg>    # removes specified package
  2386. # uninst <url>    # removes the package located at <url>
  2387. #============================================================================
  2388. sub smry_uninstall { "uninstalls packages" }
  2389. sub help_uninstall { <<'END' }
  2390. remove, uninstall -- Uninstalls Installed Packages
  2391.   Synopsis
  2392.      remove              Deletes default installed package
  2393.      remove <number>     Deletes installed package <number>
  2394.      remove <range>      Deletes a <range> of installed packages
  2395.      remove <name>       Deletes a packages by a specific name
  2396.      remove <url>        Deletes the package located at <url>
  2397.  
  2398.   Description
  2399.     The remove and uninstall commands function identically. They are used to
  2400.     delete packages from the current target (specified using the target
  2401.     command). If profile tracking is enabled, (see 'help profile') the
  2402.     current PPM profile on ASPN will be updated.
  2403.  
  2404.     Packages can be removed by package name, by their numerical listing, or
  2405.     by specifying a URL to a PPD file. For example:
  2406.  
  2407.         remove XML-DOM
  2408.  
  2409.     will delete the XML-DOM package from the target.
  2410.  
  2411.     To remove package by number:
  2412.  
  2413.         remove 6
  2414.  
  2415.     and the sixth package in your current query will be removed. If no
  2416.     queries have been run in the current PPM session, you will be prompted
  2417.     to use a query to find a package before deleting it. Remember that
  2418.     removing packages clears all previous query requests, since the
  2419.     numerical sequence stored in any query will no longer be true once
  2420.     package(s) have been removed.
  2421.  
  2422.     Packages can also be removed in groups. For example:
  2423.  
  2424.         remove 4-7
  2425.  
  2426.     will delete packages 4, 5, 6, and 7 from your target. You can also skip
  2427.     packages:
  2428.  
  2429.         remove 3-5, 7
  2430.  
  2431.     this will delete packages 3, 4, 5 and 7, but will leave 6 intact.
  2432.     Remember to run a new query whenever you remove a package from your
  2433.     target.
  2434.  
  2435.     If you specify the package as a URL, PPM determines the package name
  2436.     from the URL and removes that.
  2437.  
  2438.     Please note that wildcards like "*" or "?" cannot be used with the
  2439.     remove command.
  2440.  
  2441.   See Also
  2442.     profile
  2443. END
  2444. sub comp_uninstall { goto &comp_properties; }
  2445. sub run_uninstall {
  2446.     my $o = shift;
  2447.     my @args = @_;
  2448.     trace(1, "PPM: uninstall @args\n");
  2449.  
  2450.     # Get the force option:
  2451.     my ($force);
  2452.     {
  2453.     local @ARGV = @args;
  2454.     GetOptions(
  2455.         'force!' => \$force,
  2456.     );
  2457.     @args = @ARGV;
  2458.     }
  2459.     
  2460.     my $args = $args[0];
  2461.  
  2462.     # No Args -- removes default package
  2463.     my $n_results = $o->cache_sets('query');
  2464.     my $n_current = $o->cache_set_current('query');
  2465.     my $ind = $o->cache_set_index('query');
  2466.     unless (@args) {
  2467.     unless ($n_results and bounded(0, $n_current, $n_results - 1)) {
  2468.         $o->warn("No query results to uninstall -- " . 
  2469.           "use 'query' to find a package.\n");
  2470.         return;
  2471.     }
  2472.     else {
  2473.         my @results = $o->cache_set('query');
  2474.         if (bounded(0, $ind, $#results)) {
  2475.         my $n = $ind + 1;
  2476.         $o->inform("Package $n:\n");
  2477.         $o->remove_pkg($o->cache_entry('query', $ind)->name, $force);
  2478.         }
  2479.         else {
  2480.         $o->inform("Package 1:\n");
  2481.         $o->remove_pkg($o->cache_entry('query', 0)->name, $force);
  2482.         }
  2483.     }
  2484.     }
  2485.  
  2486.     # Args provided
  2487.     else {
  2488.     # Uninstall a particular number:
  2489.     if (my @r = parse_range(@args)) {
  2490.         unless ($n_results and bounded(0, $n_current, $n_results - 1)) {
  2491.         $o->warn("No query results to uninstall -- " . 
  2492.           "use 'query' to find a package.\n");
  2493.         return;
  2494.         }
  2495.         else {
  2496.         my @results = $o->cache_set('query');
  2497.         my $npkgs = @results;
  2498.         my $ok = 0;
  2499.         for my $n (@r) {
  2500.             if (bounded(1, $n, $npkgs)) {
  2501.             $o->inform("Package $n:\n");
  2502.             $ok |=
  2503.               $o->remove_pkg($o->cache_entry('query', $n-1)->name,
  2504.                      $force, 1);
  2505.             }
  2506.             else {
  2507.             $o->warn("No such package $n in result set.\n");
  2508.             }
  2509.         }
  2510.         $o->cache_clear('query') if $ok;
  2511.         }
  2512.     }
  2513.  
  2514.     # Uninstall a particular package
  2515.     else {
  2516.         if ($o->conf('target')) {
  2517.         $o->remove_pkg($_, $force) for @args;
  2518.         }
  2519.         else {
  2520.         print
  2521.           "No targets -- use 'rep add' to add a target.\n";
  2522.         return;
  2523.         }
  2524.     }
  2525.     }
  2526.     1;
  2527. }
  2528. sub alias_uninstall { qw(remove) }
  2529.  
  2530. #============================================================================
  2531. # Settings:
  2532. #============================================================================
  2533. my (%lib_keys, @ui_keys);
  2534. my (@path_keys, @boolean_keys, @integer_keys);
  2535. my (%cache_clear_keys);
  2536. BEGIN {
  2537.     %lib_keys = ('download-chunksize' => 'downloadbytes',
  2538.         'tempdir' => 'tempdir',
  2539.         'rebuild-html' => 'rebuildhtml',
  2540.         'trace-file' => 'tracefile',
  2541.         'trace-level' => 'tracelvl',
  2542.         'profile-track' => 'profile_enable',
  2543.         );
  2544.     @ui_keys = qw(
  2545.     case-sensitivity
  2546.     pager
  2547.     fields
  2548.     follow-install
  2549.     force-install
  2550.     prompt-context
  2551.     prompt-slotsize
  2552.     prompt-verbose
  2553.     sort-field
  2554.     verbose-startup
  2555.  
  2556.     install-verbose
  2557.     upgrade-verbose
  2558.     remove-verbose
  2559.     );
  2560.     @boolean_keys = qw(case-sensitivity force-install follow-install
  2561.                prompt-context prompt-verbose profile-track
  2562.                verbose-startup install-verbose upgrade-verbose
  2563.                remove-verbose rebuild-html
  2564.               );
  2565.     @integer_keys = qw(download-chunksize prompt-slotsize trace-level);
  2566.     @path_keys = qw(tempdir pager trace-file);
  2567.     @cache_clear_keys{qw/
  2568.     case-sensitivity
  2569.     /} = ();
  2570. }
  2571. sub settings_getkeys {
  2572.     my $o = shift;
  2573.     my @keys = @ui_keys;
  2574.     push @keys, keys %lib_keys;
  2575.     @keys;
  2576. }
  2577. sub settings_getvals {
  2578.     my $o = shift;
  2579.     my @vals;
  2580.     push @vals, $o->settings_getkey($_) for $o->settings_getkeys;
  2581.     @vals;
  2582. }
  2583.  
  2584. sub conf {
  2585.     my $o   = shift;
  2586.     my $key = shift;
  2587.     my $val = shift;
  2588.     my $un  = shift;
  2589.     return $o->settings_setkey($key, $val, $un) if defined $val;
  2590.     return $o->settings_getkey($key);
  2591. }
  2592.  
  2593. sub settings_getkey {
  2594.     my $o = shift;
  2595.     my $key = shift;
  2596.     return PPM::UI::config_get($lib_keys{$key})->result if $lib_keys{$key};
  2597.     return $o->{SHELL}{conf}{DATA}{$key};
  2598. }
  2599. sub settings_setkey {
  2600.     my $o = shift;
  2601.     my ($key, $val, $un) = @_;
  2602.     if (grep { $key eq $_ } @boolean_keys) {
  2603.     $val = 0 if $un;
  2604.     unless ($val =~ /^\d+$/ && ($val == 0 || $val == 1)) {
  2605.         $o->warn(<<END);
  2606. Setting '$key' must be boolean: '0' or '1'. See 'help settings'.
  2607. END
  2608.         return;
  2609.     }
  2610.     }
  2611.     elsif (grep { $key eq $_ } @integer_keys) {
  2612.     $val = 0 if $un;
  2613.     unless ($val =~ /^\d+$/) {
  2614.         $o->warn(<<END);
  2615. Setting '$key' must be numeric. See 'help settings'.
  2616. END
  2617.         return;
  2618.     }
  2619.     }
  2620.     elsif ($key eq 'sort-field') {
  2621.     $val = 'name' if $un;
  2622.     my @fields = sort_fields();
  2623.     unless (grep { lc($val) eq $_ } @fields) {
  2624.         $o->warn(<<END);
  2625. Error setting '$key' to '$val': should be one of:
  2626. @fields.
  2627. END
  2628.         return;
  2629.     }
  2630.     else {
  2631.         $val = lc($val);
  2632.         $o->cache_set_index('search', -1); # invalidates current indices.
  2633.         $o->cache_set_index('query', -1);
  2634.     }
  2635.     }
  2636.     elsif ($key eq 'fields') {
  2637.     $val = 'name version abstract' if $un;
  2638.     my @fields = sort_fields();
  2639.     my @vals = split ' ', $val;
  2640.     for my $v (@vals) {
  2641.         unless (grep { lc $v eq lc $_ } @fields) {
  2642.         $o->warn(<<END);
  2643. Error adding field '$v': should be one of:
  2644. @fields.
  2645. END
  2646.         return;
  2647.         }
  2648.     }
  2649.     $val = lc $val;
  2650.     }
  2651.  
  2652.     if ($un and $key eq 'tempdir') {
  2653.     $o->warn("Can't unset 'tempdir': use 'set' instead.\n");
  2654.     return;
  2655.     }
  2656.  
  2657.     # Check for any cache-clearing that needs to happen:
  2658.     if (exists $cache_clear_keys{$key}) {
  2659.     $o->cache_clear('search');
  2660.     $o->cache_clear('query');
  2661.     }
  2662.  
  2663.     if ($lib_keys{$key}) { PPM::UI::config_set($lib_keys{$key}, $val) }
  2664.     else {
  2665.     $o->{SHELL}{conf}{DATA}{$key} = $val;
  2666.     $o->{SHELL}{conf}->save;
  2667.     }
  2668.     $o->inform(<<END);
  2669. Setting '$key' set to '$val'.
  2670. END
  2671. }
  2672.  
  2673. sub smry_settings { "view or set PPM options" }
  2674. sub help_settings { <<'END' }
  2675. settings -- View or Set PPM Settings
  2676.   Synopsis
  2677.      set                 Displays current settings
  2678.      set <name>          Displays the current setting of the given <name>
  2679.      set <name> <value>  Sets <name> to <value>
  2680.      unset <name>        Sets <name> to a "false" value: '0' for boolean
  2681.                          settings, '' for others.
  2682.  
  2683.   Description
  2684.     The settings command is used to configure the default PPM environment.
  2685.     Settings such as the number of lines displayed per page,
  2686.     case-sensitivity, and the log file are configured using the settings
  2687.     command.
  2688.  
  2689.     Setting names may be abbreviated to uniqueness. For example, instead of
  2690.     typing 'case-sensitivity', you may type 'case'.
  2691.  
  2692.     Available settings:
  2693.  
  2694.      NAME                VALUE           DESCRIPTION
  2695.      case-sensitivity    1 or 0      If 1, searches and queries are
  2696.                                      case-sensitive.
  2697.  
  2698.      download-chunksize  integer     If this is set to a positive,
  2699.                                      non-zero integer, PPM updates the
  2700.                                      status after "integer" of bytes
  2701.                                      transferred during an install or
  2702.                                      upgrade.
  2703.  
  2704.      fields              fields      A space-separated list of fields to 
  2705.                                      display in the search results. Valid
  2706.                                      fields are:
  2707.  
  2708.                                        ABSTRACT
  2709.                                        AUTHOR
  2710.                                        NAME
  2711.                                        REPOSITORY
  2712.                                        TITLE
  2713.                                        VERSION
  2714.  
  2715.                                      Usually, NAME and TITLE have the same
  2716.                                      content.
  2717.  
  2718.      follow-install      1 or 0      See 'help install' for details.
  2719.  
  2720.      force-install       1 or 0      See 'help install' for details.
  2721.  
  2722.      install-verbose     1 or 0      If 0, suppresses most output when
  2723.                                      installing packages. If 1, PPM prints
  2724.                                      each file as it is installed.
  2725.  
  2726.      pager               path        The path to an external pager program
  2727.                                      used to page long displays. If blank,
  2728.                                      or set to 'internal', the internal
  2729.                                      pager is used. If 'none', paging
  2730.                                      is disabled.
  2731.  
  2732.      profile-track       1 or 0      If 1, PPM arranges to have the 
  2733.                                      ASPN server track your PPM profile. 
  2734.                                      This means that every time your install
  2735.                                      or remove a package, your profile is
  2736.                                      updated on the server. If 0, you must
  2737.                                      manually save your profile using
  2738.                                      'profile save'.
  2739.  
  2740.      prompt-context      1 or 0      If 1, enables the prompt to change
  2741.                                      based on the current state of PPM, i.e
  2742.                                      showing current target, query, etc.
  2743.  
  2744.      prompt-slotsize     integer     If prompt-verbose is 1, this defines
  2745.                                      the width of each slot in the prompt.
  2746.                                      For instance, 4 means to use 4 
  2747.                                      character-wide slots.
  2748.  
  2749.      prompt-verbose      1 or 0      If 0, uses numbers to represent the
  2750.                                      context in the prompt; much shorter.
  2751.                                      If prompt-context is set to 0, there
  2752.                                      will be no visible difference in the
  2753.                                      'prompt-verbose' settings.
  2754.  
  2755.      rebuild-html        1 or 0      If 0, suppresses regeneration of HTML
  2756.                                      documentation when packages are
  2757.                                      installed. If 1, enables HTML to be
  2758.                                      generated from POD documentation.
  2759.                                      Enabling this option may slow down
  2760.                                      package installation.
  2761.  
  2762.      remove-verbose      1 or 0      If 0, suppresses most output when
  2763.                                      removing packages. If 1, prints the
  2764.                                      name of each file as it is removed.
  2765.  
  2766.      sort-field          field       The field by which to sort search and
  2767.                                      query results. Valid fields are
  2768.                                      ABSTRACT, AUTHOR, NAME, TITLE
  2769.                                      and VERSION.
  2770.  
  2771.      tempdir             path        A temporary directory into which
  2772.                                      packages are downloaded and expanded
  2773.                                      during 'install' and 'upgrade'.
  2774.  
  2775.      trace-file          path        A file to which PPM will write tracing
  2776.                                      information.
  2777.  
  2778.      trace-level         integer     If 0 or negative, tracing is disabled.
  2779.                                      Positive, non-zero integers result in
  2780.                                      tracing information being written to
  2781.                                      'trace-file'. Higher settings of
  2782.                                      'trace-level' result in more trace
  2783.                                      information.
  2784.  
  2785.      upgrade-verbose     1 or 0      If 0, suppresses most output when
  2786.                                      upgrading packages. If 1, prints the
  2787.                                      name of each file as it is upgraded.
  2788.  
  2789.     For information about migrating options used by previous versions of
  2790.     PPM, see 'help ppm_migration'.
  2791.  
  2792.     When you assign a value to a setting, PPM saves the configuration.
  2793.     Therefore, setting values persist across sessions.
  2794. END
  2795. sub comp_settings {
  2796.     my $o = shift;
  2797.     my ($word, $line, $start) = @_;
  2798.     my @words = $o->line_parsed($line);
  2799.  
  2800.     # To please the users of Bash, we'll allow 'set foo=bar' to work as well,
  2801.     # since it's really easy to do:
  2802.     if (defined $words[1] and $words[1] =~ /=/ and not defined $words[2]) {
  2803.     my @kv = split '=', $words[1];
  2804.     splice(@words, 1, 1, @kv);
  2805.     }
  2806.     my $words = @words;
  2807.     my @compls;
  2808.  
  2809.     # return the keys when we're completing the second word
  2810.     if ($words == 1 or $words == 2 and $start != length($line)) {
  2811.     @compls = $o->settings_getkeys();
  2812.     return $o->completions($word, \@compls);
  2813.     }
  2814.  
  2815.     # Return no completions for 'unset'.
  2816.     return () if matches($o->{API}{cmd}{run}{name}, 'u|nset');
  2817.  
  2818.     # provide intelligent completion for arguments:
  2819.     if ($words ==2 or $words == 3 and $start != length($line)) {
  2820.     # Completion for boolean values:
  2821.     my @bool = $o->completions($words[1], \@boolean_keys);
  2822.     my @path = $o->completions($words[1], \@path_keys);
  2823.     if (@bool == 1) {
  2824.         return $o->completions($word, [0, 1]);
  2825.     }
  2826.     elsif (@path == 1) {
  2827.         @compls = readline::rl_filename_list($word);
  2828.         return $o->completions($word, \@compls);
  2829.     }
  2830.     elsif (matches($words[1], 's|ort-field')) {
  2831.         @compls = sort_fields();
  2832.         return $o->completions(lc($word), \@compls);
  2833.     }
  2834.     }
  2835.  
  2836.     # Don't complete for anything else.
  2837.     ()
  2838. }
  2839. sub run_settings {
  2840.     my $o = shift;
  2841.     my @args = @_;
  2842.     my $key = $args[0];
  2843.     my $val = $args[1];
  2844.  
  2845.     # To please the users of Bash, we'll allow 'set foo=bar' to work as well,
  2846.     # since it's really easy to do:
  2847.     if (defined $key and $key =~ /=/ and not defined $val) {
  2848.     ($key, $val) = split '=', $key;
  2849.     }
  2850.  
  2851.     trace(1, "PPM: settings @args\n");
  2852.     my $unset = matches($o->{API}{cmd}{run}{name}, 'u|nset');
  2853.     my @stuff = $o->completions($key, [$o->settings_getkeys()])
  2854.       if $key;
  2855.     my $fullkey = $stuff[0] if @stuff == 1;
  2856.     if (defined $key and defined $val) {
  2857.     # validate the key:
  2858.     unless ($fullkey) {
  2859.         $key = '' unless defined $key;
  2860.         $o->warn("Unknown or ambiguous setting '$key'. See 'help settings'.\n");
  2861.         return;
  2862.     }
  2863.     $o->conf($fullkey, $val, $unset);
  2864.     }
  2865.     elsif (defined $key) {
  2866.     unless ($fullkey) {
  2867.         $key = '' unless defined $key;
  2868.         $o->warn("Unknown or ambiguous setting '$key'. See 'help settings'.\n");
  2869.         return;
  2870.     }
  2871.     if ($unset) {
  2872.         $o->conf($fullkey, '', $unset);
  2873.     }
  2874.     else {
  2875.         my $val = $o->conf($fullkey);
  2876.         $o->print_pairs([$fullkey], [$val]);
  2877.     }
  2878.     }
  2879.     else {
  2880.     my (@keys, @vals);
  2881.     @keys = $o->settings_getkeys();
  2882.     @vals = $o->settings_getvals();
  2883.     my %k;
  2884.     @k{@keys} = @vals;
  2885.     @keys = sort keys %k;
  2886.     @vals = map { $k{$_} } @keys;
  2887.     $o->print_pairs(\@keys, \@vals);
  2888.     }
  2889. }
  2890. sub alias_settings { qw(unset) }
  2891.  
  2892. sub help_help { <<'END' }
  2893. help -- General help, or help on specific commands.
  2894.   Synopsis
  2895.      help                Lists available commands and help topics
  2896.      help <command>      Lists detailed help about a specific command
  2897.  
  2898.   Description
  2899.     The help command provides a brief description of the commands available
  2900.     within PPM. For help on a specific command, enter help followed by the
  2901.     command name. For example, enter help settings or help set for a
  2902.     detailed description of the settings command.
  2903.  
  2904.     There are some extra help topics built into PPM. They can be accessed
  2905.     within the PPM environment as follows:
  2906.  
  2907.       help ppm_migration
  2908.  
  2909.     shows more details about the changes from previous versions of PPM
  2910.  
  2911.       help quickstart
  2912.  
  2913.     an easy-to-follow guide to getting started with PPM
  2914.  
  2915.       help prompt
  2916.  
  2917.     provides a detailed explanation about the PPM prompt
  2918. END
  2919.  
  2920. #============================================================================
  2921. # Version:
  2922. #============================================================================
  2923. sub smry_version { "displays the PPM version ($VERSION)" }
  2924. sub help_version { <<'END' }
  2925. version -- print the name and version of PPM.
  2926.     Prints the name and version of PPM3.
  2927. END
  2928. sub comp_version {()}
  2929. sub run_version {
  2930.     my $o = shift;
  2931.     if ($o->mode eq 'SHELL') {
  2932.     $o->inform("$NAME version $VERSION\n");
  2933.     }
  2934.     else {
  2935.     $o->inform("$SHORT_NAME $VERSION\n");
  2936.     }
  2937.     1;
  2938. }
  2939.  
  2940. #============================================================================
  2941. # Exit:
  2942. #============================================================================
  2943. sub help_exit { <<'END' }
  2944. exit, q, quit -- Exit the program
  2945.   Synopsis
  2946.      exit                Exit
  2947.      q                   Exit
  2948.      quit                Exit
  2949.  
  2950.   Description
  2951.     When you leave the PPM environment, the current settings are saved.
  2952. END
  2953. sub comp_exit {
  2954.     my $o = shift;
  2955.     return &comp_query
  2956.     if $o->{API}{cmd}{run}{name} eq 'q' and @_;
  2957.     ();
  2958. }
  2959. sub run_exit {
  2960.     my $o = shift;
  2961.     # Special case: 'q' with no arguments should mean 'quit', but 'q' with
  2962.     # arguments should mean 'query'.
  2963.     if ($o->{API}{cmd}{run}{name} eq 'q' and @_) {
  2964.     return $o->run('query', @_);
  2965.     }
  2966.     $o->stoploop;
  2967. }
  2968. sub alias_exit { qw(quit q) }
  2969.  
  2970. #============================================================================
  2971. # Upgrade
  2972. # upgrade    # lists upgrades available
  2973. # upgrade <\d+> # lists upgrades for specified package
  2974. # upgrade<pkg>    # lists upgrades for named package
  2975. #============================================================================
  2976. sub smry_upgrade { "shows availables upgrades for installed packages" }
  2977. sub help_upgrade { <<'END' }
  2978. upgrade -- List or install available upgrades
  2979.   Synopsis
  2980.      upgrade [*]         Lists upgrades available for all installed packages
  2981.      upgrade <number>    Lists upgrades for installed package <number>
  2982.      upgrade <range>     Lists upgrades for a <range> of installed packages
  2983.      upgrade <package>   Lists upgrades for the named <package>
  2984.  
  2985.   Description
  2986.     The upgrade command lists package upgrades that are available on the
  2987.     active repositories for packages installed on your system. To install
  2988.     available upgrades, use the '--install' option.
  2989.  
  2990.     If profile tracking is enabled, (see 'help profile'), your profile will
  2991.     be updated to reflect changes to any packages which are upgraded.
  2992.  
  2993.     There are several modifiers to the upgrade command:
  2994.  
  2995.     -install
  2996.         Installs, rather than lists, available upgrades
  2997.  
  2998.     -precious
  2999.         Allows upgrading of "precious" packages
  3000.  
  3001.     -force
  3002.         See 'help install'
  3003.  
  3004.     -follow
  3005.         See 'help install'
  3006.  
  3007.     By default, 'upgrade' typed by itself only lists the available upgrades.
  3008.     To actually install all available upgrades, enter
  3009.  
  3010.         upgrade -install
  3011.  
  3012.     To enable upgrading "precious" packages, enter
  3013.  
  3014.         upgrade -install -precious
  3015.  
  3016.   See Also
  3017.     profile
  3018. END
  3019. sub comp_upgrade { goto &comp_properties; }
  3020. sub run_upgrade {
  3021.     my $o = shift;
  3022.     my @args = @_;
  3023.     trace(1, "PPM: upgrade @args\n");
  3024.  
  3025.     # Get options:
  3026.     my %opts = (
  3027.     install => 0,
  3028.     doprecious => 0,
  3029.     dryrun => 0,
  3030.     force => $o->conf('force-install'),
  3031.     follow => $o->conf('follow-install'),
  3032.     );
  3033.     {
  3034.     local @ARGV = @args;
  3035.     GetOptions(install => \$opts{install},
  3036.            precious => \$opts{doprecious},
  3037.            'force!' => \$opts{force},
  3038.            'follow!' => \$opts{follow},
  3039.            dryrun => \$opts{dryrun},
  3040.           );
  3041.     @args = @ARGV;
  3042.     }
  3043.  
  3044.     my $rlist = [$o->reps_on];
  3045.     my $targ  = $o->conf('target');
  3046.     my @pkgs;
  3047.  
  3048.     # Allow 'upgrade *';
  3049.     @args = grep { $_ ne '*' } @args;
  3050.  
  3051.     # List upgrades for a particular package
  3052.     if (@args) {
  3053.     my $pkg = $args[0];
  3054.     my @n = parse_range($o->raw_args);
  3055.     for my $n (@n) {
  3056.         my $ppd = $o->cache_entry('query', $n-1);
  3057.         unless($ppd) {
  3058.         $o->warn("No such query result '$pkg' in result set.\n");
  3059.         return;
  3060.         }
  3061.         else {
  3062.         push @pkgs, $ppd;
  3063.         }
  3064.     }
  3065.  
  3066.     # The name of the package:
  3067.     unless (@n) {
  3068.         my $ppd = PPM::UI::properties($o->conf('target'), $pkg);
  3069.         unless ($ppd->is_success) {
  3070.         $o->warn($ppd->msg);
  3071.         return unless $ppd->ok;
  3072.         }
  3073.         my $real_ppd = ($ppd->result_l)[0];
  3074.         push @pkgs, $real_ppd;
  3075.     }
  3076.     }
  3077.     # List upgrades for all packages
  3078.     else {
  3079.     @pkgs = PPM::UI::query($targ, '*', 0)->result_l;
  3080.     @pkgs = $o->sort_pkgs($o->conf('sort-field'), @pkgs);
  3081.     }
  3082.  
  3083.     my $verify = PPM::UI::verify_pkgs($rlist, $targ, @pkgs);
  3084.     unless ($verify->is_success) {
  3085.     $o->error("Error verifying packages: ", $verify->msg_raw, "\n");
  3086.     return;
  3087.     }
  3088.     my %bypackage;
  3089.     for my $result ($verify->result_l) {
  3090.     next unless $result->is_success; # ignore unfound packages
  3091.     my ($uptodate, $server_pkg, $inst_pkg, $b, $p) = $result->result_l;
  3092.     my $name = $server_pkg->name;
  3093.     my $nver = $server_pkg->version;
  3094.     my $over = $inst_pkg->version;
  3095.     my $repo = $server_pkg->repository->name;
  3096.     $bypackage{$name}{$repo} = {
  3097.         uptodate => $uptodate,
  3098.         oldver => $over,
  3099.         newver => $nver,
  3100.         repo => $repo,
  3101.         bundled => $b,
  3102.         precious => $p,
  3103.         pkg => $server_pkg,
  3104.     };
  3105.     }
  3106.     for my $pkg (sort keys %bypackage) {
  3107.     my $default;
  3108.     my @updates;
  3109.     my $p = $bypackage{$pkg};
  3110.     for my $rep (sort { $p->{$b}{newver} cmp $p->{$a}{newver} } keys %$p) {
  3111.         my $tmp = $default = $p->{$rep};
  3112.         push @updates, [@$tmp{qw(oldver newver repo)}] unless $tmp->{uptodate};
  3113.     }
  3114.     my $upgrade = $opts{install} ? 1 : 0;
  3115.         for (@updates) {
  3116.         $o->inform("$pkg $_->[0]: new version $_->[1] available in $_->[2]\n");
  3117.     }
  3118.     unless (@updates) {
  3119.         $o->inform("$pkg $default->{oldver}: up to date.\n");
  3120.         $upgrade &= $opts{force};
  3121.     }
  3122.     if ($upgrade) {
  3123.         my @k = keys %$p;
  3124.         my $ask = (@updates > 1 or @k > 1 and !@updates);
  3125.         if ($ask) {
  3126.         # Which one do they want to install?
  3127.         $o->inform(<<MANY);
  3128.  
  3129.    Note: $pkg version $default->{oldver} is available from more than one place.
  3130.    Which repository would you like to upgrade from?
  3131.  
  3132. MANY
  3133.         my @repos = map { $_->[2] } @updates;
  3134.         $o->print_pairs([ 1 .. @repos ], \@repos, '. ');
  3135.         $o->inform("\n");
  3136.         my $rep = $o->prompt(
  3137.             "Repository? [$default->{repo}] ",
  3138.             $default->{repo},
  3139.             [ 1 .. @repos, @repos ],
  3140.         );
  3141.         $rep = $repos[$rep - 1] if $rep =~ /^\d+$/;
  3142.         $default = $p->{$rep};
  3143.         }
  3144.         elsif (!@updates) {
  3145.         ($default) = values %$p;
  3146.         }
  3147.         if (not $default->{precious} or $default->{precious} && $opts{doprecious}) {
  3148.         $o->upgrade_pkg($default->{pkg}, \%opts);
  3149.         }
  3150.         else {
  3151.         $o->warn(<<END);
  3152. Use '-precious' to force precious packages to be upgraded.
  3153. END
  3154.         }
  3155.     }
  3156.     }
  3157.     1;
  3158. }
  3159.  
  3160. #============================================================================
  3161. # Profile:
  3162. # profile        # lists the profiles available on the repository
  3163. # profile N        # switches profiles
  3164. # profile add "name"    # adds a new profile
  3165. # profile delete N    # deletes the given profile
  3166. # profile describe N    # describes the given profile
  3167. # profile save        # saves the current state to the current profile
  3168. # profile restore    # restores the current profile
  3169. # profile rename    # renames the given profile
  3170. #============================================================================
  3171. sub smry_profiles { "manage PPM profiles" }
  3172. sub help_profiles { <<'END' }
  3173. profile -- Manage PPM Profiles
  3174.   Synopsis
  3175.      profile                     Lists profiles available on the repository
  3176.      profile <num>               Switches to the given profile
  3177.      profile add <name>          Creates a new profile on the repository
  3178.      profile delete <name or num>
  3179.                                  Deletes the given profile
  3180.      profile describe [name or num]
  3181.                                  Describes the current or given profile
  3182.      profile save                Saves the client state to the current profile
  3183.      profile restore             Restores the current profile
  3184.      profile rename <name or num> <name>
  3185.                                  Renames the given profile to <name>
  3186.  
  3187.   Description
  3188.     Profiles store information about packages that are installed on your
  3189.     system. If the 'profile-track' setting is enabled, your ASPN Profile
  3190.     will be updated with information about installed packages. Profiles
  3191.     allow you to easily migrate, reinstall, upgrade or restore PPM packages
  3192.     in one or more locations.
  3193.  
  3194.     To use profiles, you must have a license for ASPN. For license
  3195.     information, see http://www.ActiveState.com/ASPN/About Disable profile
  3196.     tracking by setting 'profile-track=0'.
  3197. END
  3198. sub comp_profiles {
  3199.     my $o = shift;
  3200.     my ($word, $line, $start) = @_;
  3201.     my @words = $o->line_parsed($line);
  3202.     my $words = scalar @words;
  3203.     my @profs = PPM::UI::profile_list();
  3204.     my @cmds = ('add', 'delete', 'describe', 'save', 'restore', 'rename');
  3205.  
  3206.     if ($words == 1 or $words == 2 and $start != length($line)) {
  3207.     my @compls = (@cmds, 1 .. scalar @profs);
  3208.     return $o->completions($word, \@compls);
  3209.     }
  3210.     if ($words == 2 or $words == 3 and $start != length($line)) {
  3211.     return ()
  3212.       if ($o->completions($words[1], [qw(add save restore)])==1);
  3213.     return $o->completions($word, [1 .. scalar @profs])
  3214.       if ($o->completions($words[1], [qw(delete describe rename)])==1);
  3215.     }
  3216.     ();
  3217. }
  3218. sub run_profiles {
  3219.     my $o = shift;
  3220.     my @args = @_;
  3221.     trace(1, "PPM: profile @args\n");
  3222.  
  3223.     my $ok = PPM::UI::profile_list();
  3224.     unless ($ok->is_success) {
  3225.     $o->warn($ok->msg);
  3226.     return unless $ok->ok;
  3227.     }
  3228.     my @profiles = dictsort $ok->result_l;
  3229.     $ok = PPM::UI::profile_get();
  3230.     unless ($ok->is_success) {
  3231.     $o->warn($ok->msg);
  3232.     return unless $ok->ok;
  3233.     }
  3234.     my $profile = $ok->result;
  3235.     my $which = find_index($profile, 0, @profiles);
  3236.     if ($which < 0 and @profiles) {
  3237.     $profile = $profiles[0];
  3238.     PPM::UI::profile_set($profile);
  3239.     }
  3240.  
  3241.     if (@args) {
  3242.     # Switch to profile N:
  3243.     if ($args[0] =~ /^\d+$/) {
  3244.         my $num = $args[0];
  3245.         if (bounded(1, $num, scalar @profiles)) {
  3246.         my $profile = $profiles[$num-1];
  3247.         PPM::UI::profile_set($profile);
  3248.         }
  3249.         else {
  3250.         $o->warn("No such profile number '$num'.\n");
  3251.         return;
  3252.         }
  3253.     }
  3254.  
  3255.     # Describe profile N:
  3256.     elsif (matches($args[0], "des|cribe")) {
  3257.         my $num =     $args[1] =~ /^\d+$/ ? $args[1] :
  3258.             do {
  3259.                 my $n = find_index($args[1], 1, @profiles);
  3260.                 if ($n < 1) {
  3261.                 $o->warn("No such profile '$args[1]'.\n");
  3262.                 return;
  3263.                 }
  3264.                 $n;
  3265.             } if defined $args[1];
  3266.         my $prof;
  3267.         if (defined $num and $num =~ /^\d+$/) {
  3268.         if (bounded(1, $num, scalar @profiles)) {
  3269.             $prof = $profiles[$num - 1];
  3270.         }
  3271.         else {
  3272.             $o->warn("No such profile number '$num'.\n");
  3273.             return;
  3274.         }
  3275.         }
  3276.         elsif (defined $num) {
  3277.         $o->warn("Argument to '$args[0]' must be numeric; see 'help profile'.\n");
  3278.         return;
  3279.         }
  3280.         else {
  3281.         $prof = $profile;
  3282.         }
  3283.  
  3284.         my $res = PPM::UI::profile_info($prof);
  3285.         $o->warn($res->msg) and return unless $res->ok;
  3286.         my @res = $res->result_l;
  3287.         {
  3288.         my ($pkg, $version, $target);
  3289.         my $picture = <<'END';
  3290. [[[[[[[[[[[[[[[[[[[    [[[[[[[[[[[    [[[[[[[[[[[[[[[[[[[[[[
  3291. END
  3292.         ($pkg, $version, $target) = qw(PACKAGE VERSION TARGET);
  3293.         my $text = '';
  3294.         $text .= form($picture, $pkg, $version, $target)
  3295.           if @res;
  3296.         for my $entity (@res) {
  3297.             ($pkg, $version, $target) = @$entity;
  3298.             $version = "[$version]";
  3299.             $text .= form($picture, $pkg, $version, $target);
  3300.         }
  3301.         if (@res) {
  3302.             $o->inform("Describing Profile '$prof':\n");
  3303.         }
  3304.         else {
  3305.             $o->inform("Profile '$prof' is empty.\n");
  3306.         }
  3307.         $o->page($text);
  3308.         }
  3309.         return 1;
  3310.     }
  3311.  
  3312.     # Add a profile "name":
  3313.     elsif (matches($args[0], "a|dd")) {
  3314.         my $name = $args[1];
  3315.         if ($name) {
  3316.         # Note: do some heavy-duty error-checking; XXX
  3317.         PPM::UI::profile_add($name);
  3318.         PPM::UI::profile_save($name)
  3319.           if $o->conf('profile-track');
  3320.         PPM::UI::profile_set($name)
  3321.           unless $which >= 0;
  3322.         @profiles = PPM::UI::profile_list()->result_l;
  3323.         }
  3324.         else {
  3325.         $o->warn("Invalid use of 'add' command; see 'help profile'.\n");
  3326.         return;
  3327.         }
  3328.     }
  3329.  
  3330.     # Remove profile N:
  3331.     elsif (matches($args[0], "del|ete")) {
  3332.         my $num =    $args[1] =~ /^\d+$/ ? $args[1] :
  3333.             do {
  3334.                 my $n = find_index($args[1], 1, @profiles);
  3335.                 if ($n < 1) {
  3336.                 $o->inform("No such profile '$args[1]'.\n");
  3337.                 return;
  3338.                 }
  3339.                 $n;
  3340.             } if defined $args[1];
  3341.         if (defined $num and $num =~ /^\d+$/) {
  3342.         my $dead_profile = $profiles[$num-1];
  3343.         if (bounded(1, $num, scalar @profiles)) {
  3344.             PPM::UI::profile_del($dead_profile);
  3345.             @profiles = dictsort PPM::UI::profile_list()->result_l;
  3346.             if (@profiles and $dead_profile eq $profile) {
  3347.             $profile = $profiles[0];
  3348.             PPM::UI::profile_set($profile);
  3349.             }
  3350.             elsif (not @profiles) {
  3351.             $o->conf('profile-track', 0);
  3352.             PPM::UI::profile_set('');
  3353.             }
  3354.         }
  3355.         else {
  3356.             $o->warn("No such profile '$num'.\n");
  3357.             return;
  3358.         }
  3359.         }
  3360.         elsif (defined $num) {
  3361.         $o->warn(<<END);
  3362. Argument to '$args[0]' must be numeric; see 'help profile'.
  3363. END
  3364.         return;
  3365.         }
  3366.         else {
  3367.         $o->warn(<<END);
  3368. Invalid use of '$args[0]' command; see 'help profile'.
  3369. END
  3370.         return;
  3371. }
  3372.     }
  3373.  
  3374.     # Save current profile:
  3375.     elsif (matches($args[0], "s|ave")) {
  3376.         unless (@profiles) {
  3377.         $o->warn(<<END);
  3378. No profiles on the server. Use 'profile add' to add a profile.
  3379. END
  3380.         return;
  3381.         }
  3382.         unless ($which >= 0) {
  3383.         $o->warn(<<END);
  3384. No profile selected. Use 'profile <number>' to select a profile.
  3385. END
  3386.         return;
  3387.         }
  3388.         my $ok = PPM::UI::profile_save($profile);
  3389.         if ($ok->ok) {
  3390.         $o->inform("Profile '$profile' saved.\n");
  3391.         }
  3392.         else {
  3393.         $o->warn($ok->msg);
  3394.         return;
  3395.         }
  3396.         return 1;
  3397.     }
  3398.  
  3399.     # Rename profile:
  3400.     elsif (matches($args[0], "ren|ame")) {
  3401.         unless (@profiles) {
  3402.         $o->warn(<<END);
  3403. No profiles on the server. Use 'profile add' to add a profile.
  3404. END
  3405.         return;
  3406.         }
  3407.  
  3408.         # Determine the old name:
  3409.         my $num =    $args[1] =~ /^\d+$/ ? $args[1] :
  3410.             do {
  3411.                 my $n = find_index($args[1], 1, @profiles);
  3412.                 if ($n < 1) {
  3413.                 $o->warn("No such profile '$args[1]'.\n");
  3414.                 return;
  3415.                 };
  3416.                 $n;
  3417.             } if defined $args[1];
  3418.         my $oldprof;
  3419.         if (defined $num and $num =~ /^\d+$/) {
  3420.         if (bounded(1, $num, scalar @profiles)) {
  3421.             $oldprof = $profiles[$num - 1];
  3422.         }
  3423.         else {
  3424.             $o->warn("No such profile number '$num'.\n");
  3425.             return;
  3426.         }
  3427.         }
  3428.         elsif (defined $num) {
  3429.         $o->warn("Argument to '$args[0]' must be numeric; see 'help profile'.\n");
  3430.         return;
  3431.         }
  3432.         else {
  3433.         $o->warn("profile: invalid use of '$args[0]' command: see 'help profile'.\n");
  3434.         return;
  3435.         }
  3436.  
  3437.         # Validate the new name:
  3438.         my $newprof = $args[2];
  3439.         unless (defined $newprof and length($newprof)) {
  3440.         $newprof = '' unless defined $newprof;
  3441.         $o->warn(<<END);
  3442. Profile names must be non-empty: '$newprof' is not a valid name.
  3443. END
  3444.         return;
  3445.         }
  3446.  
  3447.         # Actually do it:
  3448.         my $ok = PPM::UI::profile_rename($oldprof, $newprof);
  3449.         unless ($ok->is_success) {
  3450.         $o->warn($ok->msg);
  3451.         return unless $ok->ok;
  3452.         }
  3453.         if ($profile eq $oldprof) {
  3454.         $profile = $newprof;
  3455.         PPM::UI::profile_set($profile);
  3456.         }
  3457.         @profiles = dictsort PPM::UI::profile_list()->result_l;
  3458.     }
  3459.  
  3460.     # Restore current profile:
  3461.     elsif (matches($args[0], "res|tore")) {
  3462.         unless (@profiles) {
  3463.         $o->warn(<<END);
  3464. No profiles on this server. Use 'profile add' to add a profile.
  3465. END
  3466.         return;
  3467.         }
  3468.         unless ($which >= 0) {
  3469.         $o->warn(<<END);
  3470. No profile selected. Use 'profile <number>' to select a profile.
  3471. END
  3472.         return;
  3473.         }
  3474.         my ($clean_packages, $dry) = (0, 0);
  3475.         my ($force, $follow) = (1, 0);
  3476.         {
  3477.         local @ARGV = @args;
  3478.         GetOptions('clean!' => \$clean_packages,
  3479.                'force!' => \$force,
  3480.                'follow!' => \$follow,
  3481.                'dryrun' => \$dry,
  3482.               );
  3483.         @args = @ARGV;
  3484.         }
  3485.         my $cb_inst = $dry ? \&dr_install : \&cb_install;
  3486.         my $cb_rm   = $dry ? \&dr_remove  : \&cb_remove ;
  3487.         my $ok = PPM::UI::profile_restore($profile, sub {$o->$cb_inst(@_)},
  3488.                           sub {$o->$cb_rm(@_)}, $force, $follow,
  3489.                           $dry, $clean_packages);
  3490.         if ($ok->ok) {
  3491.         $o->cache_clear('query');
  3492.         $o->inform("Profile '$profile' restored.\n");
  3493.         }
  3494.         else {
  3495.         $o->warn($ok->msg);
  3496.         return;
  3497.         }
  3498.         return 1;
  3499.     }
  3500.  
  3501.     # Unrecognized subcommand:
  3502.     else {
  3503.         $o->warn("No such profile command '$args[0]'; see 'help profile'.\n");
  3504.         return;
  3505.     }
  3506.     }
  3507.     if (@profiles) {
  3508.     @profiles = dictsort @profiles;
  3509.     my $i = 0;
  3510.     $o->inform("Profiles:\n");
  3511.     my $profile = PPM::UI::profile_get()->result;
  3512.     for (@profiles) {
  3513.         $o->informf("%s%2d", $profile eq $profiles[$i] ? "*" : " ", $i + 1);
  3514.         $o->inform(". $_\n");
  3515.         $i++;
  3516.     }
  3517.     }
  3518.     elsif (defined $args[0] and matches($args[0], "del|ete")) {
  3519.     # assume that we just deleted the last profile
  3520.     $o->warn(<<END);
  3521. Profile deleted; no remaining profiles on the server.
  3522. END
  3523.     }
  3524.     else {
  3525.     $o->warn(<<END);
  3526. No profiles. Use 'profile add' to add a profile.
  3527. END
  3528.     }
  3529.     1;
  3530. }
  3531.  
  3532. #============================================================================
  3533. # Help-only topics:
  3534. #============================================================================
  3535. sub smry_prompt { "how to interpret the PPM prompt" }
  3536. sub help_prompt { <<'END' }
  3537. prompt -- information about the PPM3 prompt
  3538.   Description
  3539.     The PPM prompt can tell you six things:
  3540.  
  3541.     1)  The current repository;
  3542.  
  3543.     2)  The current target;
  3544.  
  3545.     3)  The last search you made on the current repository;
  3546.  
  3547.     4)  The last query you made on the current target;
  3548.  
  3549.     5)  The last package you described from this repository; and,
  3550.  
  3551.     6)  The last package you described from this target.
  3552.  
  3553.     To enable the prompt to tell you this information, you must set
  3554.     'prompt-context' to '1'. The following examples all assume this setting.
  3555.  
  3556.   Examples
  3557.     1   Repository and Target:
  3558.  
  3559.         Set 'prompt-context' The prompt will resemble:
  3560.  
  3561.             ppm:1:1> 
  3562.  
  3563.         In this case, the first '1' means that the first repository is
  3564.         selected. The second '1' means the first target is selected. You can
  3565.         prove this by adding another repository and switching to it:
  3566.  
  3567.             ppm:1:1> rep add TEMP http://my/repository
  3568.             Repositories:
  3569.               1. ActiveState Package Repository
  3570.             * 2. TEMP
  3571.             ppm:1:1> rep 2
  3572.             Repositories:
  3573.               1. ActiveState Package Repository
  3574.             * 2. TEMP
  3575.             ppm:2:1> 
  3576.  
  3577.         The same is true for targets. If you have multiple versions of Perl
  3578.         installed, when you swtich to a different target the second number
  3579.         reflects the change.
  3580.  
  3581.         If you delete all the repositories, the repository number changes to
  3582.         '?'. The same goes for targets. If either item is indicated by a
  3583.         question mark, you must configure a repository or target before
  3584.         proceeding.
  3585.  
  3586.     2   Search and Query:
  3587.  
  3588.         PPM stores searches and search results from in the current session.
  3589.         The prompt displays the search number:
  3590.  
  3591.             ppm:1:1> search Text
  3592.             [results displayed here]
  3593.             ppm:1:1:s1> 
  3594.  
  3595.         The 's1' indicates that the last search you performed can be viewed
  3596.         again by entering 'search 1'. Type 'search' with no arguments to
  3597.         view the list of cached searches:
  3598.  
  3599.             ppm:1:1:s1> search
  3600.             Search Result Sets:
  3601.             * 1. Text
  3602.  
  3603.         If you then enter 'search 1', you will see the same results as when
  3604.         you typed 'search Text' earlier. If you search for something else
  3605.         ('search Parse') then the number will change to 's2':
  3606.  
  3607.             ppm:1:1:s1> search Parse
  3608.             [results displayed here]
  3609.             ppm:1:1:s2>
  3610.  
  3611.         The same indicators apply to the query command. When you run a
  3612.         query, a numerical indicator displays the current query:
  3613.  
  3614.             ppm:1:1:s1> query PPM
  3615.             [results displayed here]
  3616.             ppm:1:1:s1:q1> 
  3617.  
  3618.         You can view the past queries with 'query', and view results by
  3619.         querying a particular number.
  3620.  
  3621.     3   Describe and Properties:
  3622.  
  3623.         When you use the describe command with the numerical switch (to view
  3624.         package information based on the package number in the last search
  3625.         or query), PPM sets that index to the current index. If you use the
  3626.         desribe command with the name switch, and the name is found within
  3627.         the current result, the index is set to the current one. If no
  3628.         package is found, PPM creates a new search or query on-the-fly, and
  3629.         sets it as the current search or query.
  3630.  
  3631.         For example:
  3632.  
  3633.             ppm:1:1> search Text
  3634.             1. Convert-Context  [0.501]     an Attributed Text data type
  3635.             2. gettext          [1.01]      message handling functions
  3636.             3. HTML-FromText    [1.005]     mark up text as HTML
  3637.             4. HTML-Subtext     [1.03]      Perform text substitutions on an HTML
  3638.                                             template
  3639.             5. Locale-Maketext  [0.18]      framework for software localization
  3640.             ppm:1:1:s1>
  3641.  
  3642.             ppm:1:1:s1> describe 1
  3643.             ====================
  3644.             Package 1:
  3645.                 Name: Convert-Context
  3646.              Version: 0.501
  3647.               Author: Martin Schwartz (martin@nacho.de)
  3648.             Abstract: an Attributed Text data type
  3649.             Implementations:
  3650.                    1. i686-linux-thread-multi
  3651.                    2. MSWin32-x86-multi-thread
  3652.                    3. sun4-solaris-thread-multi
  3653.             ====================
  3654.             ppm:1:1:s1:sp1> 
  3655.  
  3656.         The last prompt has an extra 'sp1'. That stands for 'search package
  3657.         1', and it means that PPM considers 'Convert-Context' to be the
  3658.         default package. If you now type 'describe' or 'install' with no
  3659.         arguments, PPM will apply your command to this package.
  3660.  
  3661.         If you go back to where you had no default package selected:
  3662.  
  3663.             ppm:1:1> search Text
  3664.             1. Convert-Context  [0.501]     an Attributed Text data type
  3665.             2. gettext          [1.01]      message handling functions
  3666.             3. HTML-FromText    [1.005]     mark up text as HTML
  3667.             4. HTML-Subtext     [1.03]      Perform text substitutions on an HTML
  3668.                                             template
  3669.             5. Locale-Maketext  [0.18]      framework for software localization
  3670.             ppm:1:1:s1>
  3671.  
  3672.         ...and you describe 'Locale-Maketext', you will see this:
  3673.  
  3674.             ppm:1:1:s1> describe Locale-Maketext
  3675.             ====================
  3676.                 Name: Locale-Maketext
  3677.              Version: 0.18
  3678.               Author: Sean M. Burke (sburke@cpan.org)
  3679.             Abstract: framework for software localization
  3680.             Prerequisites:
  3681.                    1. I18N-LangTags 0.13
  3682.             Implementations:
  3683.                    1. i686-linux-thread-multi
  3684.                    2. MSWin32-x86-multi-thread
  3685.                    3. sun4-solaris-thread-multi
  3686.             ====================
  3687.             ppm:1:1:s1:sp5>
  3688.  
  3689.         Notice that the correct package got selected, even though you
  3690.         specified it by name.
  3691.  
  3692.     This behaviour also applies to the query and properties commands.
  3693.  
  3694.   See Also
  3695.     describe, properties, query, search
  3696. END
  3697.  
  3698. #sub run_quickstart  { $_[0]->run_help('quickstart') }
  3699. sub smry_quickstart { "a crash course in using PPM" }
  3700. sub help_quickstart { <<'END' }
  3701. quickstart -- a beginners' guide to PPM3
  3702.   Description
  3703.     PPM (Programmer's Package Manager) is a utility for managing software
  3704.     "packages". A package is a modular extension for a language or a
  3705.     software program. Packages reside in repositories. PPM can use three
  3706.     types of repositories:
  3707.  
  3708.      1) A directory on a CD-ROM or hard drive in your computer
  3709.      2) A website
  3710.      3) A remote Repository Server (such as ASPN)
  3711.  
  3712.     Common Commands:
  3713.  
  3714.     To view PPM help:
  3715.  
  3716.       help
  3717.       help <command>
  3718.  
  3719.     To view the name of the current repository:
  3720.  
  3721.       repository
  3722.  
  3723.     To search the current repository:
  3724.  
  3725.       search <keywords>
  3726.  
  3727.     To install a package:
  3728.  
  3729.       install <package_name>
  3730.  
  3731.     Most commands can be truncated; as long as the command is unambiguous,
  3732.     PPM will recognize it. For example, 'repository add foo' can be entered
  3733.     as 'rep add foo'.
  3734.  
  3735.     PPM features user profiles, which store information about installed
  3736.     packages. Profiles are stored as part of your ASPN account; thus, you
  3737.     can easily maintain package profiles for different languages, or
  3738.     configure one machine with your favorite packages, and then copy that
  3739.     installation to another machine by accessing your ASPN profile.
  3740.  
  3741.     For more information, type 'help profile' at the PPM prompt.
  3742. END
  3743.  
  3744. sub smry_ppm_migration { "guide for those familiar with PPM" }
  3745. sub help_ppm_migration { <<'END' }
  3746. ppm migration -- PPM Migration Guide
  3747.   Description
  3748.     Those familiar with PPM version 2 should appreciate the extended
  3749.     functionality of PPM version 3, including the command-line history,
  3750.     autocomplete and profiles. Some PPM version 2 commands are different in
  3751.     PPM version 3. Examples of command changes include:
  3752.  
  3753.     1   Adding a repository
  3754.  
  3755.         PPM2:
  3756.  
  3757.           set repository my_repository http://my/repository
  3758.  
  3759.         PPM3:
  3760.  
  3761.           repository add my_repository http://my/repository
  3762.  
  3763.     2   Removing a repository
  3764.  
  3765.         PPM2:
  3766.  
  3767.           set repository --remove my_repository
  3768.  
  3769.         PPM3:
  3770.  
  3771.           repository del my_repository
  3772.  
  3773.     3   Setting the temporary directory
  3774.  
  3775.         PPM2:
  3776.  
  3777.           set build DIRECTORY
  3778.  
  3779.         PPM3
  3780.  
  3781.           set tempdir DIRECTORY
  3782.  
  3783.     4   Setting frequency of download updates
  3784.  
  3785.         PPM2:
  3786.  
  3787.           set downloadstatus NUMBER
  3788.  
  3789.         PPM3:
  3790.  
  3791.           set download-chunksize NUMBER
  3792.  
  3793.     5   Changing the installation root directory:
  3794.  
  3795.         PPM2:
  3796.  
  3797.           set root DIRECTORY
  3798.  
  3799.         PPM3:
  3800.  
  3801.           target set root DIRECTORY
  3802.  
  3803.     6   Listing all installed packages:
  3804.  
  3805.         PPM2:
  3806.  
  3807.           query
  3808.  
  3809.         PPM3:
  3810.  
  3811.           query *
  3812.  
  3813.     7   Listing all packages on server:
  3814.  
  3815.         PPM2:
  3816.  
  3817.           search
  3818.  
  3819.         PPM3:
  3820.  
  3821.           search *
  3822.  
  3823.     8   Enabling HTML documentation generation:
  3824.  
  3825.         PPM2:
  3826.  
  3827.           set rebuildhtml 1
  3828.  
  3829.         PPM3:
  3830.  
  3831.           set rebuild-html 1
  3832. END
  3833.  
  3834. sub smry_unicode { "notes about unicode author names" }
  3835. sub help_unicode { <<'END' }
  3836. unicode -- Notes About Unicode Author Names
  3837.   Description
  3838.     CPAN author names are defined to be in Unicode. Unicode is an
  3839.     international standard ISO 10646, defining the *Universal Character Set
  3840.     (UCS)*. UCS contains all characters of all other character set
  3841.     standards. For more information about Unicode, see
  3842.     http://www.unicode.org/.
  3843.  
  3844.     The CPAN authors website is located at your local CPAN mirror under
  3845.     /authors/00whois.html. For example, you can view it at
  3846.     http://www.cpan.org/authors/00whois.html. This page can be rendered by
  3847.     Mozilla 0.9.8 and Internet Explorer 5.0, but you may have to install
  3848.     extra language packs to view all the author names.
  3849.  
  3850.     By default, PPM3 renders all characters as Latin1 when it prints them to
  3851.     your console. Characters outside the Latin1 range (0-255) are not
  3852.     printed at all.
  3853.  
  3854.     If your console can render UTF-8 characters, you can tell PPM3 not to
  3855.     recode characters by using one of the following environment variables:
  3856.  
  3857.     *   LC_ALL
  3858.  
  3859.     *   LC_CTYPE
  3860.  
  3861.     *   LANG
  3862.  
  3863.     *   PPM_LANG
  3864.  
  3865.     PPM3 requires one of these environment variables to contain the string
  3866.     'UTF-8'. For example, the following setting make PPM3 print
  3867.     beautifully-formatted authors in RedHat Linux 7.2 (assumes you're using
  3868.     a Bourne shell):
  3869.  
  3870.       $ PPM_LANG='en_US.UTF-8' xterm -u8 -e ppm3
  3871.  
  3872.     Linux and Solaris users should refer to xterm for more information about
  3873.     setting up xterm to display UTF-8 characters.
  3874. END
  3875.  
  3876. #============================================================================
  3877. # Utility Functions
  3878. #============================================================================
  3879. sub sort_fields { qw(name title author abstract version repository) }
  3880. sub sort_pkgs {
  3881.     my $o = shift;
  3882.     my $field = lc shift;
  3883.     my @pkgs = @_;
  3884.     my $targ = $o->conf('target');
  3885.     my $filt = sub { $_[0]->getppd_obj($targ)->result->$field };
  3886.     if ($field eq 'name') {
  3887.     return dictsort $filt, @pkgs;
  3888.     }
  3889.     if ($field eq 'title') {
  3890.     return dictsort $filt, @pkgs;
  3891.     }
  3892.     if ($field eq 'author') {
  3893.     return dictsort $filt, @pkgs;
  3894.     }
  3895.     if ($field eq 'abstract') {
  3896.     return dictsort $filt, @pkgs;
  3897.     }
  3898.     if ($field eq 'repository') {
  3899.     return dictsort sub { $_[0]->repository->name }, @pkgs;
  3900.     }
  3901.     if ($field eq 'version') {
  3902.     return sort {
  3903.         my $pa = $a->getppd_obj($targ)->result;
  3904.         my $pb = $b->getppd_obj($targ)->result;
  3905.         $pb->uptodate($pa->version_osd) <=> $pa->uptodate($pb->version_osd)
  3906.     } @pkgs;
  3907.     }
  3908.     @pkgs;
  3909. }
  3910.  
  3911. sub find_index {
  3912.     my $entry = shift || '';
  3913.     my $index = shift;
  3914.     $index = 0 unless defined $index;
  3915.     for (my $i=0; $i<@_; $i++) {
  3916.     return $index + $i if $entry eq $_[$i];
  3917.     }
  3918.     return $index - 1;
  3919. }
  3920.  
  3921. sub bounded {
  3922.     my $lb = shift;
  3923.     my $d = shift;
  3924.     my $ub = shift;
  3925.     return ($d >= $lb and $d <= $ub);
  3926. }
  3927.  
  3928. sub dictsort(@) {
  3929.     my $o = shift if eval { $_[0]->isa("PPMShell") };
  3930.     my $filt = ref($_[0]) eq 'CODE' ? shift @_ : undef;
  3931.     return map { $_->[0] }
  3932.        sort { lc $a->[1] cmp lc $b->[1] }
  3933.        map { [ $_, $filt ? $filt->($_) : $_ ] } @_;
  3934. }
  3935.  
  3936. sub path_under {
  3937.     my $path = shift;
  3938.     my $cmp  = shift;
  3939.     if ($^O eq 'MSWin32') {
  3940.     $path =~ s#\\#/#g;
  3941.     $cmp  =~ s#\\#/#g;
  3942.     return $path =~ /^\Q$cmp\E/i;
  3943.     }
  3944.     else {
  3945.     return $path =~ /^\Q$cmp\E/;
  3946.     }
  3947. }
  3948.  
  3949. sub prompt_str {
  3950.     my $o = shift;
  3951.  
  3952.     # Hack: set the pager here, instead of in settings_setkey()
  3953.     $o->{API}{pager} = $o->conf('pager');
  3954.  
  3955.     my @search_results = $o->cache_sets('search');
  3956.     my $search_result_current = $o->cache_set_current('search');
  3957.     my $search_result_index = $o->cache_set_index('search');
  3958.     my @query_results = $o->cache_sets('query');
  3959.     my $query_result_current = $o->cache_set_current('query');
  3960.     my $query_result_index = $o->cache_set_index('query');
  3961.  
  3962.     # Make sure a profile is selected if they turned tracking on.
  3963.     my $profile_track = $o->conf('profile-track');
  3964.     my $profile       = PPM::UI::profile_get()->result;
  3965.     $o->setup_profile()
  3966.     if $profile_track and not $profile and $o->mode eq 'SHELL';
  3967.  
  3968.     my @targs = PPM::UI::target_list()->result_l;
  3969.     if (@targs and not find_index($o->conf('target'), 1, @targs)) {
  3970.     $o->conf('target', $targs[0]);
  3971.     }
  3972.  
  3973.     if ($o->conf('prompt-context')) {
  3974.     my ($targ, $rep, $s, $sp, $q, $qp);
  3975.  
  3976.     if ($o->conf('prompt-verbose')) {
  3977.         my $sz = $o->conf('prompt-slotsize');
  3978.         $targ = substr($o->conf('target'), 0, $sz);
  3979.         $rep  = substr($o->conf('repository'), 0, $sz);
  3980.  
  3981.         my $sq_tmp = $o->cache_set('search', undef, 'query');
  3982.         my $ss_tmp = $o->cache_set('search');
  3983.         my $sp_tmp = $o->cache_entry('search');
  3984.         $s = (defined $sq_tmp)
  3985.           ? ":" . substr($sq_tmp, 0, $sz)
  3986.           : "";
  3987.         $sp = ($s and defined $sp_tmp and
  3988.            bounded(0, $search_result_index, $#$ss_tmp))
  3989.           ? ":" . substr($sp_tmp->name, 0, $sz)
  3990.           : "";
  3991.  
  3992.         my $qq_tmp = $o->cache_set('query', undef, 'query');
  3993.         my $qs_tmp = $o->cache_set('query');
  3994.         my $qp_tmp = $o->cache_entry('query');
  3995.         $q = (defined $qq_tmp)
  3996.           ? ":" . substr($qq_tmp, 0, $sz)
  3997.           : "";
  3998.         $qp = ($q and defined $qp_tmp and
  3999.            bounded(0, $query_result_index, $#$qs_tmp))
  4000.           ? ":" . substr($qp_tmp->name, 0, $sz)
  4001.           : "";
  4002.     }
  4003.     else {
  4004.         # Target and Repository:
  4005.         $targ = find_index($o->conf('target'), 1, @targs);
  4006.         $targ = '?' if $targ == 0;
  4007.     
  4008.         # Search number & package:
  4009.         $s = @search_results ? ":s".($search_result_current + 1) : "";
  4010.         my $sp_tmp = $o->cache_set('search');
  4011.         $sp = ($s and defined $sp_tmp and 
  4012.            bounded(0, $search_result_index, $#$sp_tmp))
  4013.           ? ":sp".($search_result_index + 1)
  4014.           : "";
  4015.     
  4016.         # Query number & package:
  4017.         $q = @query_results ? ":q".($query_result_current + 1) : "";
  4018.         my $qp_tmp = $o->cache_set('query');
  4019.         $qp = ($q and defined $qp_tmp and
  4020.            bounded(0, $query_result_index, $#$qp_tmp))
  4021.           ? ":qp".($query_result_index + 1)
  4022.           : "";
  4023.     }
  4024.     return "ppm:$targ$s$sp$q$qp> ";
  4025.     }
  4026.     else {
  4027.     return "ppm> ";
  4028.     }
  4029. }
  4030.  
  4031. {
  4032.     # Weights for particular fields: these are stored in percentage of the
  4033.     # screen width, based on the number of columns they use on an 80 column
  4034.     # terminal. They also have a minimum and maximum.
  4035.     use constant MIN    => 0;
  4036.     use constant MAX    => 1;
  4037.     my %weight = (
  4038.     name     => [12, 20],
  4039.     title    => [12, 20],
  4040.     abstract => [12, 20],
  4041.     author   => [12, 20],
  4042.     repository => [12, 20],
  4043.     version  => [ 4,  9],
  4044.     );
  4045.     my %meth = (
  4046.     name     => 'name',
  4047.     title    => 'title',
  4048.     version  => 'version',
  4049.     abstract => 'abstract',
  4050.     author   => 'author',
  4051.     repository => sub {
  4052.         my $o = shift;
  4053.         my $rep = $o->repository or return "Installed";
  4054.         my $name = $rep->name;
  4055.         my $id   = $o->id || $name;
  4056.         my $loc  = $rep->location;
  4057.         "$name [$loc]"
  4058.     },
  4059.     );
  4060.     # These are Text::Autoformat justification marks. They're actually used to
  4061.     # build a printf() format string, since it's so much more efficient for a
  4062.     # non-line-wrapping case.
  4063.     my %just = (
  4064.     name     => '<',
  4065.     title    => '<',
  4066.     abstract => '<',
  4067.     author   => '<',
  4068.     repository => '<',
  4069.     version  => '>',
  4070.     );
  4071.     my %plus = (
  4072.     name     => '0',
  4073.     title    => '0',
  4074.     abstract => '0',
  4075.     author   => '0',
  4076.     repository => '0',
  4077.     version  => '2',
  4078.     );
  4079.     my %filt = (
  4080.     version => q{"[$_]"},
  4081.     );
  4082.     sub picture_optimized {
  4083.     my $o = shift;
  4084.     my @items = @{shift(@_)};
  4085.     unless ($o->conf('fields')) {
  4086.         my $m = $o->setmode('SILENT');
  4087.         $o->conf('fields', '', 1);
  4088.         $o->setmode($m);
  4089.     }
  4090.     my @fields = split ' ', $o->conf('fields');
  4091.     $_ = lc $_ for @fields;
  4092.     my (%max_width, %width);
  4093.     my $cols = $o->termsize->{cols};
  4094.     for my $f (@fields) {
  4095.         my $meth = $meth{$f};
  4096.         $max_width{$f} = max { length($_->$meth) } @items;
  4097.         $max_width{$f} += $plus{$f};
  4098.         $width{$f} = $max_width{$f} / 80 * $cols;
  4099.         my $max_f  = $weight{$f}[MAX] / 80 * $cols;
  4100.         my $min_f  = $weight{$f}[MIN];
  4101.         my $gw     = $width{$f};
  4102.         $width{$f} = (
  4103.         $width{$f} > $max_width{$f} ? $max_width{$f} :
  4104.         $width{$f} > $max_f         ? $max_f         :
  4105.         $width{$f} < $min_f         ? $min_f         : $width{$f}
  4106.         );
  4107.     }
  4108.     my $right = $fields[-1];
  4109.     my $index_sz = length( scalar(@items) ) + 3; # index spaces
  4110.     my $space_sz = @fields + 1; # separator spaces
  4111.     my $room = $cols - $index_sz - $space_sz;
  4112.     $width{$right} = $room - sum { $width{$_} } @fields[0 .. $#fields-1];
  4113.     while ($width{$right} > $max_width{$right}) {
  4114.         my $smallest;
  4115.         my $n;
  4116.         for my $k (@fields[0 .. $#fields-1]) {
  4117.         my $max = $max_width{$k};
  4118.         my $sz  = $width{$k};
  4119.         $smallest = $k, $n = $max - $sz if $max - $sz > $n;
  4120.         }
  4121.         $width{$right}--;
  4122.         $width{$smallest}++;
  4123.     }
  4124.     while ($width{$right} < $weight{$right}[MIN]) {
  4125.         my $biggest;
  4126.         my $n;
  4127.         for my $k (@fields[0 .. $#fields-1]) {
  4128.         my $max = $max_width{$k};
  4129.         my $sz  = $width{$k};
  4130.         $biggest = $k, $n = $max - $sz if $max - $sz < $n;
  4131.         }
  4132.         $width{$right}++;
  4133.         $width{$biggest}--;
  4134.     }
  4135.     my $picture;
  4136.     $picture = "\%${index_sz}s "; # printf picture
  4137.     $picture .= join ' ', map {
  4138.         my $w = $width{$_};
  4139.         my $c = $just{$_};
  4140.         my $pad = $c eq '>' ? '' : '-';
  4141.         "\%${pad}${w}s" # printf picture
  4142.     } @fields;
  4143.     ($picture, \@fields, [@width{@fields}]);
  4144.     }
  4145.  
  4146.     sub print_formatted {
  4147.     my $o = shift;
  4148.     my $targ = $o->conf('target');
  4149.     my @items = map { $_->getppd_obj($targ)->result } @{shift(@_)};
  4150.     my $selected = shift;
  4151.     my $format;
  4152.  
  4153.     # Generate a picture and a list of fields for Text::Autoformat:
  4154.     my (@fields, %width);
  4155.     my ($picture, $f, $w) = $o->picture_optimized(\@items);
  4156.     $picture .= "\n";
  4157.     @fields = @$f;
  4158.     @width{@fields} = @$w;
  4159.  
  4160.     # The line-breaking sub: use '~' as hyphenation signal
  4161.     my $wrap = sub {
  4162.         my ($str, $maxlen, $width) = @_;
  4163.         my $field = substr($str, 0, $maxlen - 1) . '~';
  4164.         my $left  = substr($str, $maxlen - 1);
  4165.         ($field, $left);
  4166.     };
  4167.  
  4168.     my $lines = 0;
  4169.     my $i = 1;
  4170.     my @text;
  4171.     my %seen;
  4172.     for my $pkg (@items) {
  4173.         my $star = (defined $selected and $selected == $i - 1) ? "*" : " ";
  4174.         my $num  = "$star $i.";
  4175.         my @vals = (
  4176.         map {
  4177.             my $field  = $_;
  4178.             my $method = $meth{$field};
  4179.             local $_   = $pkg->$method;
  4180.             my $val = defined $filt{$field} ? eval $filt{$field} : $_;
  4181.             ($val) = $wrap->($val, $width{$field})
  4182.                 if length $val > $width{$field};
  4183.             $val;
  4184.         }
  4185.         @fields
  4186.         );
  4187. #        my $key = join '', @vals;
  4188. #        if (exists $seen{$key}) {
  4189. #        my $index = $seen{$key};
  4190. #        substr($text[$index], 0, 1) = '+';
  4191. #        next;
  4192. #        }
  4193. #        $seen{$key} = $i - 1;
  4194.         (my $inc = sprintf $picture, $num, @vals) =~ s/[ ]+$//;
  4195.         push @text, $inc;
  4196.         $i++;
  4197.     }
  4198.  
  4199.     # And, page it.
  4200.     $o->page(join '', @text);
  4201.     }
  4202. }
  4203.  
  4204. sub tree_pkg {
  4205.     my $o = shift;
  4206.     my @rlist = $o->reps_on;
  4207.     my $tar = $o->conf('target');
  4208.     my $pkg = shift;
  4209.     my $ppd;
  4210.     if (eval { $pkg->isa('PPM::Package') }) {
  4211.     $ppd = $pkg->getppd_obj($tar);
  4212.     unless ($ppd->ok) {
  4213.         $o->warn($ppd->msg);
  4214.         return;
  4215.     }
  4216.     $ppd = $ppd->result;
  4217.     }
  4218.     else {
  4219.     my ($s, $i) = $o->cache_find('search', $pkg);
  4220.     if ($i >= 0) {
  4221.         $ppd = $o->cache_entry('search', $i, $s);
  4222.     } 
  4223.     else {
  4224.         my $ok = PPM::UI::describe(\@rlist, $tar, $pkg);
  4225.         unless ($ok->is_success) {
  4226.         $o->warn($ok->msg);
  4227.         return unless $ok->ok;
  4228.         }
  4229.         $ppd = $ok->result->getppd_obj($tar);
  4230.         unless ($ppd->ok) {
  4231.         $o->warn($ppd->msg);
  4232.         return;
  4233.         }
  4234.         $ppd = $ppd->result;
  4235.     }
  4236.     }
  4237.  
  4238.     my $pad = "\n";
  4239.     $o->inform($ppd->name, " ", $ppd->version);
  4240.     $o->Tree(\@rlist, $tar, $ppd->name, $pad, {});
  4241.     $o->inform($pad);
  4242. }
  4243.  
  4244. my ($VER, $HOR, $COR, $TEE, $SIZ) = ('|', '_', '\\', '|', ' ');
  4245.  
  4246. sub Tree {
  4247.     my $o = shift;
  4248.     my $reps = shift;
  4249.     my $tar = shift;
  4250.     my $pkg = shift;
  4251.     my $ind = shift;
  4252.     my $seen = shift;
  4253.     my $pad = $ind . "  " . $VER;
  4254.  
  4255.     my $ppd;
  4256.     if (exists $seen->{$pkg}) {
  4257.     $ppd = $seen->{$pkg};
  4258.     }
  4259.     else {
  4260.     my ($s, $i) = $o->cache_find('search', $pkg);
  4261.     if ($i >= 0) {
  4262.         $ppd = $o->cache_entry('search', $i, $s);
  4263.     }
  4264.     else {
  4265.         my $ok = PPM::UI::describe($reps, $tar, $pkg);
  4266.         unless ($ok->is_success) {
  4267.         $o->inform(" -- package not found; skipping tree");
  4268.         return 0 unless $ok->ok;
  4269.         }
  4270.         $ppd = $ok->result;
  4271.     }
  4272.     $ppd->make_complete($tar);
  4273.     $ppd = $ppd->getppd_obj($tar);
  4274.     unless ($ppd->ok) {
  4275.         $o->warn($ppd->msg);
  4276.         return;
  4277.     }
  4278.     $ppd = $ppd->result;
  4279.     $seen->{$pkg} = $ppd;
  4280.     }
  4281.  
  4282.     my @impls   = $ppd->implementations;
  4283.     return 0 unless @impls;
  4284.     my @prereqs = $impls[0]->prereqs;
  4285.     return 0 unless @prereqs;
  4286.     my $nums = scalar @prereqs;
  4287.  
  4288.     for (1..$nums) {
  4289.     my $doneblank = 0;
  4290.     my $pre = $prereqs[$_-1];
  4291.     my $txt = $pre->name . " " . $pre->version;
  4292.     if ($_ == $nums) {
  4293.         substr($pad, -1) = $COR;
  4294.         $o->inform($pad, "$HOR$HOR", $txt);
  4295.         substr($pad, -1) = ' ';
  4296.     }
  4297.     else {
  4298.         substr($pad, -1) = $TEE;
  4299.         $o->inform($pad, "$HOR$HOR", $txt);
  4300.         substr($pad, -1) = $VER;
  4301.     }
  4302.     if ($o->Tree($reps, $tar, $pre->name, $pad, $seen) != 0 and
  4303.         $doneblank == 0) {
  4304.         $o->inform($pad); ++$doneblank;
  4305.     }
  4306.     }
  4307.     return $nums;
  4308. }
  4309.  
  4310. sub describe_pkg {
  4311.     my $o = shift;
  4312.     my $pkg = shift;
  4313.     my ($extra_keys, $extra_vals) = (shift || [], shift || []);
  4314.     my $n; 
  4315.  
  4316.     # Get the PPM::PPD object out of the PPM::Package object.
  4317.     my $pkg_des = $pkg->describe($o->conf('target'));
  4318.     unless ($pkg_des->ok) {
  4319.     $o->warn($pkg_des->msg);
  4320.     return;
  4321.     }
  4322.     $pkg_des = $pkg_des->result;
  4323.  
  4324.     # Basic information:
  4325.     $n = $o->print_pairs(
  4326.     [qw(Name Version Author Title Abstract), @$extra_keys],
  4327.     [(map { $pkg_des->$_ } qw(name version author title abstract)),
  4328.      @$extra_vals],
  4329.     undef,    # separator
  4330.     undef,    # left
  4331.     undef,    # indent
  4332.     undef,    # length
  4333.     1,    # wrap (yes, please wrap)
  4334.     );
  4335.  
  4336.     # The repository:
  4337.     if (my $rep = $pkg_des->repository) {
  4338.     $o->print_pairs(
  4339.         ["Location"],
  4340.         [$rep->name],
  4341.         undef,    # separator
  4342.         undef,    # left
  4343.         undef,    # indent
  4344.         $n,        # length
  4345.         1,        # wrap
  4346.     );
  4347.     }
  4348.     
  4349.     # Prerequisites:
  4350.     my @impls = grep { $_->architecture } $pkg_des->implementations;
  4351.     my @prereqs = @impls ? $impls[0]->prereqs : ();
  4352.     $o->inform("Prerequisites:\n") if @prereqs;
  4353.     $o->print_pairs(
  4354.     [ 1 .. @prereqs ],
  4355.     [ map { $_->name . ' ' . $_->version} @prereqs ],
  4356.     '. ',    # separator
  4357.     undef,    # left
  4358.     undef,    # indent
  4359.     $n,    # length
  4360.     0,    # wrap (no, please don't wrap)
  4361.     );
  4362.     
  4363.     # Implementations:
  4364.     $o->inform("Available Platforms:\n") if @impls;
  4365.     my @impl_strings;
  4366.     for (@impls) {
  4367.     my $arch  = $_->architecture;
  4368.     my $os    = $_->os;
  4369.     my $osver = $_->osversion;
  4370.     my $str   = $arch;
  4371.     $osver    =~ s/\Q(any version)\E//g;
  4372.     if ($os and $osver) {
  4373.         $str .= ", $os $osver";
  4374.     }
  4375.     push @impl_strings, $str;
  4376.     }
  4377.     @impl_strings = dictsort @impl_strings;
  4378.     $o->print_pairs(
  4379.     [ 1 .. @impls ],
  4380.     [ @impl_strings ],
  4381.     '. ', undef, undef, $n
  4382.     );
  4383. }
  4384.  
  4385. sub remove_pkg {
  4386.     my $o = shift;
  4387.     my $package = shift;
  4388.     my $target = $o->conf('target');
  4389.     my $force = shift;
  4390.     my $quell_clear = shift;
  4391.     my $verbose = $o->conf('remove-verbose');
  4392.     my $ok = PPM::UI::remove($target, $package, $force, sub { $o->cb_remove(@_) }, $verbose);
  4393.     unless ($ok->is_success) {
  4394.     $o->warn($ok->msg);
  4395.     return 0 unless $ok->ok;
  4396.     }
  4397.     else {
  4398.     $o->warn_profile_change($ok);
  4399.     }
  4400.     $o->cache_clear('query') if ($ok->ok and not $quell_clear);
  4401.     1;
  4402. }
  4403.  
  4404. sub upgrade_pkg {
  4405.     push @_, 'upgrade';
  4406.     goto &install_pkg;
  4407. }
  4408. sub install_pkg {
  4409.     my $o = shift;
  4410.     my $pkg = shift;
  4411.     my $opts = shift;
  4412.     my $action = shift;
  4413.     my $quell_clear = shift;
  4414.     $action = 'install' unless defined $action;
  4415.  
  4416.     # Find the package:
  4417.     while (1) {
  4418.     # 1. Return if they specified a full filename or URL:
  4419.     last if PPM::UI::is_pkg($pkg);
  4420.  
  4421.     # 2. Check if whatever they specified returns 1 search result:
  4422.     my $search =
  4423.       PPM::UI::search([$o->reps_on], $o->conf('target'), $pkg, 
  4424.               $o->conf('case-sensitivity'));
  4425.     unless ($search->is_success) {
  4426.         $o->warn($search->msg);
  4427.         return unless $search->ok;
  4428.     }
  4429.     my @ret = $search->result_l;
  4430.     if (@ret > 1) {
  4431.         $o->warn(<<END);
  4432. Searching for '$pkg' returned multiple results. Using 'search' instead...
  4433. END
  4434.         $o->run_search($pkg);
  4435.         return;
  4436.     }
  4437.     elsif (not @ret) {
  4438.         $o->warn(<<END);
  4439. Searching for '$pkg' returned no results. Try a broader search first.
  4440. END
  4441.         return;
  4442.     }
  4443.     $pkg = $ret[0]->name;
  4444.     last;
  4445.     }
  4446.  
  4447.     my $cb = (
  4448.     $opts->{dryrun}
  4449.     ? $action eq 'install' ? \&dr_install : \&dr_upgrade
  4450.     : $action eq 'install' ? \&cb_install : \&cb_upgrade
  4451.     );
  4452.  
  4453.     # Now, do the install
  4454.     my $ok;
  4455.     my @rlist = $o->reps_on;
  4456.     my $targ = $o->conf('target');
  4457.  
  4458.     my $prop = PPM::UI::properties($targ, $pkg);
  4459.     if ($prop->ok) {
  4460.     my $name = ($prop->result_l)[0]->name;
  4461.     if (ref $pkg) {
  4462.         $pkg->name($name);
  4463.     }
  4464.     else {
  4465.         $pkg = $name;
  4466.     }
  4467.     }
  4468.  
  4469.     if ($action eq 'install') {
  4470.     $opts->{verbose} = $o->conf('install-verbose');
  4471.     my $pkgname = ref $pkg ? $pkg->name : $pkg;
  4472.     if ($prop->ok) {
  4473.         $o->inform("Note: Package '$pkgname' is already installed.\n");
  4474.         return unless $opts->{force};
  4475.     }
  4476.     $ok = PPM::UI::install(\@rlist, $targ, $pkg, $opts, sub {$o->$cb(@_)});
  4477.     }
  4478.     else {
  4479.     $opts->{verbose} = $o->conf('upgrade-verbose');
  4480.     $ok = PPM::UI::upgrade(\@rlist, $targ, $pkg, $opts, sub {$o->$cb(@_)});
  4481.     }
  4482.  
  4483.     unless ($ok->is_success) {
  4484.     $o->warn($ok->msg);
  4485.     return unless $ok->ok;
  4486.     }
  4487.     else {
  4488.     $o->warn_profile_change($ok);
  4489.     $o->cache_clear('query') unless $quell_clear;
  4490.     }
  4491.     1;
  4492. }
  4493.  
  4494. # The dry run callback; just prints out package name and version:
  4495. sub dr_install {
  4496.     my $o = shift;
  4497.     my $pkg = shift;
  4498.     my $version = shift;
  4499.     my $target_name = shift;
  4500.     $o->inform(<<END);
  4501. Dry run install '$pkg' version $version in $target_name.
  4502. END
  4503. }
  4504.  
  4505. sub dr_upgrade {
  4506.     my $o = shift;
  4507.     my $pkg = shift;
  4508.     my $version = shift;
  4509.     my $target_name = shift;
  4510.     $o->inform(<<END);
  4511. Dry run upgrade '$pkg' version $version in $target_name.
  4512. END
  4513. }
  4514.  
  4515. sub dr_remove {
  4516.     my $o = shift;
  4517.     my $pkg = shift;
  4518.     my $version = shift;
  4519.     my $target_name = shift;
  4520.     $o->inform(<<END);
  4521. Dry run remove '$pkg' version $version from $target_name.
  4522. END
  4523. }
  4524.  
  4525. sub cb_remove {
  4526.     my $o = shift;
  4527.     my $pkg = shift;
  4528.     my $version = shift;
  4529.     my $target_name = shift;
  4530.     my $status = shift;
  4531.     if ($status eq 'COMPLETE') {
  4532.     $o->inform(
  4533.         "Successfully removed $pkg version $version from $target_name.\n"
  4534.     )
  4535.     }
  4536.     else {
  4537.     $o->inform(<<END);
  4538. $SEP
  4539. Remove '$pkg' version $version from $target_name.
  4540. $SEP
  4541. END
  4542.     }
  4543. }
  4544.  
  4545. sub cb_install {
  4546.     my $o = shift;
  4547.     unshift @_, $o, 'install';
  4548.     &cb_status;
  4549. }
  4550.  
  4551. sub cb_upgrade {
  4552.     my $o = shift;
  4553.     unshift @_, $o, 'upgrade';
  4554.     &cb_status;
  4555. }
  4556.  
  4557. sub cb_status {
  4558.     my $o = shift;
  4559.     my $ACTION = shift;
  4560.     my $pkg = shift;
  4561.     my $version = shift;
  4562.     my $target_name = shift;
  4563.     my $status = shift;
  4564.     my $bytes = shift;
  4565.     my $total = shift;
  4566.     my $secs = shift;
  4567.  
  4568.     my $cols = $ENV{COLUMNS} || 78;
  4569.  
  4570.     $o->inform(<<END) and return if ($status eq 'PRE-INSTALL');
  4571. $SEP
  4572. \u$ACTION '$pkg' version $version in $target_name.
  4573. $SEP
  4574. END
  4575.  
  4576.     # Print the output on one line, repeatedly:
  4577.     my ($line, $pad, $eol);
  4578.     if ($status eq 'DOWNLOAD') {
  4579.     if ($bytes < $total) {
  4580.         $line = "Transferring data: $bytes/$total bytes.";
  4581.         $eol = "\r";
  4582.     }
  4583.     else {
  4584.         $line = "Downloaded $bytes bytes.";
  4585.         $eol = "\n";
  4586.     }
  4587.     }
  4588.     elsif ($status eq 'PRE-EXPAND') {
  4589.     $line = ""; #"Extracting package. This may take a few seconds.";
  4590.     $eol = "\r";  #"\n";
  4591.     }
  4592.     elsif ($status eq 'EXPAND') {
  4593.     $line = "Extracting $bytes/$total: $secs";
  4594.     $eol = $bytes < $total ? "\r" : "\n";
  4595.     }
  4596.     elsif ($status eq 'COMPLETE') {
  4597.     my $verb = $ACTION eq 'install' ? 'installed' : 'upgraded';
  4598.     $o->inform(
  4599.         "Successfully $verb $pkg version $version in $target_name.\n"
  4600.     );
  4601.     return;
  4602.     }
  4603.     $pad = ' ' x ($cols - length($line));
  4604.     $o->verbose($line, $pad, $eol);
  4605. }
  4606.  
  4607. sub warn_profile_change {
  4608.     my $o = shift;
  4609.     my $ok = shift;
  4610.  
  4611.     my $profile_track = $o->conf('profile-track');
  4612.     my $profile = PPM::UI::profile_get()->result;
  4613.  
  4614.     if ($profile_track) {
  4615.     $o->verbose(<<END);
  4616. Tracking changes to profile '$profile'.
  4617. END
  4618.     }
  4619. }
  4620.  
  4621. sub parse_range {
  4622.     my @numbers;
  4623.     my $arg;
  4624.     while ($arg = shift) {
  4625.       while ($arg) {
  4626.     if ($arg =~ s/^\s*,?\s*(\d+)\s*-\s*(\d+)//) {
  4627.         push @numbers, ($1 .. $2);
  4628.     }
  4629.     elsif ($arg =~ s/^\s*,?\s*(\d+)//) {
  4630.         push @numbers, $1;
  4631.     }
  4632.     else {
  4633.         last;
  4634.     }
  4635.       }
  4636.     }
  4637.     @numbers;
  4638. }
  4639.  
  4640. sub raw_args {
  4641.     my $o = shift;
  4642.     strip($o->line_args);
  4643. }
  4644.  
  4645. sub strip {
  4646.     my $f = shift;
  4647.     $f =~ s/^\s*//;
  4648.     $f =~ s/\s*$//;
  4649.     $f;
  4650. }
  4651.  
  4652. # matches("neil", "ne|il") => 1
  4653. # matches("ne", "ne|il") => 1
  4654. # matches("n", "ne|il") => 0
  4655. sub matches {
  4656.     my $cmd = shift;
  4657.     my $pat = shift || "";
  4658.  
  4659.     my ($required, $extra) = split '\|', $pat;
  4660.     $extra ||= "";
  4661.     my $regex = "$required(?:";
  4662.     for (my $i=1; $i<=length($extra); $i++) {
  4663.     $regex .= '|' . substr($extra, 0, $i);
  4664.     }
  4665.     $regex .= ")";
  4666.     return $cmd =~ /^$regex$/i;
  4667. }
  4668.  
  4669. sub pause_exit {
  4670.     my $o = shift;
  4671.     my $exit_code = shift || 0;
  4672.     my $pause = shift || 0;
  4673.     if ($pause) {
  4674.     if ($o->have_readkey) {
  4675.         $o->inform("Hit any key to exit...");
  4676.     }
  4677.     else {
  4678.         $o->inform("Hit <ENTER> to exit...");
  4679.     }
  4680.     $o->readkey;
  4681.     }
  4682.     exit $exit_code;
  4683. }
  4684.  
  4685. #============================================================================
  4686. # Check if this is the first time we've ever used profiles. This can be
  4687. # guessed: if the 'profile' entry is not set, but the 'profile-track' flag
  4688. # is, then it's the first time profile-track has been set to '1'.
  4689. #============================================================================
  4690. sub setup_profile {
  4691.     my $o = shift;
  4692.     $o->inform(<<END);
  4693. $SEP
  4694. You have profile tracking turned on: now it's time to choose a profile name.
  4695. ActiveState's PPM 3 Server will track which packages you have installed on
  4696. your machine. This information is stored in a "profile", located on the
  4697. server.
  4698.  
  4699. Here are some features of profiles:
  4700.  o You can have as many profiles as you want;
  4701.  o Each profile can track an unlimited number of packages;
  4702.  o PPM defaults to "tracking" your profile (it updates your profile every time
  4703.    you add or remove a package;
  4704.  o You can disable profile tracking by modifying the 'profile-track' option;
  4705.  o You can manually select, save, and restore profiles;
  4706.  o You can view your profile from ASPN as well as inside PPM 3.
  4707. $SEP
  4708.  
  4709. END
  4710.  
  4711.     my $response = PPM::UI::profile_list();
  4712.     my @l;
  4713.     unless ($response->ok) {
  4714.     $o->warn("Failed to enable profile tracking: ".$response->msg);
  4715.     $o->warn(<<END);
  4716.  
  4717. You can still use PPM3, but profiles are not enabled. To try setting up
  4718. profiles again, enter 'set profile-track=1'. Or, you can set up profiles
  4719. by hand, using the 'profile add' command.
  4720.  
  4721. END
  4722.     $o->run('unset', 'profile-track');
  4723.     return;
  4724.     }
  4725.     else {
  4726.     @l = sort $response->result_l;
  4727.     $o->inform("It looks like you have profiles on the server already.\n")
  4728.       if @l;
  4729.     $o->print_pairs([1 .. @l], \@l, '. ', 1, ' ');
  4730.     $o->inform("\n") if @l;
  4731.     }
  4732.  
  4733.     require PPM::Sysinfo;
  4734.     (my $suggest = PPM::Sysinfo::hostname()) =~ s/\..*$//;
  4735.     $suggest ||= "Default Profile";
  4736.     my $profile_name = $o->prompt(
  4737.     "What profile name would you like? [$suggest] ", $suggest, @l
  4738.     );
  4739.  
  4740.     my $select_existing = grep { $profile_name eq $_ } $response->result_l
  4741.       if $response->ok;
  4742.     if ($select_existing) {
  4743.     $o->inform("Selecting profile '$profile_name'...\n");
  4744.     PPM::UI::profile_set($profile_name);
  4745.     $o->inform(<<END);
  4746. You should probably run either 'profile save' or 'profile restore' to bring
  4747. the profile in sync with your computer.
  4748. END
  4749.     }
  4750.     elsif ($response->ok) {
  4751.     $o->inform("Creating profile '$profile_name'...\n");
  4752.     $o->run('profile', 'add', $profile_name);
  4753.     $o->inform("Saving profile '$profile_name'...\n");
  4754.     $o->run('profile', 'save');
  4755.     $o->inform(<<END);
  4756. Congratulations! PPM is now set up to track your profile.
  4757. END
  4758.     }
  4759.     else {
  4760.     $o->warn($response->msg);
  4761.     $o->warn(<<END);
  4762.  
  4763. You can still use PPM3, but profiles will not be enabled. To try setting up
  4764. profiles again, enter 'set profile-track=1'. Or, you can set up profiles
  4765. yourself using the 'profile add' command.
  4766.  
  4767. END
  4768.     $o->run('unset', 'profile-track');
  4769.     }
  4770. }
  4771.  
  4772. package main;
  4773. use Getopt::Long;
  4774. use Data::Dumper;
  4775.  
  4776. $ENV{PERL_READLINE_NOWARN} = "1";
  4777. $ENV{PERL_RL} = $^O eq 'MSWin32' ? "0" : "Perl";
  4778.  
  4779. my ($pause, $input_file, $target);
  4780.  
  4781. BEGIN {
  4782.     my ($shared_config_files, @fixpath, $gen_inst_key);
  4783.  
  4784.     Getopt::Long::Configure('pass_through');
  4785.     $target = 'auto';
  4786.     GetOptions(
  4787.     'file=s' => \$input_file,
  4788.     'shared' => \$shared_config_files,
  4789.     'target:s' => \$target,
  4790.     'fixpath=s' => \@fixpath,
  4791.     'generate-inst-key' => \$gen_inst_key,
  4792.     pause => \$pause,
  4793.     );
  4794.     Getopt::Long::Configure('no_pass_through');
  4795.  
  4796.     if ($shared_config_files) {
  4797.     $ENV{PPM3_shared_config} = 1;
  4798.     }
  4799.  
  4800.     if (@fixpath) {
  4801.     PPM::UI::target_fix_paths(@fixpath);
  4802.     exit;
  4803.     }
  4804.     if ($gen_inst_key) {
  4805.     require PPM::Config;
  4806.     PPM::Config::load_config_file('instkey');
  4807.     exit;
  4808.     }
  4809. }
  4810.  
  4811. # If we're being run from a file, tell Term::Shell about it:
  4812. if ($input_file) {
  4813.     my $line = 0;
  4814.     open SCRIPT, $input_file or die "$0: can't open $input_file: $!";
  4815.     my $shell = PPMShell->new(
  4816.     term => ['PPM3', \*SCRIPT, \*STDOUT],
  4817.     target => $target,
  4818.     pager => 'none',
  4819.     );
  4820.     $shell->setmode('SCRIPT');
  4821.     while (<SCRIPT>) {
  4822.     $line++;
  4823.     next if /^\s*#/ or /^\s*$/;
  4824.     my ($cmd, @args) = $shell->line_parsed($_);
  4825.     my $ret = $shell->run($cmd, @args);
  4826.     my $warn = <<END;
  4827. $0: $input_file:$line: fatal error: unknown or ambiguous command '$cmd'. 
  4828. END
  4829.     $shell->warn($warn) and $shell->pause_exit(2, $pause)
  4830.         unless $shell->{API}{cmd}{run}{found};
  4831.     $shell->pause_exit(1, $pause) unless $ret;
  4832.     }
  4833.     close SCRIPT;
  4834.     $shell->pause_exit(0, $pause);
  4835. }
  4836.  
  4837. # If we've been told what to do from the command-line, do it right away:
  4838. elsif (@ARGV) {
  4839.     my $shell = PPMShell->new(target => $target, pager => 'none');
  4840.     $shell->setmode('BATCH');
  4841.     my $ret = $shell->run($ARGV[0], @ARGV[1..$#ARGV]);
  4842.     my $warn = <<END;
  4843. Unknown or ambiguous command '$ARGV[0]'; type 'help' for commands.
  4844. END
  4845.     $shell->warn($warn) and $shell->pause_exit(2, $pause)
  4846.     unless $shell->{API}{cmd}{run}{found};
  4847.     $shell->pause_exit(0, $pause) if $ret;
  4848.     $shell->pause_exit(1, $pause);
  4849. }
  4850.  
  4851. # Just run the command loop
  4852. if (-t STDIN and -t STDOUT) {
  4853.     my $shell = PPMShell->new(target => $target);
  4854.     $shell->setmode('SHELL');
  4855.     $shell->cmdloop;
  4856. }
  4857. else {
  4858.     die <<END;
  4859.  
  4860. Error:
  4861.     PPM3 cannot be run in interactive shell mode unless both STDIN and
  4862.     STDOUT are connected to a terminal or console. If you want to
  4863.     capture the output of a command, use PPM3 in batch mode like this:
  4864.  
  4865.        ppm3 search IO-stringy > results.txt
  4866.  
  4867.     Type 'perldoc ppm3' for more information.
  4868.  
  4869. END
  4870. }
  4871.  
  4872.  
  4873. =head1 NAME
  4874.  
  4875. ppm3-bin - ppm3 executable
  4876.  
  4877. =head1 SYNOPSIS
  4878.  
  4879. Do not run I<ppm3-bin> manually. It is meant to be called by the wrapper
  4880. program I<ppm3>. See L<ppm3>.
  4881.  
  4882. =head1 DESCRIPTION
  4883.  
  4884. I<ppm3> runs I<ppm3-bin> after setting up a few environment variables. You
  4885. should run I<ppm3> instead.
  4886.  
  4887. For information about I<ppm3> commands, see L<ppm3>.
  4888.  
  4889. =head1 SEE ALSO
  4890.  
  4891. See L<ppm3>.
  4892.  
  4893. =head1 AUTHOR
  4894.  
  4895. ActiveState Corporation (support@ActiveState.com)
  4896.  
  4897. =head1 COPYRIGHT
  4898.  
  4899. Copyright (C) 2001, 2002, ActiveState Corporation. All Rights Reserved.
  4900.  
  4901. =cut
  4902.  
  4903. __END__
  4904. :endofperl
  4905.