package PAR::Dist::InstallPPD::GUI::Installed;
use strict;
use warnings;
use ExtUtils::Installed;
use Tk::HList;
use Tk::Dialog;
use IO::Dir;
our $VERSION = '0.05';
sub _init_installed_tab {
my $self = shift;
my $fr = $self->{tabs}{installed}->Frame()->pack(qw/-side top -fill both -expand 1/);
$self->{installed} = {};
my $afr = $fr->Frame()->pack(qw/-side top -fill x/);
my $remove_button = $afr->Button(
-text => 'Uninstall Selected Module', -command => [$self, '_uninstall_module_gui'],
)->pack(qw/-side left -padx 4/);
$afr->Label(-text=>'Filter Display:')->pack(qw/-side left -padx 4/);
$self->{installed}{module_display_filter} = $afr->Entry(
qw/-width 10 -background white -validate key/,
qw/-validatecommand/ => [$self, '_installed_modules_filter_hook'],
)->pack(qw/-side left -padx 4/);
$fr->Label(-text => 'Installed modules:')->pack(qw/-side top -fill x -pady 3/);
my $modules = $self->{installed}{modules} = $fr->Scrolled(
'HList', qw/-scrollbars osoe/,
qw/-columns 2 -header 1 -height 9 -background white/,
'-browsecmd' => [$self, '_display_installed_files']
)->pack(qw/-side top -fill both -expand 1 -padx 4/);
$modules->header('create', 0, -text => 'Module');
$modules->header('create', 1, -text => 'Version');
$fr->Label(-text => 'Files of selected module:')->pack(qw/-side top -fill x -pady 3/);
my $files = $self->{installed}{files} = $fr->Scrolled(
'HList', qw/-scrollbars osoe/,
qw/-columns 1 -header 1 -height 7 -background white/,
)->pack(qw/-side top -fill both -expand 1 -padx 4/);
$files->header('create', 0, -text => 'Path');
}
sub _installed_modules_filter_hook {
my $self = shift;
my $regex = shift;
my $change = shift;
# Don't refresh if invalid.
my $r;
eval {$r = qr/$regex/;};
return 1 if $@ or not defined $r;
$self->_populate_installed_modules_list(defined($regex) ? $regex : '');
return 1;
}
sub _raise_installed {
my $self = shift;
$self->_status('Searching for installed modules...');
my $inst = $self->{installed}{extutils_installed} = ExtUtils::Installed->new();
$self->_populate_installed_modules_list();
$self->_status('');
return 1;
}
sub _populate_installed_modules_list {
my $self = shift;
my $filter_re = shift;
$self->_status('Populating list of installed modules...');
$self->{installed}{module_display_filter}->configure(qw/-state readonly/);
my $inst = $self->{installed}{extutils_installed} ||= ExtUtils::Installed->new();
my $hlist = $self->{installed}{modules};
$hlist->delete('all');
$self->{installed}{files}->delete('all');
$self->{installed}{current_module} = undef;
$filter_re = $self->{installed}{module_display_filter}->get() if not defined $filter_re;
$filter_re = '.' if not defined $filter_re or $filter_re eq '';
eval {$filter_re = qr/$filter_re/;};
if ($@) {
$filter_re = qr/./;
}
my $i = 0;
foreach my $module (
map {$_->[1]}
sort {$a->[0] cmp $b->[0]}
map {[uc($_), $_]}
grep {$_ =~ $filter_re}
$inst->modules())
{
$self->{mw}->update();
next if $module =~ /^Perl/;
my $version = $inst->version($module) || '?';
$hlist->add($i);
$hlist->itemCreate($i, 0, -text => $module);
$hlist->itemCreate($i, 1, -text => $version);
$self->{mw}->update();
$i++;
}
$self->{installed}{module_display_filter}->configure(qw/-state normal/);
$self->_status('');
return 1;
}
sub _display_installed_files {
my $self = shift;
my $modules = $self->{installed}{modules};
my $files = $self->{installed}{files};
my @list = $modules->info('selection');
my $mod_no = shift @list;
my $modulename = $modules->itemCget($mod_no, 0, '-text');
my $current_module = $self->{installed}{current_module};
return if defined $current_module and $current_module eq $modulename;
$self->_status('Populating files list');
my $instl = $self->{installed}{extutils_installed}
|| ExtUtils::Installed->new();
my @files = $instl->files($modulename);
$files->delete('all');
my $i = 0;
foreach my $file (
map {$_->[1]}
sort {$a->[0] cmp $b->[0]}
map {[uc($_), $_]}
@files)
{
$files->add($i);
$files->itemCreate($i, 0, -text => $file);
$i++;
}
$self->{installed}{current_module} = $modulename;
$self->_status('');
}
sub _uninstall_module_gui {
my $self = shift;
my $module = $self->{installed}{current_module};
if (not defined $module or $module eq '') {
return;
}
my $confirm = $self->{mw}->Dialog(
-title => 'Really uninstall?',
-text => "Please confirm that you really wish to uninstall the '$module' module.",
-default_button => 'Cancel',
-buttons => ['Uninstall', 'Cancel'],
);
my $answer = $confirm->Show();
if ($answer eq 'Uninstall') {
$self->_uninstall_module($module);
$self->_raise_installed();
}
}
sub _uninstall_module {
my $self = shift;
my $module = shift;
$self->_status("Uninstalling $module from the system...");
my $instl = $self->{installed}{extutils_installed}
|| ExtUtils::Installed->new();
my @files = $instl->files($module);
# Remove all the files
foreach my $file (@files) {
unlink($file);
}
my $pf = $instl->packlist($module)->packlist_file();
unlink($pf);
foreach my $dir (sort($instl->directory_tree($module))) {
if ($self->_is_empty_dir($dir)) {
rmdir($dir);
}
}
undef $instl;
$self->_status('');
return 1;
}
sub _is_empty_dir {
my $self = shift;
my $dir = shift;
my $dh = IO::Dir->new($dir) || return(0);
my @count = $dh->read();
$dh->close();
return(@count == 2 ? 1 : 0);
}
1;
__END__
=head1 NAME
PAR::Dist::InstallPPD::GUI::Installed - Implements the Installed tab
=head1 SYNOPSIS
use PAR::Dist::InstallPPD::GUI;
my $gui = PAR::Dist::InstallPPD::GUI->new();
$gui->run();
=head1 DESCRIPTION
This module is B<for internal use only>.
=head1 SEE ALSO
L<PAR::Dist::InstallPPD::GUI>
PAR has a mailing list, <par@perl.org>, that you can write to; send an empty mail to <par-subscribe@perl.org> to join the list and participate in the discussion.
Please send bug reports to <bug-par-dist-installppd-gui@rt.cpan.org>.
The official PAR website may be of help, too: http://par.perl.org
For details on the I<Perl Package Manager>, please refer to ActiveState's
website at L<http://activestate.com>.
=head1 AUTHOR
Steffen Mueller, E<lt>smueller at cpan dot orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2006-2007 by Steffen Mueller
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.6 or,
at your option, any later version of Perl 5 you may have available.
=cut