#!perl
use strict;
#use warnings;
use Tk;
use PPM;
use Tk::MListbox;
require Tk::DialogBox;
require Tk::BrowseEntry;
require Tk::LabEntry;
use PPM::Make::Util qw(:all);
use PPM::Repositories;
use CPAN;
use Win32::Process;

my $d = parse_ppm();
my $ppmv = ppd2cpan_version($d->{PPMVER});

our ($type, $message, $no_case, $save, $repository, $VERSION,
    $ppm_ignore, $ppm_remove, $partial, $old_partial);
$type = 'Package';
$no_case = 1;
$old_partial = 1;
$partial = 1;
$save = 1;
$ppm_remove = 0;
$ppm_ignore = 0;
$main::VERSION = $PPM::Make::VERSION;
my $shell = $ENV{ComSpec};
my $ext = qr{\.(tar\.gz|tgz|tar\.Z|zip)};

my (%reps, %alias, @choices, %indices);
## Create main perl/tk window.
my $mw = MainWindow->new;
$mw->title("Interface to PPM $ppmv");

my ($info, $error, $upgrades);

## Create the MListbox widget. 
## Specify alternative comparison routine for integers and date.
## frame, but since the "Show All" button references $ml, we have to create
## it now. 

my %tan = qw(-bg tan -fg black);
my %orange = qw(-bg orange -fg black);
my %green = qw(-bg green -fg black);
my %cyan = qw(-bg cyan -fg black);
my %yellow = qw(-bg yellow -fg black);

CPAN::Config->load unless $CPAN::Config_loaded++;
my $top = $mw->Frame(-label => "Interface to PPM $ppmv");
my $options = $mw->Frame();
my $left = $mw->Frame(-label => 'Local');
my $middle = $mw->Frame();
my $right = $mw->Frame(-label => 'Repository');
my $bottom = $mw->Frame();

my $cb_label = 
  $options->Label(-text => 'Treat query as a',
		 )->pack(-side => 'left', -padx => 4);

my $package = $options->Radiobutton(-text => 'Package',
				   -variable => \$type,
				   -value => 'Package',
                                   -command => \&enable_partial,
				  )->pack(-side => 'left');
help_msg($package, 'Treat search term as a package name');

my $abstract = $options->Radiobutton(-text => 'Abstract',
				     -variable => \$type,
				     -value => 'ABSTRACT',
                                     -command => \&enable_partial,
				    )->pack(-side => 'left');
help_msg($abstract, 'Treat search term as part of the abstract');

my $author = $options->Radiobutton(-text => 'Author',
				   -variable => \$type,
				   -value => 'AUTHOR',
                                   -command => \&enable_partial,
				  )->pack(-side => 'left');
help_msg($author, 'Treat search term as an author name');

my $module = $options->Radiobutton(-text => 'Module',
				   -variable => \$type,
				   -value => 'Module',
                                   -command => \&disable_partial,
				  )->pack(-side => 'left');
help_msg($module, 'Treat search term as a module name');

my $search_label = 
  $top->Label(-text => 'Search term:')->pack(-side => 'left');
my $search_box = 
  $top->Entry(-width => 20)->pack(-side => 'left', -padx => 10);
help_msg($search_box, 'Enter a (regular expression) search term');

$search_box->bind('<Return>', [\&search]);

my $search = $top->Button(-text => 'Search',
			  -command => [\&search],
			 )->pack(-side => 'left', -padx => 10);
help_msg($search, 'Perform a repository search');

my $query = $top->Button(-text => 'Query',
			 -command => [\&query],
			)->pack(-side => 'left', -padx => 10, -pady => 5);
help_msg($query, 'Perform a query on installed packages');

my $clear = $top->Button(-text => 'Clear',
			 -command => sub{$search_box->delete(0, 'end');},
			 )->pack(-side => 'left', -padx => 10);
help_msg($clear, 'Clear the Search box entry');

my $cb_case = $top->Checkbutton(-text => 'case insensitive',
				-variable => \$no_case,
				-onvalue => 1,
				-offvalue => 0,
			       )
  ->pack(-side => 'left', -padx => 5, -pady => 5);
help_msg($cb_case, 'Perform case insensitive searches');

my $cb_partial = $top->Checkbutton(-text => 'partial matches',
                                   -variable => \$partial,
                                   -onvalue => 1,
                                   -offvalue => 0,
                                  )
  ->pack(-side => 'left', -padx => 5, -pady => 5);
help_msg($cb_partial, 'Perform partial searches');

