home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / tk-ppm < prev    next >
Encoding:
Text File  |  2003-11-20  |  34.5 KB  |  1,160 lines
  1. #!perl
  2. use strict;
  3. #use warnings;
  4. use Tk;
  5. use PPM;
  6. use Tk::MListbox;
  7. require Tk::DialogBox;
  8. require Tk::BrowseEntry;
  9. require Tk::LabEntry;
  10. use PPM::Make::Util qw(:all);
  11. use PPM::Repositories;
  12. use CPAN;
  13. use Win32::Process;
  14.  
  15. my $d = parse_ppm();
  16. my $ppmv = ppd2cpan_version($d->{PPMVER});
  17.  
  18. our ($type, $message, $no_case, $save, $repository, $VERSION,
  19.     $ppm_ignore, $ppm_remove, $partial, $old_partial);
  20. $type = 'Package';
  21. $no_case = 1;
  22. $old_partial = 1;
  23. $partial = 1;
  24. $save = 1;
  25. $ppm_remove = 0;
  26. $ppm_ignore = 0;
  27. $main::VERSION = $PPM::Make::VERSION;
  28. my $shell = $ENV{ComSpec};
  29. my $ext = qr{\.(tar\.gz|tgz|tar\.Z|zip)};
  30.  
  31. my (%reps, %alias, @choices, %indices);
  32. ## Create main perl/tk window.
  33. my $mw = MainWindow->new;
  34. $mw->title("Interface to PPM $ppmv");
  35.  
  36. my ($info, $error, $upgrades);
  37.  
  38. ## Create the MListbox widget. 
  39. ## Specify alternative comparison routine for integers and date.
  40. ## frame, but since the "Show All" button references $ml, we have to create
  41. ## it now. 
  42.  
  43. my %tan = qw(-bg tan -fg black);
  44. my %orange = qw(-bg orange -fg black);
  45. my %green = qw(-bg green -fg black);
  46. my %cyan = qw(-bg cyan -fg black);
  47. my %yellow = qw(-bg yellow -fg black);
  48.  
  49. CPAN::Config->load unless $CPAN::Config_loaded++;
  50. my $top = $mw->Frame(-label => "Interface to PPM $ppmv");
  51. my $options = $mw->Frame();
  52. my $left = $mw->Frame(-label => 'Local');
  53. my $middle = $mw->Frame();
  54. my $right = $mw->Frame(-label => 'Repository');
  55. my $bottom = $mw->Frame();
  56.  
  57. my $cb_label = 
  58.   $options->Label(-text => 'Treat query as a',
  59.          )->pack(-side => 'left', -padx => 4);
  60.  
  61. my $package = $options->Radiobutton(-text => 'Package',
  62.                    -variable => \$type,
  63.                    -value => 'Package',
  64.                                    -command => \&enable_partial,
  65.                   )->pack(-side => 'left');
  66. help_msg($package, 'Treat search term as a package name');
  67.  
  68. my $abstract = $options->Radiobutton(-text => 'Abstract',
  69.                      -variable => \$type,
  70.                      -value => 'ABSTRACT',
  71.                                      -command => \&enable_partial,
  72.                     )->pack(-side => 'left');
  73. help_msg($abstract, 'Treat search term as part of the abstract');
  74.  
  75. my $author = $options->Radiobutton(-text => 'Author',
  76.                    -variable => \$type,
  77.                    -value => 'AUTHOR',
  78.                                    -command => \&enable_partial,
  79.                   )->pack(-side => 'left');
  80. help_msg($author, 'Treat search term as an author name');
  81.  
  82. my $module = $options->Radiobutton(-text => 'Module',
  83.                    -variable => \$type,
  84.                    -value => 'Module',
  85.                                    -command => \&disable_partial,
  86.                   )->pack(-side => 'left');
  87. help_msg($module, 'Treat search term as a module name');
  88.  
  89. my $search_label = 
  90.   $top->Label(-text => 'Search term:')->pack(-side => 'left');
  91. my $search_box = 
  92.   $top->Entry(-width => 20)->pack(-side => 'left', -padx => 10);
  93. help_msg($search_box, 'Enter a (regular expression) search term');
  94.  
  95. $search_box->bind('<Return>', [\&search]);
  96.  
  97. my $search = $top->Button(-text => 'Search',
  98.               -command => [\&search],
  99.              )->pack(-side => 'left', -padx => 10);
  100. help_msg($search, 'Perform a repository search');
  101.  
  102. my $query = $top->Button(-text => 'Query',
  103.              -command => [\&query],
  104.             )->pack(-side => 'left', -padx => 10, -pady => 5);
  105. help_msg($query, 'Perform a query on installed packages');
  106.  
  107. my $clear = $top->Button(-text => 'Clear',
  108.              -command => sub{$search_box->delete(0, 'end');},
  109.              )->pack(-side => 'left', -padx => 10);
  110. help_msg($clear, 'Clear the Search box entry');
  111.  
  112. my $cb_case = $top->Checkbutton(-text => 'case insensitive',
  113.                 -variable => \$no_case,
  114.                 -onvalue => 1,
  115.                 -offvalue => 0,
  116.                    )
  117.   ->pack(-side => 'left', -padx => 5, -pady => 5);
  118. help_msg($cb_case, 'Perform case insensitive searches');
  119.  
  120. my $cb_partial = $top->Checkbutton(-text => 'partial matches',
  121.                                    -variable => \$partial,
  122.                                    -onvalue => 1,
  123.                                    -offvalue => 0,
  124.                                   )
  125.   ->pack(-side => 'left', -padx => 5, -pady => 5);
  126. help_msg($cb_partial, 'Perform partial searches');
  127.  
  128. my $lscrolly = $left->Scrollbar();
  129. my $local = 
  130.   $left->MListbox(-yscrollcommand => ['set' => $lscrolly],
  131.           -background => 'white', 
  132.           -foreground => 'blue',
  133.           -textwidth => 10,
  134.           -highlightthickness => 2,
  135.           -width => 0,
  136.           -selectmode => 'single',
  137.           -bd=>2,
  138.           -relief=>'sunken',
  139.           -columns=>[
  140.                  [qw/-text Package -textwidth 18/, %green,
  141.                   -comparecmd => sub {lc $_[0] cmp lc $_[1]}],
  142.                  [qw/-text Version -textwidth 6/, %orange, 
  143.                   -comparecmd => sub {$_[0] <=> $_[1]}],
  144.                 ]);
  145. $lscrolly->configure(-command => ['yview' => $local]);
  146. $lscrolly->pack(-side => 'left', -fill => 'y');
  147.  
  148. $local->pack(-side => 'left', -fill => 'both');
  149. $local->bindRows('<Button-3>', [\&display_info, 'local']);
  150. $local->bindRows('<Double-Button-1>', [\&upgrade]);
  151.  
  152. my $verify = $left->Button(-text => 'Verify',
  153.                -command => [\&verify],
  154.               )->pack(-side => 'top',
  155.                   -anchor => 'sw',
  156.                   -fill => 'x');
  157. help_msg($verify, 'Verify a locally installed package');
  158.  
  159. my $upgrade = $left->Button(-text => 'Upgrade',
  160.                 -command => [\&upgrade],
  161.                )->pack(-side => 'top', 
  162.                    -anchor => 'w', 
  163.                    -fill => 'x');
  164. help_msg($upgrade, 'Upgrade the selected local package');
  165.  
  166. my $remove = $left->Button(-text => 'Remove',
  167.                -command => [\&remove],
  168.               )->pack(-side => 'top', 
  169.                   -anchor => 'w', 
  170.                   -fill => 'x');
  171. help_msg($remove, 'Remove the selected local package');
  172.  
  173. my $clr_local = $left->Button(-text => 'Clear',
  174.                   -command => [\&clear, $local],
  175.                  )->pack(-side => 'top', 
  176.                      -anchor => 'w', 
  177.                      -fill => 'x');
  178. help_msg($clr_local, 'Clear the local listbox entries');
  179.  
  180. my $readme_local = $left->Button(-text => 'Readme',
  181.                                  -command => [\&get_readme, $local],
  182.                                 )->pack(-side => 'top', 
  183.                                         -anchor => 'w', 
  184.                                         -fill => 'x');
  185. help_msg($readme_local, 'Fetch the CPAN readme for the distribution');
  186.  
  187. set_reps();
  188. $middle->Label( -text => 'Repository: ')
  189.   ->pack(-side => 'top', -anchor => 'n');
  190.  
  191. my $replist = 
  192.   $middle->BrowseEntry(-variable => \$repository,
  193.                -choices => [@choices],
  194.               )
  195.   ->pack(-side => 'top', -anchor => 'n', -pady => 5);  
  196. help_msg($replist, 'Choose a repository to search');
  197.  
  198. my $help_msg =<<'END';
  199. Right click on a selection
  200. for further information, or
  201. double click a selection
  202. to upgrade/install.
  203. END
  204.  
  205. my $info_label = $middle->Label(-text => $help_msg, 
  206.                 -relief => 'groove',
  207.                    )->pack(-side => 'top', 
  208.                        -padx => 25, -pady => 15,
  209.                        -anchor => 'center');
  210.  
  211. my $rscrolly = $right->Scrollbar();
  212. my $rep = 
  213.   $right->MListbox(-yscrollcommand => ['set' => $rscrolly],
  214.            #           -background => 'white', 
  215.            -foreground => 'blue',
  216.            #           -textwidth => 10,
  217.            -highlightthickness => 2,
  218.            #           -width => 0,
  219.            -selectmode => 'single',
  220.            -bd=>2,
  221.            -relief=>'sunken',
  222.            -columns=>[
  223.                   [qw/-text Package -textwidth 18/, %green,
  224.                    -comparecmd => sub {lc $_[0] cmp lc $_[1]}],
  225.                   [qw/-text Version -textwidth 6/, %orange, 
  226.                    -comparecmd => sub {$_[0] <=> $_[1]}],
  227.                   [],
  228.                  ]);
  229. $rep->columnHide(2);
  230. $rscrolly->configure(-command => ['yview' => $rep]);
  231. $rscrolly->pack(-side => 'right', -fill => 'y');
  232.  
  233. $rep->pack(-side => 'left', -fill => 'x');
  234. $rep->pack(-side => 'right', -fill => 'y');
  235. $rep->bindRows('<Button-3>', [\&display_info]);
  236. $rep->bindRows('<Double-Button-1>', [\&ppminstall_bind]);
  237.  
  238. my $install = $right->Button(-text => 'Install',
  239.                  -command => [\&ppminstall_bind],
  240.                 )->pack(-side => 'top', 
  241.                     -anchor => 'n',
  242.                     -fill => 'x');
  243. help_msg($install, 'Install the selected package');
  244.  
  245. my $summary = $right->Button(-text => 'Summary',
  246.                  -command => [\&summary],
  247.                 )->pack(-side => 'top', 
  248.                     -anchor => 's',
  249.                     -fill => 'x');
  250. help_msg($summary, 'Get a summary of packages available from repositories');
  251.  
  252. my $rep_edit = $right->Button(-text => 'Repositories',
  253.                   -command => [\&rep],
  254.                  )->pack(-side => 'top', 
  255.                      -anchor => 'w', 
  256.                      -fill => 'x');
  257. help_msg($rep_edit, 'Add or remove a site from the repository list');
  258.  
  259. my $clr_rep = $right->Button(-text => 'Clear',
  260.                  -command => [\&clear, $rep],
  261.                 )->pack(-side => 'top', 
  262.                     -anchor => 'w', 
  263.                     -fill => 'x');
  264. help_msg($clr_rep, 'Clear the repository listbox entries');
  265.  
  266. my $readme_rep = $right->Button(-text => 'Readme',
  267.                                 -command => [\&get_readme, $rep],
  268.                                 )->pack(-side => 'top', 
  269.                                         -anchor => 'w', 
  270.                                         -fill => 'x');
  271. help_msg($readme_rep, 'Fetch the CPAN readme for the distribution');
  272.  
  273. my $stdout = $bottom->Scrolled('Text',
  274.                    -scrollbars => 'w',
  275.                    -height => 5,
  276.                   )->pack(-side => 'top', 
  277.                       -fill => 'x',
  278.                       -anchor => 's');
  279.  
  280. my $help = $bottom->Label(-textvariable => \$message,
  281.               -relief => 'groove',
  282.              )->pack(-side => 'top', -expand => 1,-fill => 'x');
  283. my $exit = $bottom->Button(-text => 'Exit',
  284.                -command => [$mw => 'destroy'],
  285.               )->pack(-side => 'top', -anchor => 'center');
  286. help_msg($exit, 'Quit Tk-PPM');
  287.  
  288. tie(*STDOUT, 'Tk::Text', $stdout);
  289.  
  290. $top->pack(-side => 'top');
  291. $options->pack(-side => 'top');
  292. $bottom->pack(-side => 'bottom', -fill => 'x');
  293. $left->pack(-side => 'left');
  294. $middle->pack(-side => 'left');
  295. $right->pack(-side => 'right');
  296.  
  297. MainLoop;
  298.  
  299. sub disable_partial {
  300.   $old_partial = $partial;
  301.   $partial = 0;
  302.   $cb_partial->configure(-state => 'disabled');
  303. }
  304. sub enable_partial {
  305.   $partial = $old_partial;
  306.   $cb_partial->configure(-state => 'normal');
  307. }
  308.  
  309. sub set_reps {
  310.   %reps = PPM::ListOfRepositories();
  311.   %alias = reverse %reps;
  312.   @choices = ('All available', keys %reps);
  313.   %indices = map {$choices[$_] => $_} (0 .. $#choices);
  314.   $repository ||= $choices[0];
  315. }
  316.  
  317. sub search_term {
  318.   my %args = @_;
  319.   my $RE = $args{search_term} || trim($search_box->get());
  320.   eval { $RE =~ /$RE/ };
  321.   if ($@) {
  322.     $error = qq{"$RE" is not a valid regular expression.};
  323.     return;
  324.   }
  325.   unless ($args{all}) {
  326.     unless ($RE =~ /\w{1}/) {
  327.       $error = q{The search query must contain at least one word character};
  328.       return;
  329.     }
  330.   }
  331.   if ($type eq 'Module' and not $args{all}) {
  332.     $RE =~ s!-!::!g;
  333.     $partial = 0;
  334.     msg_update(qq{Searching on CPAN for /$RE/ - please wait ...});
  335.     my $mods = mod_search($RE, 
  336.                           no_case => $no_case,
  337.                           partial => 0);
  338.     msg_update(qq{Done!});
  339.     unless ($mods) {
  340.       $error = qq{Could not find any modules matching "$RE"};
  341.       return;
  342.     }
  343.     my $file;
  344.     for (keys %$mods) {
  345.       $RE = $_;
  346.       last if $file = $mods->{$_}->{cpan_file};
  347.     }
  348.     unless ($file) {
  349.       $error = qq{Could not find the distribution containing $RE};
  350.       return;
  351.     }
  352.     $RE = $file;
  353.   }
  354.   elsif ($args{all} and not $RE) {
  355.     $RE = '.';
  356.   }
  357.   else {
  358.     $RE = "(?i)$RE" if ($no_case == 1);
  359.     $RE = "^$RE\$" unless ($partial == 1);
  360.     $RE =~ s!::!-!g if $type eq 'Package';
  361.   }
  362.   return $RE;
  363. }
  364.  
  365. sub search_tag {
  366.   return ($type eq 'AUTHOR' or $type eq 'ABSTRACT') ?
  367.     $type : undef;
  368. }
  369.  
  370. sub query {
  371.   my %args = @_;
  372.   if ($type eq 'Module') {
  373.     enable_partial();
  374.     $type = 'Package';
  375.   }
  376.   my $RE = search_term(all => 1, search_term => $args{search_term});
  377.   my $searchtag = search_tag();
  378.   unless ($RE) {
  379.     dialog_error('Invalid search term', q{Could not perform the search.});
  380.     return;
  381.   }
  382.   PPM::reread_config();
  383.   my %installed = InstalledPackageProperties();
  384.   foreach(keys %installed) {
  385.     if ($searchtag) {
  386.       delete $installed{$_} unless $installed{$_}{$searchtag} =~ /$RE/;
  387.     }
  388.     else {
  389.       delete $installed{$_} unless /$RE/;
  390.     }
  391.   }
  392.   if (%installed) {
  393.     $local->delete(0, 'end');
  394.     populate(\%installed, 'local');
  395.   }
  396.   else {
  397.     dialog_info('No matches',
  398.                 qq{No matches for "$RE" were found});
  399.   }
  400. }
  401.  
  402. sub search {
  403.   my $searchRE;
  404.   unless ($searchRE = search_term()) {
  405.     dialog_error('Invalid search term', q{Could not perform the search.});
  406.     return;
  407.   }
  408.   my ($packages, $file);
  409.   if ($type eq 'Module') {
  410.     $file = $searchRE;
  411.     $no_case = 1;
  412.     $type = 'Package';
  413.     enable_partial();
  414.     $searchRE = file_to_dist($searchRE);
  415.     $searchRE = "^$searchRE\$";
  416.   }
  417.   if ($packages = search_for($searchRE) ) {
  418.     $rep->delete(0, 'end');
  419.     populate($packages->{$_}, $_) foreach (keys %$packages);
  420.     return 1;
  421.   }
  422.   elsif ($file) {
  423.     return unless 
  424.       dialog_yes_no('Try on CPAN?',
  425.             qq{No ppm package for $searchRE available. Try on CPAN?});
  426.     my @args = ('ppm_install', $file);
  427.     unless (launch(\@args, 0) == 0) {
  428.       $error = undef;
  429.       dialog_error('ppm_install failed',
  430.            qq{ppm_install of $file failed.});
  431.       return;
  432.     }
  433.     dialog_info('Installation succeeded',
  434.         "Successfully installed $file");
  435.     return 1;
  436.   }
  437.   else {
  438.     dialog_error('No results', "No results for $searchRE were found");
  439.     return;
  440.   }
  441. }
  442.  
  443. sub confirm_install {
  444.   my $dist = shift;
  445.   my $confirm = $mw->DialogBox(-title => 'Confirm installation',
  446.                                -buttons => ['OK', 'Cancel']);
  447.   $confirm->Label( -text => "Install $dist?")
  448.     ->grid(-row => 0, -pady => 5, -padx => 5,
  449.            -column => 0, -sticky => 'w', -columnspan => 2);  
  450.   $confirm->Checkbutton(-text => 'Ignore failed tests',
  451.                         -variable => \$ppm_ignore,
  452.                         -onvalue => 1,
  453.                         -offvalue => 0,
  454.                        )
  455.     ->grid(-row => 1, -pady => 5, -padx => 5,
  456.            -column => 0, -sticky => 'w');  
  457.   $confirm->Checkbutton(-text => 'Remove intermediate files',
  458.                         -variable => \$ppm_remove,
  459.                         -onvalue => 1,
  460.                         -offvalue => 0,
  461.                        )
  462.     ->grid(-row => 1, -pady => 5, -padx => 5,
  463.            -column => 1, -sticky => 'w');  
  464.   my $ans = $confirm->Show;
  465.   return $ans eq 'OK' ? 1 : 0;
  466. }
  467.  
  468. sub search_for {
  469.   my ($searchRE, $location) = @_;
  470.   my $searchtag = search_tag();
  471.   msg_update(qq{Searching for /$searchRE/ of type "$type" - please wait ...});
  472.   my ($packages, @locations);
  473.   if ($location) {
  474.     @locations = ($location);
  475.   }
  476.   else {
  477.     @locations = ($repository eq 'All available') ?
  478.       values %reps : ($reps{$repository});
  479.   }
  480.   foreach my $loc (@locations) {
  481.     my %summary;
  482.     # see if the repository has server-side searching
  483.     if (defined $searchRE && 
  484.     (%summary = ServerSearch(location => $loc, 
  485.                  searchRE => $searchRE, 
  486.                  searchtag => $searchtag))) {
  487.       # XXX: clean this up
  488.       foreach my $package (keys %{$summary{$loc}}) {
  489.     $packages->{$loc}->{$package} = \%{$summary{$loc}{$package}};
  490.       }
  491.       next;
  492.     }
  493.     
  494.     # see if a summary file is available
  495.     %summary = RepositorySummary(location => $loc);
  496.     if (%summary) {
  497.       foreach my $package (keys %{$summary{$loc}}) {
  498.     next if (defined $searchtag && 
  499.          $summary{$loc}{$package}{$searchtag} !~ /$searchRE/);
  500.     next if (!defined $searchtag && 
  501.          defined $searchRE && $package !~ /$searchRE/);
  502.     $packages->{$loc}->{$package} = \%{$summary{$loc}{$package}};
  503.       }
  504.     }
  505.     else {
  506.       my %ppds = PPM::RepositoryPackages(location => $loc);
  507.       # No summary: oh my, nothing but 'Net
  508.       foreach my $package (@{$ppds{$loc}}) {
  509.     my %package_details = 
  510.       RepositoryPackageProperties(package => $package, 
  511.                       location => $loc);
  512.     next unless %package_details;
  513.     next if (defined $searchtag && 
  514.          $package_details{$searchtag} !~ /$searchRE/);
  515.     next if (!defined $searchtag && 
  516.          defined $searchRE && $package !~ /$searchRE/);
  517.     $packages->{$loc}->{$package} = \%package_details;
  518.       }
  519.     }
  520.   }
  521.   msg_update(qq{  Done!});
  522.   unless ($packages) {
  523.     $error = qq{No matches for "$searchRE" were found};
  524.     return;
  525.   }
  526.   return $packages;
  527. }
  528.  
  529. sub verify {
  530.   my ($index, $pack, $version, $loc) = get_selection($local) or do {
  531.     dialog_error('No selection made', 'Please make a selection first');
  532.     return;
  533.   };
  534.   my $resp = verify_pack($pack);
  535.   if ($resp eq 'OK') {
  536.     dialog_info('Up to date',
  537.            qq{"$pack" is up to date});
  538.   }
  539.   elsif ($resp eq 'UK') {
  540.     dialog_info('No upgrade found',
  541.         qq{No upgrade for "$pack" was found});
  542.   }
  543.   else {
  544.     dialog_info('Upgrade available',
  545.         qq{An upgrade to $resp for "$pack" from $alias{$upgrades->{$pack}->{location}} is available});
  546.   }
  547. }
  548.  
  549. sub upgrade {
  550.   my ($index, $pack, $version, $loc) = get_selection($local) or do {
  551.     dialog_error('No selection made', 'Please make a selection first');
  552.     return;
  553.   };
  554.   my $resp = verify_pack($pack);
  555.   if ($resp eq 'OK') {
  556.     dialog_info('Up to date',
  557.            qq{"$pack" is up to date});
  558.     return;
  559.   }
  560.   elsif ($resp eq 'UK') {
  561.     dialog_info('No upgrade found',
  562.         qq{No upgrade for "$pack" was found});
  563.     return;
  564.   }
  565.   else {
  566.     $loc = $upgrades->{$pack}->{location};
  567.     return unless 
  568.       dialog_yes_no('Upgrade available',
  569.             qq{Upgrade "$pack" to $resp from $alias{$loc}?});
  570.   }
  571.   msg_update(qq{Removing "$pack" - please wait ...});
  572.   unless (RemovePackage(package => $pack)) {
  573.     $error = $PPM::PPMERR;
  574.     dialog_error('Removal error', 
  575.          qq{Removal of "$pack" failed.});
  576.     return;
  577.   }
  578.   msg_update(qq{Done!});
  579.   msg_update(qq{Installing "$pack" - please wait ...});
  580.   unless (InstallPackage(package => $pack, location => $reps{$loc})) {
  581.     $error = $PPM::PPMERR;
  582.     dialog_error('Installation error', 
  583.          qq{Installation of "$pack" failed.});
  584.     return;
  585.   }
  586.   msg_update(qq{Done!});
  587.   $local->delete($index);
  588.   $local->insert($index, 
  589.          [$pack, ppd2cpan_version($upgrades->{$pack}->{version})]);
  590.   $info->{$pack}->{local}->{version} = $upgrades->{$pack}->{version};
  591.   dialog_info('Installation successful',
  592.           qq{Installation of "$pack" was successful});
  593. }
  594.  
  595. sub verify_pack {
  596.   my $pack = shift;
  597.   my $packages;
  598.   unless ($packages = search_for(qq{^$pack\$}) ) {
  599.     return 'UK';
  600.   }
  601.   my $version = $info->{$pack}->{local}->{version};
  602.   my @installed_version = split(',', $version);
  603.   my ($available, $remote_version, $location);
  604.   foreach (keys %$packages) {
  605.     $location = $_;
  606.     $remote_version = $packages->{$location}->{$pack}->{VERSION};
  607.     my @remote_version = split (',', $remote_version);
  608.     foreach(0..3) {
  609.       next if $installed_version[$_] == $remote_version[$_];
  610.       $available++ if $installed_version[$_] < $remote_version[$_];
  611.       last;
  612.     }
  613.     last if $available;
  614.   }
  615.   if ($available) {
  616.     $upgrades->{$pack} = {location => $location,
  617.               version => $remote_version};
  618.     return ppd2cpan_version($remote_version);
  619.   }
  620.   else {
  621.     return 'OK';
  622.   }
  623. }
  624.  
  625. sub get_selection {
  626.   my $widget = shift;
  627.   my @sel = $widget->curselection;
  628.   return unless (@sel == 1);
  629.   my $pack = ($widget->getRow($sel[0]))[0];
  630.   my $loc = ($widget->getRow($sel[0]))[2] ?
  631.     ($widget->getRow($sel[0]))[2] : undef;
  632.   return ($sel[0], $pack, ($widget->getRow($sel[0]))[1], $loc);
  633. }
  634.  
  635. sub remove {
  636.   my ($index, $package, $version, $loc) = get_selection($local) or do {
  637.     dialog_error('No selection made', 'Please make a selection first');
  638.     return;
  639.   };
  640.   return unless dialog_yes_no('Confirm delete',
  641.                   qq{Remove "$package?"});
  642.   msg_update(qq{Removing "$package" - please wait ...});
  643.   unless (RemovePackage(package => $package)) {
  644.     $error = $PPM::PPMERR;
  645.     dialog_error('Removal error', 
  646.          qq{Removal of "$package" failed.});
  647.     return;
  648.   }
  649.   msg_update(qq{Done!});
  650.   dialog_info('Removal suceessful',
  651.          qq{Removed "$package"});
  652.   $local->delete($index);
  653. }
  654.  
  655. sub ppminstall_bind {
  656.   my ($widget, $hash, %args) = @_;
  657.   my ($index, $package, $version, $alias) = get_selection($rep) or do {
  658.       dialog_error('No selection made', 'Please make a selection first');
  659.       return;
  660.     };
  661.   ppminstall($package, $reps{$alias}, $version);
  662. }
  663.  
  664.  
  665. sub ppminstall {
  666.   my ($package, $location, $version) = @_;
  667.   return unless ($package);
  668.   my %installed = InstalledPackageProperties();
  669.   if (my $pkg = (grep {/^$package$/i} keys %installed)[0]) {
  670.     my $version = ppd2cpan_version($installed{$pkg}{'VERSION'});
  671.     dialog_error('Already installed', 
  672.          qq{Version $version of '$pkg' is already installed.\n} .
  673.          qq{Either remove it or use the upgrade button.});
  674.     return;
  675.   }
  676.   return unless dialog_yes_no('Confirm install',
  677.                   qq{Install "$package?"});
  678.   msg_update(qq{Installing "$package" - please wait ....});
  679.   unless (InstallPackage(package => $package, location => $location)) {
  680.     $error = $PPM::PPMERR;
  681.     dialog_error('Installation error', 
  682.          qq{Installation of "$package" failed.});
  683.     return;
  684.   }
  685.   msg_update(qq{Done!});
  686.   dialog_info('Installation successful',
  687.           qq{Installed "$package".});
  688.   my $hashref = $info->{$package}->{$location};
  689.   foreach (keys %$hashref) {
  690.     next if ($_ eq 'location');
  691.     $info->{$package}->{local}->{$_} = $hashref->{$_};
  692.   }
  693.   my $index = 'end';
  694.   my $version = ppd2cpan_version($info->{$package}->{local}->{version});
  695.   if ($index = get_index($package, $local)) {
  696.     $local->delete($index);
  697.   }
  698.   $index ||= 'end';
  699.   $local->insert($index, [$package, $version]);
  700. }
  701.  
  702. sub get_readme {
  703.   my $widget = shift;
  704.   my ($index, $pack, $version, $loc) = get_selection($widget) or do {
  705.     dialog_error('No selection made', 'Please make a selection first');
  706.     return;
  707.   };
  708.   msg_update(qq{Fetching README - please wait ....});
  709.   my $text = fetch_readme($pack) or do {
  710.     dialog_error('No README available', qq{No README for '$pack' available});
  711.     return;
  712.   };
  713.   msg_update(qq{Done!});
  714. #  my $tl = $mw->Toplevel;
  715. #  $tl->title('README');
  716. #  my $scroll = $tl->Scrollbar();
  717. #  my $readme = $tl->Text(-yscrollcommand => ['set' => $scroll]);
  718. #  for (@$text) {
  719. #    s/=head\d//;
  720. #    $readme->insert('end', $_);
  721. #  }
  722. #  $scroll->configure(-command => ['yview' => $readme]);
  723. #  $scroll->pack(-side => 'left', -fill => 'y');
  724. #  $readme->pack(-side => 'top', -fill => 'y');
  725. #  $tl->Button(-text => 'Quit',
  726. #              -command => sub {$tl->destroy },
  727. #             )->pack(-side => 'top');
  728.   my $tmpfile = tempfile();
  729.   open(my $fh, ">$tmpfile") or do {
  730.     dialog_error('open failed',
  731.                  qq{Could not open $tmpfile: $!});
  732.     return;
  733.   };
  734.   for (@$text) {
  735.     s/=head\d//;
  736.     print $fh $_;
  737.   }
  738.   close $fh;
  739.   my $editor = $ENV{EDITOR} || 'notepad';
  740.   my @args = ($editor, $tmpfile);
  741.   unless (launch(\@args, 1) == 0) {
  742.     dialog_error('README failed',
  743.                  qq{Launch of $editor to view README failed.});
  744.   }
  745.   unlink($tmpfile);
  746. }
  747.  
  748. sub summary {
  749.   my %packages;
  750.   msg_update(qq{Obtaining summary from "$repository" - please wait ....});
  751.   my @locations = ($repository eq 'All available') ?
  752.       values %reps : ($reps{$repository});
  753.  
  754.   foreach my $loc (@locations) {
  755.     # see if the repository has server-side searching
  756.     # see if a summary file is available
  757.     my %summary = RepositorySummary(location => $loc);
  758.     if (%summary) {
  759.       foreach my $package (keys %{$summary{$loc}}) {
  760.     $packages{$loc}{$package} = \%{$summary{$loc}{$package}};
  761.       }
  762.     }
  763.     else {
  764.       my %ppds = PPM::RepositoryPackages(location => $loc);
  765.       # No summary: oh my, nothing but 'Net
  766.       foreach my $package (@{$ppds{$loc}}) {
  767.     my %package_details = 
  768.       RepositoryPackageProperties(package => $package, 
  769.                       location => $loc);
  770.     next unless %package_details;
  771.     $packages{$loc}{$package} = \%package_details;
  772.       }
  773.     }
  774.   }
  775.   msg_update(q{Done!});
  776.   unless (%packages) {
  777.     dialog_info(q{No summary available},
  778.         q{Cannot get summary information});
  779.     return;
  780.   }
  781.   foreach (keys %packages) {
  782.     populate(\%{$packages{$_}}, $_);
  783.   }
  784. }
  785.  
  786. sub rep {
  787.   my $reps = $mw->Toplevel;
  788.   $reps->title('Repositories');
  789.   my @choices = keys %reps;
  790.   my $rep = $choices[0];
  791.   my $add = $reps{$rep};
  792.   $reps->Label( -text => 'Repository: ')
  793.     ->grid(-row => 0, -pady => 5, -padx => 5,
  794.        -column => 0, -sticky => 'e');  
  795.   my $box = 
  796.     $reps->BrowseEntry(-variable => \$rep,
  797.                -choices => [@choices],
  798.                -browsecmd => sub{$add = $reps{$rep}},
  799.               )
  800.       ->grid(-row => 0, -column => 1, -columnspan => 3, 
  801.              -pady => 5, -padx => 5, -sticky => 'w', -ipadx => 5);
  802.   
  803.   $reps->Label( -text => 'URL: ')
  804.     ->grid(-row => 1, -column => 0, -sticky => 'e', -pady => 10);
  805.   $reps->Label( -textvariable => \$add, -relief => 'groove')
  806.     ->grid(-row => 1, -column => 1, -columnspan => 4, -pady => 10,
  807.            -sticky => 'w', -padx => 5);
  808.  
  809.   $reps->Checkbutton(-text => 'save changes',
  810.              -variable => \$save,
  811.              -onvalue => 1,
  812.              -offvalue => 0,
  813.             )
  814.     ->grid(-row => 2, -column => 0, 
  815.        -pady => 5,  -sticky => 'e');
  816.   
  817.   $reps->Button( -text => 'New',
  818.          -command => [\&new_rep, $reps],
  819.            )->grid(-row => 2, -pady => 10, 
  820.                -padx => 5, -column => 1, -sticky => 'w');
  821.   $reps->Button( -text => 'Delete',
  822.          -command => [\&del_rep, $reps, \$rep],
  823.            )->grid(-row => 2, -pady => 10, 
  824.                -padx => 5, -column => 2, -sticky => 'w');
  825.   $reps->Button( -text => 'Known',
  826.          -command => [\&add_rep, $reps],
  827.            )->grid(-row => 2, -pady => 10, 
  828.                -padx => 5, -column => 3, -sticky => 'w');
  829.   $reps->Button( -text => 'Close',
  830.          -command => [ $reps => 'destroy'],
  831.            )->grid(-row => 2, -pady => 10,
  832.                -padx => 5, -column => 4, -sticky => 'w');
  833. }
  834.  
  835. sub del_rep {
  836.   my ($tl, $rep) = @_;
  837.   return unless dialog_yes_no('Confirm delete',
  838.                   qq{Delete "$$rep" from the repository list?});
  839.   RemoveRepository(repository => $$rep, save => $save);
  840.   $tl->destroy;
  841.   $replist->delete($indices{$$rep});
  842.   set_reps();
  843.   rep();
  844. }
  845.  
  846. sub new_rep {
  847.   my $tl = shift;
  848.   my ($rep, $loc);
  849.   my $add = $mw->DialogBox(-title => 'Add a repository',
  850.                -buttons => ['OK', 'Cancel']);
  851.   $add->add('LabEntry', -textvariable => \$rep, 
  852.         -label => 'Name: ', -width => 20, 
  853.         -labelPack => [-side => 'left'])
  854.     ->grid(-row => 0, -column => 0, -pady => 10,
  855.        -sticky => 'w');
  856.   $add->add('LabEntry', -textvariable => \$loc, 
  857.         -width => 40, -label => 'URL:   ', 
  858.         -labelPack => [-side => 'left'])
  859.     ->grid(-row => 1, -column => 0, -pady => 10,
  860.        -sticky => 'w');
  861.   my $ans = $add->Show;
  862.   return unless ($ans eq 'OK');
  863.   $rep = trim($rep);
  864.   $loc = trim($loc);
  865.   unless ($rep and $loc) {
  866.     dialog_error('Incomplete specification',
  867.         q{Please specify both a name and the URL for the repository});
  868.     return;
  869.   }
  870.   AddRepository(repository => $rep, location => $loc, save => $save);
  871.   $tl->destroy;
  872.   $replist->insert('end', $rep);
  873.   set_reps();
  874.   rep();
  875. }
  876.  
  877. sub add_rep {
  878.   my $tl = shift;
  879.   my $add = $mw->DialogBox(-title => 'Select a repository',
  880.                            -buttons => ['OK', 'Cancel']);
  881.   my @choices;
  882.   my @others = values %reps;
  883.   (my $pv = $]) =~ s!(5.)00(\d).*!$1$2!;
  884.   foreach my $entry (sort keys %Repositories) {
  885.     next unless grep {$_ eq $^O}
  886.       @{ $Repositories{$entry}->{PerlO}};
  887.     next unless grep {$_ eq $pv}
  888.       @{ $Repositories{$entry}->{PerlV}};
  889.     next if grep {$_ eq $Repositories{$entry}->{location} } @others;
  890.     push @choices, $entry;
  891.   }
  892.   my $rep = $choices[0];
  893.   my $loc = $Repositories{$rep}->{location};
  894.   my $note = $Repositories{$rep}->{Notes};
  895.   $add->Label( -text => 'Repository: ')
  896.     ->grid(-row => 0, -pady => 5, -padx => 5,
  897.            -column => 0, -sticky => 'e');  
  898.   my $box = 
  899.     $add->BrowseEntry(-variable => \$rep,
  900.                       -choices => [@choices],
  901.                       -browsecmd => 
  902.                       sub{$loc = $Repositories{$rep}->{location};
  903.                           $note = $Repositories{$rep}->{Notes}},
  904.                      )
  905.       ->grid(-row => 0, -column => 1, -columnspan => 3, 
  906.              -pady => 5, -padx => 5, -sticky => 'w', -ipadx => 5);
  907.   
  908.   $add->Label( -text => 'URL: ')
  909.     ->grid(-row => 1, -column => 0, -sticky => 'e', -pady => 10);
  910.   $add->Label( -textvariable => \$loc, -relief => 'groove')
  911.     ->grid(-row => 1, -column => 1, -columnspan => 4, -pady => 10,
  912.            -sticky => 'w', -padx => 5);
  913.   $add->Label( -text => 'Note: ')
  914.     ->grid(-row => 2, -column => 0, -sticky => 'e', -pady => 10);
  915.   $add->Label( -textvariable => \$note, -relief => 'groove')
  916.     ->grid(-row => 2, -column => 1, -columnspan => 4, -pady => 10,
  917.            -sticky => 'w', -padx => 5);
  918.   
  919.   my $ans = $add->Show;
  920.   return unless ($ans eq 'OK');
  921.   $rep = trim($rep);
  922.   $loc = trim($loc);
  923.   AddRepository(repository => $rep, location => $loc, save => $save);
  924.   $tl->destroy;
  925.   $replist->insert('end', $rep);
  926.   set_reps();
  927.   rep();
  928. }
  929.  
  930. sub populate {
  931.   my ($data, $where) = @_;
  932.   foreach my $package (sort keys %{$data}) {
  933.     my $author = $data->{$package}->{AUTHOR};
  934.     my $version = ppd2cpan_version($data->{$package}->{VERSION});
  935.     if ($author and $author =~ /Unknown/i) {
  936.       $author = 'Unknown';
  937.     }
  938.     $info->{$package}->{$where}
  939.       = {author => $author,
  940.      abstract => $data->{$package}->{ABSTRACT},
  941.      version => $data->{$package}->{VERSION},
  942.     };
  943.     if ($where eq 'local') {
  944.       $local->bell;
  945.       $local->insert('end', [$package, $version]);
  946.     }
  947.     else {
  948.       $rep->bell;
  949.       $rep->insert('end', [$package, $version, $alias{$where}]);
  950.     }
  951.   }
  952. }
  953.  
  954. sub launch {
  955.   my ($cmd, $no_console) = @_;
  956.   if (ref($cmd) eq 'ARRAY') {
  957.     $cmd = join ' ', @{$cmd};    
  958.   }
  959.   my $cflags = $no_console ? NORMAL_PRIORITY_CLASS :
  960.     NORMAL_PRIORITY_CLASS  | CREATE_NEW_CONSOLE;
  961.   my $ProcessObj;
  962.   $mw->withdraw;
  963.   Win32::Process::Create($ProcessObj,
  964.                          "$shell",
  965.                          "$shell /c $cmd",
  966.                          0,
  967.                          $cflags,
  968.                          ".")
  969.       or do {
  970.         $error = Win32::FormatMessage(Win32::GetLastError());
  971.         $mw->deiconify;
  972.         $mw->raise;
  973.         return;
  974.       };
  975.   $ProcessObj->Wait(INFINITE);
  976.   my $exitcode;
  977.   $ProcessObj->GetExitCode($exitcode);
  978.   $mw->deiconify;
  979.   $mw->raise;
  980.   return $exitcode;
  981. }
  982.  
  983. sub get_index {
  984.   my ($match, $widget) = @_;
  985.   my @list = $widget->get(0, 'end');
  986.   my $i = 0;
  987.   foreach (@list) {
  988.     return $i if ($_->[0] eq $match);
  989.     $i++;
  990.   }
  991.   return;
  992. }
  993.  
  994. sub clear {
  995.   my $widget = shift;
  996.   $widget->delete(0, 'end');
  997. }
  998.  
  999. sub display_info {
  1000.   my ($widget, $hash, $where) = @_;
  1001.   my ($package, $index, $version, $loc);
  1002.   if ($where and $where eq 'local') {
  1003.     ($index, $package, $version) = get_selection($widget);
  1004.   }
  1005.   else {
  1006.     ($index, $package, $version, $where) = get_selection($widget);
  1007.   }
  1008.   unless ($package) {
  1009.     dialog_error('Selection error', 'Please make a selection first');
  1010.     return;
  1011.   }
  1012.   my $loc = ($where eq 'local' ? 'local' : $reps{$where});
  1013.   my $vers = ppd2cpan_version($info->{$package}->{$loc}->{version});
  1014.   my $msg = <<"END";
  1015.  Package "$package":
  1016.    Version: $vers        
  1017.    Author: $info->{$package}->{$loc}->{author}             
  1018.    Abstract: $info->{$package}->{$loc}->{abstract}              
  1019. END
  1020.   if ($where ne 'local') {
  1021.     $msg .= qq[   Location: $where                      \n];
  1022.   }
  1023.   dialog_info(qq{Information for "$package"}, $msg);
  1024. }
  1025.  
  1026. sub help_msg {
  1027.   my ($widget, $msg) = @_;
  1028.   $widget->bind('<Enter>', [sub {$message = $_[1]; }, $msg]);
  1029.   $widget->bind('<Leave>', [sub {$message = ''; }]);
  1030. }
  1031.  
  1032. sub msg_update {
  1033.   $message = shift;
  1034.   $mw->update;
  1035. }
  1036.  
  1037. sub dialog_error {
  1038.   my ($title, $msg) = @_;
  1039.   $msg .= "\n\n$error" if $error;
  1040.   my $ans = $mw->messageBox(-title => $title, -message => $msg,
  1041.                 -icon => 'error', -type => 'OK');
  1042.   undef $error;
  1043. }
  1044.  
  1045. sub dialog_info {
  1046.   my ($title, $msg) = @_;
  1047.   my $ans = $mw->messageBox(-title => $title, -message => $msg,
  1048.                 -icon => 'info', -type => 'OK');
  1049.   undef $error;
  1050. }
  1051.  
  1052. sub dialog_yes_no {
  1053.   my ($title, $msg) = @_;
  1054.   my $ans = $mw->messageBox(-title => $title, -message => $msg,
  1055.                 -icon => 'warning', -type => 'YesNo');
  1056.   return ($ans =~ /^yes$/i) ? 1 : 0;
  1057. }
  1058.  
  1059.  
  1060. __END__
  1061.  
  1062. =head1 NAME
  1063.  
  1064. tk-ppm - Tk interface to the ppm utility
  1065.  
  1066. =head1 SYNOPSIS
  1067.  
  1068.    C:\> perl tk-ppm
  1069.  
  1070. or, first making a C<bat> file,
  1071.  
  1072.    C:\> pl2bat tk-ppm
  1073.    C:\> tk-ppm
  1074.  
  1075. =head1 README
  1076.  
  1077. This script provides a Tk graphical interface to the ppm
  1078. utility, used particularly with Win32 ActivePerl to install
  1079. and manage binary packages.
  1080.  
  1081. =head1 DESCRIPTION
  1082.  
  1083. When invoked, C<tk-ppm> will bring up a main window through
  1084. which one can do many of the operations of the command-line based
  1085. C<ppm> utility:
  1086.  
  1087. =over 3
  1088.  
  1089. =item *
  1090.  
  1091. query for information on locally installed packages.
  1092.  
  1093. =item *
  1094.  
  1095. check if upgrades are available for locally installed
  1096. packages, and do an upgrade (one may have to remove packages
  1097. first before doing an upgrade).
  1098.  
  1099. =item *
  1100.  
  1101. search, by package name, author, abstract, or module name,
  1102. for packages on remote repositories (this requires the CPAN.pm
  1103. module to be available and configured). If no ppm package is found,
  1104. an offer will be made to search CPAN for the package and, if found,
  1105. use PPM::Make to install it.
  1106.  
  1107. =item *
  1108.  
  1109. install packages from remote repositories.
  1110.  
  1111. =item *
  1112.  
  1113. add or delete entries from the list of repositories. This
  1114. uses the PPM::Repostories module to suggest a list of
  1115. available repositories you may wish to include.
  1116.  
  1117. =back
  1118.  
  1119. Right-clicking on a package item within a listbox will bring
  1120. up a short description of that item, which double-clicking it
  1121. will either verify it (for a local package) or install it
  1122. (for a remote package). Short descriptions of actions are provided 
  1123. within the window when the mouse hovers over the different 
  1124. buttons and areas - a more thorough description is available within 
  1125. the C<ppm> utility.
  1126.  
  1127. At present, searching by module name is done by an exact
  1128. match. If no ppm package is found corresponding to the module
  1129. name, an offer will be made to attempt to install it
  1130. from the CPAN sources.
  1131.  
  1132. =head1 PREREQUISITES
  1133.  
  1134. This script requires C<Tk>, C<PPM>, C<Tk::MListbox>, 
  1135. C<PPM::Repositories>, and C<CPAN>.
  1136. The C<CPAN> module must be first configured.
  1137.  
  1138. =head1 OSNAMES
  1139.  
  1140. any
  1141.  
  1142. =head1 SEE ALSO
  1143.  
  1144. L<PPM>, L<PPM::Make::Install>, and L<CPAN>.
  1145.  
  1146. =head1 COPYRIGHT
  1147.  
  1148. This script is copyright (c) 2003 by Randy Kobes
  1149. (E<lt>randy@theory.uwinnipeg.caE<gt>). All rights reserved.
  1150. You may use and distribute this code under the same terms
  1151. as Perl itself.
  1152.  
  1153. =head1 SCRIPT CATEGORIES
  1154.  
  1155. Win32
  1156.  
  1157. =cut
  1158.  
  1159. =cut
  1160.