my $lscrolly = $left->Scrollbar();
my $local = 
  $left->MListbox(-yscrollcommand => ['set' => $lscrolly],
		  -background => 'white', 
		  -foreground => 'blue',
		  -textwidth => 10,
		  -highlightthickness => 2,
		  -width => 0,
		  -selectmode => 'single',
		  -bd=>2,
		  -relief=>'sunken',
		  -columns=>[
			     [qw/-text Package -textwidth 18/, %green,
			      -comparecmd => sub {lc $_[0] cmp lc $_[1]}],
			     [qw/-text Version -textwidth 6/, %orange, 
			      -comparecmd => sub {$_[0] <=> $_[1]}],
			    ]);
$lscrolly->configure(-command => ['yview' => $local]);
$lscrolly->pack(-side => 'left', -fill => 'y');

$local->pack(-side => 'left', -fill => 'both');
$local->bindRows('<Button-3>', [\&display_info, 'local']);
$local->bindRows('<Double-Button-1>', [\&upgrade]);

my $verify = $left->Button(-text => 'Verify',
			   -command => [\&verify],
			  )->pack(-side => 'top',
				  -anchor => 'sw',
				  -fill => 'x');
help_msg($verify, 'Verify a locally installed package');

my $upgrade = $left->Button(-text => 'Upgrade',
			    -command => [\&upgrade],
			   )->pack(-side => 'top', 
				   -anchor => 'w', 
				   -fill => 'x');
help_msg($upgrade, 'Upgrade the selected local package');

my $remove = $left->Button(-text => 'Remove',
			   -command => [\&remove],
			  )->pack(-side => 'top', 
				  -anchor => 'w', 
				  -fill => 'x');
help_msg($remove, 'Remove the selected local package');

my $clr_local = $left->Button(-text => 'Clear',
			      -command => [\&clear, $local],
			     )->pack(-side => 'top', 
				     -anchor => 'w', 
				     -fill => 'x');
help_msg($clr_local, 'Clear the local listbox entries');

my $readme_local = $left->Button(-text => 'Readme',
                                 -command => [\&get_readme, $local],
                                )->pack(-side => 'top', 
                                        -anchor => 'w', 
                                        -fill => 'x');
help_msg($readme_local, 'Fetch the CPAN readme for the distribution');

set_reps();
$middle->Label( -text => 'Repository: ')
  ->pack(-side => 'top', -anchor => 'n');

my $replist = 
  $middle->BrowseEntry(-variable => \$repository,
		       -choices => [@choices],
		      )
  ->pack(-side => 'top', -anchor => 'n', -pady => 5);  
help_msg($replist, 'Choose a repository to search');

my $help_msg =<<'END';
Right click on a selection
for further information, or
double click a selection
to upgrade/install.
END

my $info_label = $middle->Label(-text => $help_msg, 
				-relief => 'groove',
			       )->pack(-side => 'top', 
				       -padx => 25, -pady => 15,
				       -anchor => 'center');

my $rscrolly = $right->Scrollbar();
my $rep = 
  $right->MListbox(-yscrollcommand => ['set' => $rscrolly],
		   #		   -background => 'white', 
		   -foreground => 'blue',
		   #		   -textwidth => 10,
		   -highlightthickness => 2,
		   #		   -width => 0,
		   -selectmode => 'single',
		   -bd=>2,
		   -relief=>'sunken',
		   -columns=>[
			      [qw/-text Package -textwidth 18/, %green,
			       -comparecmd => sub {lc $_[0] cmp lc $_[1]}],
			      [qw/-text Version -textwidth 6/, %orange, 
			       -comparecmd => sub {$_[0] <=> $_[1]}],
			      [],
			     ]);
$rep->columnHide(2);
$rscrolly->configure(-command => ['yview' => $rep]);
$rscrolly->pack(-side => 'right', -fill => 'y');

$rep->pack(-side => 'left', -fill => 'x');
$rep->pack(-side => 'right', -fill => 'y');
$rep->bindRows('<Button-3>', [\&display_info]);
$rep->bindRows('<Double-Button-1>', [\&ppminstall_bind]);

my $install = $right->Button(-text => 'Install',
			     -command => [\&ppminstall_bind],
			    )->pack(-side => 'top', 
				    -anchor => 'n',
				    -fill => 'x');
help_msg($install, 'Install the selected package');

my $summary = $right->Button(-text => 'Summary',
			     -command => [\&summary],
			    )->pack(-side => 'top', 
				    -anchor => 's',
				    -fill => 'x');
help_msg($summary, 'Get a summary of packages available from repositories');

my $rep_edit = $right->Button(-text => 'Repositories',
			      -command => [\&rep],
			     )->pack(-side => 'top', 
				     -anchor => 'w', 
				     -fill => 'x');
help_msg($rep_edit, 'Add or remove a site from the repository list');

my $clr_rep = $right->Button(-text => 'Clear',
			     -command => [\&clear, $rep],
			    )->pack(-side => 'top', 
				    -anchor => 'w', 
				    -fill => 'x');
help_msg($clr_rep, 'Clear the repository listbox entries');

my $readme_rep = $right->Button(-text => 'Readme',
                                -command => [\&get_readme, $rep],
                                )->pack(-side => 'top', 
                                        -anchor => 'w', 
                                        -fill => 'x');
help_msg($readme_rep, 'Fetch the CPAN readme for the distribution');

my $stdout = $bottom->Scrolled('Text',
			       -scrollbars => 'w',
			       -height => 5,
			      )->pack(-side => 'top', 
				      -fill => 'x',
				      -anchor => 's');

my $help = $bottom->Label(-textvariable => \$message,
			  -relief => 'groove',
			 )->pack(-side => 'top', -expand => 1,-fill => 'x');
my $exit = $bottom->Button(-text => 'Exit',
			   -command => [$mw => 'destroy'],
			  )->pack(-side => 'top', -anchor => 'center');
help_msg($exit, 'Quit Tk-PPM');

tie(*STDOUT, 'Tk::Text', $stdout);

$top->pack(-side => 'top');
$options->pack(-side => 'top');
$bottom->pack(-side => 'bottom', -fill => 'x');
$left->pack(-side => 'left');
$middle->pack(-side => 'left');
$right->pack(-side => 'right');

MainLoop;

sub disable_partial {
  $old_partial = $partial;
  $partial = 0;
  $cb_partial->configure(-state => 'disabled');
}
sub enable_partial {
  $partial = $old_partial;
  $cb_partial->configure(-state => 'normal');
}

sub set_reps {
  %reps = PPM::ListOfRepositories();
  %alias = reverse %reps;
  @choices = ('All available', keys %reps);
  %indices = map {$choices[$_] => $_} (0 .. $#choices);
  $repository ||= $choices[0];
}

sub search_term {
  my %args = @_;
  my $RE = $args{search_term} || trim($search_box->get());
  eval { $RE =~ /$RE/ };
  if ($@) {
    $error = qq{"$RE" is not a valid regular expression.};
    return;
  }
  unless ($args{all}) {
    unless ($RE =~ /\w{1}/) {
      $error = q{The search query must contain at least one word character};
      return;
    }
  }
  if ($type eq 'Module' and not $args{all}) {
    $RE =~ s!-!::!g;
    $partial = 0;
    msg_update(qq{Searching on CPAN for /$RE/ - please wait ...});
    my $mods = mod_search($RE, 
                          no_case => $no_case,
                          partial => 0);
    msg_update(qq{Done!});
    unless ($mods) {
      $error = qq{Could not find any modules matching "$RE"};
      return;
    }
    my $file;
    for (keys %$mods) {
      $RE = $_;
      last if $file = $mods->{$_}->{cpan_file};
    }
    unless ($file) {
      $error = qq{Could not find the distribution containing $RE};
      return;
    }
    $RE = $file;
  }
  elsif ($args{all} and not $RE) {
    $RE = '.';
  }
  else {
    $RE = "(?i)$RE" if ($no_case == 1);
    $RE = "^$RE\$" unless ($partial == 1);
    $RE =~ s!::!-!g if $type eq 'Package';
  }
  return $RE;
}

sub search_tag {
  return ($type eq 'AUTHOR' or $type eq 'ABSTRACT') ?
    $type : undef;
}

sub query {
  my %args = @_;
  if ($type eq 'Module') {
    enable_partial();
    $type = 'Package';
  }
  my $RE = search_term(all => 1, search_term => $args{search_term});
  my $searchtag = search_tag();
  unless ($RE) {
    dialog_error('Invalid search term', q{Could not perform the search.});
    return;
  }
  PPM::reread_config();
  my %installed = InstalledPackageProperties();
  foreach(keys %installed) {
    if ($searchtag) {
      delete $installed{$_} unless $installed{$_}{$searchtag} =~ /$RE/;
    }
    else {
      delete $installed{$_} unless /$RE/;
    }
  }
  if (%installed) {
    $local->delete(0, 'end');
    populate(\%installed, 'local');
  }
  else {
    dialog_info('No matches',
                qq{No matches for "$RE" were found});
  }
}

sub search {
  my $searchRE;
  unless ($searchRE = search_term()) {
    dialog_error('Invalid search term', q{Could not perform the search.});
    return;
  }
  my ($packages, $file);
  if ($type eq 'Module') {
    $file = $searchRE;
    $no_case = 1;
    $type = 'Package';
    enable_partial();
    $searchRE = file_to_dist($searchRE);
    $searchRE = "^$searchRE\$";
  }
  if ($packages = search_for($searchRE) ) {
    $rep->delete(0, 'end');
    populate($packages->{$_}, $_) foreach (keys %$packages);
    return 1;
  }
  elsif ($file) {
    return unless 
      dialog_yes_no('Try on CPAN?',
		    qq{No ppm package for $searchRE available. Try on CPAN?});
    my @args = ('ppm_install', $file);
    unless (launch(\@args, 0) == 0) {
      $error = undef;
      dialog_error('ppm_install failed',
		   qq{ppm_install of $file failed.});
      return;
    }
    dialog_info('Installation succeeded',
		"Successfully installed $file");
    return 1;
  }
  else {
    dialog_error('No results', "No results for $searchRE were found");
    return;
  }
}

sub confirm_install {
  my $dist = shift;
  my $confirm = $mw->DialogBox(-title => 'Confirm installation',
                               -buttons => ['OK', 'Cancel']);
  $confirm->Label( -text => "Install $dist?")
    ->grid(-row => 0, -pady => 5, -padx => 5,
           -column => 0, -sticky => 'w', -columnspan => 2);  
  $confirm->Checkbutton(-text => 'Ignore failed tests',
                        -variable => \$ppm_ignore,
                        -onvalue => 1,
                        -offvalue => 0,
                       )
    ->grid(-row => 1, -pady => 5, -padx => 5,
           -column => 0, -sticky => 'w');  
  $confirm->Checkbutton(-text => 'Remove intermediate files',
                        -variable => \$ppm_remove,
                        -onvalue => 1,
                        -offvalue => 0,
                       )
    ->grid(-row => 1, -pady => 5, -padx => 5,
           -column => 1, -sticky => 'w');  
  my $ans = $confirm->Show;
  return $ans eq 'OK' ? 1 : 0;
}

sub search_for {
  my ($searchRE, $location) = @_;
  my $searchtag = search_tag();
  msg_update(qq{Searching for /$searchRE/ of type "$type" - please wait ...});
  my ($packages, @locations);
  if ($location) {
    @locations = ($location);
  }
  else {
    @locations = ($repository eq 'All available') ?
      values %reps : ($reps{$repository});
  }
  foreach my $loc (@locations) {
    my %summary;
    # see if the repository has server-side searching
    if (defined $searchRE && 
	(%summary = ServerSearch(location => $loc, 
				 searchRE => $searchRE, 
				 searchtag => $searchtag))) {
      # XXX: clean this up
      foreach my $package (keys %{$summary{$loc}}) {
	$packages->{$loc}->{$package} = \%{$summary{$loc}{$package}};
      }
      next;
    }
    
    # see if a summary file is available
    %summary = RepositorySummary(location => $loc);
    if (%summary) {
      foreach my $package (keys %{$summary{$loc}}) {
	next if (defined $searchtag && 
		 $summary{$loc}{$package}{$searchtag} !~ /$searchRE/);
	next if (!defined $searchtag && 
		 defined $searchRE && $package !~ /$searchRE/);
	$packages->{$loc}->{$package} = \%{$summary{$loc}{$package}};
      }
    }
    else {
      my %ppds = PPM::RepositoryPackages(location => $loc);
      # No summary: oh my, nothing but 'Net
      foreach my $package (@{$ppds{$loc}}) {
	my %package_details = 
	  RepositoryPackageProperties(package => $package, 
				      location => $loc);
	next unless %package_details;
	next if (defined $searchtag && 
		 $package_details{$searchtag} !~ /$searchRE/);
	next if (!defined $searchtag && 
		 defined $searchRE && $package !~ /$searchRE/);
	$packages->{$loc}->{$package} = \%package_details;
      }
    }
  }
  msg_update(qq{  Done!});
  unless ($packages) {
    $error = qq{No matches for "$searchRE" were found};
    return;
  }
  return $packages;
}

sub verify {
  my ($index, $pack, $version, $loc) = get_selection($local) or do {
    dialog_error('No selection made', 'Please make a selection first');
    return;
  };
  my $resp = verify_pack($pack);
  if ($resp eq 'OK') {
    dialog_info('Up to date',
	       qq{"$pack" is up to date});
  }
  elsif ($resp eq 'UK') {
    dialog_info('No upgrade found',
		qq{No upgrade for "$pack" was found});
  }
  else {
    dialog_info('Upgrade available',
		qq{An upgrade to $resp for "$pack" from $alias{$upgrades->{$pack}->{location}} is available});
  }
}

sub upgrade {
  my ($index, $pack, $version, $loc) = get_selection($local) or do {
    dialog_error('No selection made', 'Please make a selection first');
    return;
  };
  my $resp = verify_pack($pack);
  if ($resp eq 'OK') {
    dialog_info('Up to date',
	       qq{"$pack" is up to date});
    return;
  }
  elsif ($resp eq 'UK') {
    dialog_info('No upgrade found',
		qq{No upgrade for "$pack" was found});
    return;
  }
  else {
    $loc = $upgrades->{$pack}->{location};
    return unless 
      dialog_yes_no('Upgrade available',
		    qq{Upgrade "$pack" to $resp from $alias{$loc}?});
  }
  msg_update(qq{Removing "$pack" - please wait ...});
  unless (RemovePackage(package => $pack)) {
    $error = $PPM::PPMERR;
    dialog_error('Removal error', 
		 qq{Removal of "$pack" failed.});
    return;
  }
  msg_update(qq{Done!});
  msg_update(qq{Installing "$pack" - please wait ...});
  unless (InstallPackage(package => $pack, location => $reps{$loc})) {
    $error = $PPM::PPMERR;
    dialog_error('Installation error', 
		 qq{Installation of "$pack" failed.});
    return;
  }
  msg_update(qq{Done!});
  $local->delete($index);
  $local->insert($index, 
		 [$pack, ppd2cpan_version($upgrades->{$pack}->{version})]);
  $info->{$pack}->{local}->{version} = $upgrades->{$pack}->{version};
  dialog_info('Installation successful',
	      qq{Installation of "$pack" was successful});
}

sub verify_pack {
  my $pack = shift;
  my $packages;
  unless ($packages = search_for(qq{^$pack\$}) ) {
    return 'UK';
  }
  my $version = $info->{$pack}->{local}->{version};
  my @installed_version = split(',', $version);
  my ($available, $remote_version, $location);
  foreach (keys %$packages) {
    $location = $_;
    $remote_version = $packages->{$location}->{$pack}->{VERSION};
    my @remote_version = split (',', $remote_version);
    foreach(0..3) {
      next if $installed_version[$_] == $remote_version[$_];
      $available++ if $installed_version[$_] < $remote_version[$_];
      last;
    }
    last if $available;
  }
  if ($available) {
    $upgrades->{$pack} = {location => $location,
			  version => $remote_version};
    return ppd2cpan_version($remote_version);
  }
  else {
    return 'OK';
  }
}

sub get_selection {
  my $widget = shift;
  my @sel = $widget->curselection;
  return unless (@sel == 1);
  my $pack = ($widget->getRow($sel[0]))[0];
  my $loc = ($widget->getRow($sel[0]))[2] ?
    ($widget->getRow($sel[0]))[2] : undef;
  return ($sel[0], $pack, ($widget->getRow($sel[0]))[1], $loc);
}

sub remove {
  my ($index, $package, $version, $loc) = get_selection($local) or do {
    dialog_error('No selection made', 'Please make a selection first');
    return;
  };
  return unless dialog_yes_no('Confirm delete',
			      qq{Remove "$package?"});
  msg_update(qq{Removing "$package" - please wait ...});
  unless (RemovePackage(package => $package)) {
    $error = $PPM::PPMERR;
    dialog_error('Removal error', 
		 qq{Removal of "$package" failed.});
    return;
  }
  msg_update(qq{Done!});
  dialog_info('Removal suceessful',
	     qq{Removed "$package"});
  $local->delete($index);
}

sub ppminstall_bind {
  my ($widget, $hash, %args) = @_;
  my ($index, $package, $version, $alias) = get_selection($rep) or do {
      dialog_error('No selection made', 'Please make a selection first');
      return;
    };
  ppminstall($package, $reps{$alias}, $version);
}


sub ppminstall {
  my ($package, $location, $version) = @_;
  return unless ($package);
  my %installed = InstalledPackageProperties();
  if (my $pkg = (grep {/^$package$/i} keys %installed)[0]) {
    my $version = ppd2cpan_version($installed{$pkg}{'VERSION'});
    dialog_error('Already installed', 
		 qq{Version $version of '$pkg' is already installed.\n} .
		 qq{Either remove it or use the upgrade button.});
    return;
  }
  return unless dialog_yes_no('Confirm install',
			      qq{Install "$package?"});
  msg_update(qq{Installing "$package" - please wait ....});
  unless (InstallPackage(package => $package, location => $location)) {
    $error = $PPM::PPMERR;
    dialog_error('Installation error', 
		 qq{Installation of "$package" failed.});
    return;
  }
  msg_update(qq{Done!});
  dialog_info('Installation successful',
	      qq{Installed "$package".});
  my $hashref = $info->{$package}->{$location};
  foreach (keys %$hashref) {
    next if ($_ eq 'location');
    $info->{$package}->{local}->{$_} = $hashref->{$_};
  }
  my $index = 'end';
  my $version = ppd2cpan_version($info->{$package}->{local}->{version});
  if ($index = get_index($package, $local)) {
    $local->delete($index);
  }
  $index ||= 'end';
  $local->insert($index, [$package, $version]);
}

sub get_readme {
  my $widget = shift;
  my ($index, $pack, $version, $loc) = get_selection($widget) or do {
    dialog_error('No selection made', 'Please make a selection first');
    return;
  };
  msg_update(qq{Fetching README - please wait ....});
  my $text = fetch_readme($pack) or do {
    dialog_error('No README available', qq{No README for '$pack' available});
    return;
  };
  msg_update(qq{Done!});
#  my $tl = $mw->Toplevel;
#  $tl->title('README');
#  my $scroll = $tl->Scrollbar();
#  my $readme = $tl->Text(-yscrollcommand => ['set' => $scroll]);
#  for (@$text) {
#    s/=head\d//;
#    $readme->insert('end', $_);
#  }
#  $scroll->configure(-command => ['yview' => $readme]);
#  $scroll->pack(-side => 'left', -fill => 'y');
#  $readme->pack(-side => 'top', -fill => 'y');
#  $tl->Button(-text => 'Quit',
#              -command => sub {$tl->destroy },
#             )->pack(-side => 'top');
  my $tmpfile = tempfile();
  open(my $fh, ">$tmpfile") or do {
    dialog_error('open failed',
                 qq{Could not open $tmpfile: $!});
    return;
  };
  for (@$text) {
    s/=head\d//;
    print $fh $_;
  }
  close $fh;
  my $editor = $ENV{EDITOR} || 'notepad';
  my @args = ($editor, $tmpfile);
  unless (launch(\@args, 1) == 0) {
    dialog_error('README failed',
                 qq{Launch of $editor to view README failed.});
  }
  unlink($tmpfile);
}

sub summary {
  my %packages;
  msg_update(qq{Obtaining summary from "$repository" - please wait ....});
  my @locations = ($repository eq 'All available') ?
      values %reps : ($reps{$repository});

  foreach my $loc (@locations) {
    # see if the repository has server-side searching
    # see if a summary file is available
    my %summary = RepositorySummary(location => $loc);
    if (%summary) {
      foreach my $package (keys %{$summary{$loc}}) {
	$packages{$loc}{$package} = \%{$summary{$loc}{$package}};
      }
    }
    else {
      my %ppds = PPM::RepositoryPackages(location => $loc);
      # No summary: oh my, nothing but 'Net
      foreach my $package (@{$ppds{$loc}}) {
	my %package_details = 
	  RepositoryPackageProperties(package => $package, 
				      location => $loc);
	next unless %package_details;
	$packages{$loc}{$package} = \%package_details;
      }
    }
  }
  msg_update(q{Done!});
  unless (%packages) {
    dialog_info(q{No summary available},
		q{Cannot get summary information});
    return;
  }
  foreach (keys %packages) {
    populate(\%{$packages{$_}}, $_);
  }
}

sub rep {
  my $reps = $mw->Toplevel;
  $reps->title('Repositories');
  my @choices = keys %reps;
  my $rep = $choices[0];
  my $add = $reps{$rep};
  $reps->Label( -text => 'Repository: ')
    ->grid(-row => 0, -pady => 5, -padx => 5,
	   -column => 0, -sticky => 'e');  
  my $box = 
    $reps->BrowseEntry(-variable => \$rep,
		       -choices => [@choices],
		       -browsecmd => sub{$add = $reps{$rep}},
		      )
      ->grid(-row => 0, -column => 1, -columnspan => 3, 
             -pady => 5, -padx => 5, -sticky => 'w', -ipadx => 5);
  
  $reps->Label( -text => 'URL: ')
    ->grid(-row => 1, -column => 0, -sticky => 'e', -pady => 10);
  $reps->Label( -textvariable => \$add, -relief => 'groove')
    ->grid(-row => 1, -column => 1, -columnspan => 4, -pady => 10,
           -sticky => 'w', -padx => 5);
 
  $reps->Checkbutton(-text => 'save changes',
		     -variable => \$save,
		     -onvalue => 1,
		     -offvalue => 0,
		    )
    ->grid(-row => 2, -column => 0, 
	   -pady => 5,  -sticky => 'e');
  
  $reps->Button( -text => 'New',
		 -command => [\&new_rep, $reps],
	       )->grid(-row => 2, -pady => 10, 
		       -padx => 5, -column => 1, -sticky => 'w');
  $reps->Button( -text => 'Delete',
		 -command => [\&del_rep, $reps, \$rep],
	       )->grid(-row => 2, -pady => 10, 
		       -padx => 5, -column => 2, -sticky => 'w');
  $reps->Button( -text => 'Known',
		 -command => [\&add_rep, $reps],
	       )->grid(-row => 2, -pady => 10, 
		       -padx => 5, -column => 3, -sticky => 'w');
  $reps->Button( -text => 'Close',
		 -command => [ $reps => 'destroy'],
	       )->grid(-row => 2, -pady => 10,
		       -padx => 5, -column => 4, -sticky => 'w');
}

sub del_rep {
  my ($tl, $rep) = @_;
  return unless dialog_yes_no('Confirm delete',
			      qq{Delete "$$rep" from the repository list?});
  RemoveRepository(repository => $$rep, save => $save);
  $tl->destroy;
  $replist->delete($indices{$$rep});
  set_reps();
  rep();
}

sub new_rep {
  my $tl = shift;
  my ($rep, $loc);
  my $add = $mw->DialogBox(-title => 'Add a repository',
			   -buttons => ['OK', 'Cancel']);
  $add->add('LabEntry', -textvariable => \$rep, 
	    -label => 'Name: ', -width => 20, 
	    -labelPack => [-side => 'left'])
    ->grid(-row => 0, -column => 0, -pady => 10,
	   -sticky => 'w');
  $add->add('LabEntry', -textvariable => \$loc, 
	    -width => 40, -label => 'URL:   ', 
	    -labelPack => [-side => 'left'])
    ->grid(-row => 1, -column => 0, -pady => 10,
	   -sticky => 'w');
  my $ans = $add->Show;
  return unless ($ans eq 'OK');
  $rep = trim($rep);
  $loc = trim($loc);
  unless ($rep and $loc) {
    dialog_error('Incomplete specification',
		q{Please specify both a name and the URL for the repository});
    return;
  }
  AddRepository(repository => $rep, location => $loc, save => $save);
  $tl->destroy;
  $replist->insert('end', $rep);
  set_reps();
  rep();
}

sub add_rep {
  my $tl = shift;
  my $add = $mw->DialogBox(-title => 'Select a repository',
                           -buttons => ['OK', 'Cancel']);
  my @choices;
  my @others = values %reps;
  (my $pv = $]) =~ s!(5.)00(\d).*!$1$2!;
  foreach my $entry (sort keys %Repositories) {
    next unless grep {$_ eq $^O}
      @{ $Repositories{$entry}->{PerlO}};
    next unless grep {$_ eq $pv}
      @{ $Repositories{$entry}->{PerlV}};
    next if grep {$_ eq $Repositories{$entry}->{location} } @others;
    push @choices, $entry;
  }
  my $rep = $choices[0];
  my $loc = $Repositories{$rep}->{location};
  my $note = $Repositories{$rep}->{Notes};
  $add->Label( -text => 'Repository: ')
    ->grid(-row => 0, -pady => 5, -padx => 5,
           -column => 0, -sticky => 'e');  
  my $box = 
    $add->BrowseEntry(-variable => \$rep,
                      -choices => [@choices],
                      -browsecmd => 
                      sub{$loc = $Repositories{$rep}->{location};
                          $note = $Repositories{$rep}->{Notes}},
                     )
      ->grid(-row => 0, -column => 1, -columnspan => 3, 
             -pady => 5, -padx => 5, -sticky => 'w', -ipadx => 5);
  
  $add->Label( -text => 'URL: ')
    ->grid(-row => 1, -column => 0, -sticky => 'e', -pady => 10);
  $add->Label( -textvariable => \$loc, -relief => 'groove')
    ->grid(-row => 1, -column => 1, -columnspan => 4, -pady => 10,
           -sticky => 'w', -padx => 5);
  $add->Label( -text => 'Note: ')
    ->grid(-row => 2, -column => 0, -sticky => 'e', -pady => 10);
  $add->Label( -textvariable => \$note, -relief => 'groove')
    ->grid(-row => 2, -column => 1, -columnspan => 4, -pady => 10,
           -sticky => 'w', -padx => 5);
  
  my $ans = $add->Show;
  return unless ($ans eq 'OK');
  $rep = trim($rep);
  $loc = trim($loc);
  AddRepository(repository => $rep, location => $loc, save => $save);
  $tl->destroy;
  $replist->insert('end', $rep);
  set_reps();
  rep();
}

sub populate {
  my ($data, $where) = @_;
  foreach my $package (sort keys %{$data}) {
    my $author = $data->{$package}->{AUTHOR};
    my $version = ppd2cpan_version($data->{$package}->{VERSION});
    if ($author and $author =~ /Unknown/i) {
      $author = 'Unknown';
    }
    $info->{$package}->{$where}
      = {author => $author,
	 abstract => $data->{$package}->{ABSTRACT},
	 version => $data->{$package}->{VERSION},
	};
    if ($where eq 'local') {
      $local->bell;
      $local->insert('end', [$package, $version]);
    }
    else {
      $rep->bell;
      $rep->insert('end', [$package, $version, $alias{$where}]);
    }
  }
}

sub launch {
  my ($cmd, $no_console) = @_;
  if (ref($cmd) eq 'ARRAY') {
    $cmd = join ' ', @{$cmd};    
  }
  my $cflags = $no_console ? NORMAL_PRIORITY_CLASS :
    NORMAL_PRIORITY_CLASS  | CREATE_NEW_CONSOLE;
  my $ProcessObj;
  $mw->withdraw;
  Win32::Process::Create($ProcessObj,
                         "$shell",
                         "$shell /c $cmd",
                         0,
                         $cflags,
                         ".")
      or do {
        $error = Win32::FormatMessage(Win32::GetLastError());
        $mw->deiconify;
        $mw->raise;
        return;
      };
  $ProcessObj->Wait(INFINITE);
  my $exitcode;
  $ProcessObj->GetExitCode($exitcode);
  $mw->deiconify;
  $mw->raise;
  return $exitcode;
}

sub get_index {
  my ($match, $widget) = @_;
  my @list = $widget->get(0, 'end');
  my $i = 0;
  foreach (@list) {
    return $i if ($_->[0] eq $match);
    $i++;
  }
  return;
}

sub clear {
  my $widget = shift;
  $widget->delete(0, 'end');
}

sub display_info {
  my ($widget, $hash, $where) = @_;
  my ($package, $index, $version, $loc);
  if ($where and $where eq 'local') {
    ($index, $package, $version) = get_selection($widget);
  }
  else {
    ($index, $package, $version, $where) = get_selection($widget);
  }
  unless ($package) {
    dialog_error('Selection error', 'Please make a selection first');
    return;
  }
  my $loc = ($where eq 'local' ? 'local' : $reps{$where});
  my $vers = ppd2cpan_version($info->{$package}->{$loc}->{version});
  my $msg = <<"END";
 Package "$package":
   Version: $vers        
   Author: $info->{$package}->{$loc}->{author}             
   Abstract: $info->{$package}->{$loc}->{abstract}              
END
  if ($where ne 'local') {
    $msg .= qq[   Location: $where                      \n];
  }
  dialog_info(qq{Information for "$package"}, $msg);
}

sub help_msg {
  my ($widget, $msg) = @_;
  $widget->bind('<Enter>', [sub {$message = $_[1]; }, $msg]);
  $widget->bind('<Leave>', [sub {$message = ''; }]);
}

sub msg_update {
  $message = shift;
  $mw->update;
}

sub dialog_error {
  my ($title, $msg) = @_;
  $msg .= "\n\n$error" if $error;
  my $ans = $mw->messageBox(-title => $title, -message => $msg,
			    -icon => 'error', -type => 'OK');
  undef $error;
}

sub dialog_info {
  my ($title, $msg) = @_;
  my $ans = $mw->messageBox(-title => $title, -message => $msg,
			    -icon => 'info', -type => 'OK');
  undef $error;
}

sub dialog_yes_no {
  my ($title, $msg) = @_;
  my $ans = $mw->messageBox(-title => $title, -message => $msg,
			    -icon => 'warning', -type => 'YesNo');
  return ($ans eq 'yes') ? 1 : 0;
}


__END__

=head1 NAME

tk-ppm - Tk interface to the ppm utility

=head1 SYNOPSIS

   C:\> perl tk-ppm

or, first making a C<bat> file,

   C:\> pl2bat tk-ppm
   C:\> tk-ppm

=head1 README

This script provides a Tk graphical interface to the ppm
utility, used particularly with Win32 ActivePerl to install
and manage binary packages.

=head1 DESCRIPTION

When invoked, C<tk-ppm> will bring up a main window through
which one can do many of the operations of the command-line based
C<ppm> utility:

=over 3

=item *

query for information on locally installed packages.

=item *

check if upgrades are available for locally installed
packages, and do an upgrade (one may have to remove packages
first before doing an upgrade).

=item *

search, by package name, author, abstract, or module name,
for packages on remote repositories (this requires the CPAN.pm
module to be available and configured). If no ppm package is found,
an offer will be made to search CPAN for the package and, if found,
use PPM::Make to install it.

=item *

install packages from remote repositories.

=item *

add or delete entries from the list of repositories. This
uses the PPM::Repostories module to suggest a list of
available repositories you may wish to include.

=back

Right-clicking on a package item within a listbox will bring
up a short description of that item, which double-clicking it
will either verify it (for a local package) or install it
(for a remote package). Short descriptions of actions are provided 
within the window when the mouse hovers over the different 
buttons and areas - a more thorough description is available within 
the C<ppm> utility.

At present, searching by module name is done by an exact
match. If no ppm package is found corresponding to the module
name, an offer will be made to attempt to install it
from the CPAN sources.

=head1 PREREQUISITES

This script requires C<Tk>, C<PPM>, C<Tk::MListbox>, 
C<PPM::Repositories>, and C<CPAN>.
The C<CPAN> module must be first configured.

=head1 OSNAMES

any

=head1 SEE ALSO

L<PPM>, L<PPM::Make::Install>, and L<CPAN>.

=head1 COPYRIGHT

This script is copyright (c) 2003 by Randy Kobes
(E<lt>randy@theory.uwinnipeg.caE<gt>). All rights reserved.
You may use and distribute this code under the same terms
as Perl itself.

=head1 SCRIPT CATEGORIES

Win32

=cut

=cut
