CPANPLUS-Shell-Tk
view release on metacpan or search on metacpan
lib/CPANPLUS/Shell/Tk.pm view on Meta::CPAN
use CPANPLUS::Backend;
use CPANPLUS::I18N;
use Tk;
use Tk::Adjuster;
use Tk::Text;
use Tk::ROText;
use Tk::NoteBook;
use Tk::MListbox;
use Tk::BrowseEntry;
use Tk::FileSelect;
use Tk::Pod::Text;
use Tk::Splashscreen;
use Tk::Dialog;
use Config;
use File::Find;
#------------------------------------------------------------------------
# constructor
#
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
### Will call the _init constructor in Internals.pm ###
my $self = $class->SUPER::_init( brand => 'cpan' );
return $self;
}
#------------------------------------------------------------------------
# run the shell
#
sub shell {
my $self = shift;
my $MW = $self->_setup_main();
$MW->withdraw;
my $splash = $MW->Splashscreen(-milliseconds => 5000, -background => 'blue');
my $text = 'Initializing CPANPLUS backend . . .';
#---- find splash image
my $splashfile = 'CPANPLUS/Shell/cpanplus.ppm';
my $realname;
foreach my $prefix (@INC) {
$realname = "$prefix/$splashfile";
if (-f $realname) {
last;
}
$realname = undef;
}
#---- show splashscreen with image or with text
if ($realname) {
$splash->Label(-image => $MW->Photo(-file => $realname), -background => 'blue', -foreground => 'yellow')->pack(-side => 'top', -fill => 'both', -expand => 1, -padx => 10, -pady => 10);
} else {
$splash->Label(-text => "CPUI $VERSION",-font => '{Helvetica} -20 {bold}', -background => 'blue', -foreground => 'yellow')->pack(-side => 'top', -fill => 'both', -expand => 1, -padx => 10, -pady => 10);
}
$splash->Label(-textvariable => \$text, -background => 'blue', -foreground => 'yellow')->pack(-side => 'top', -fill => 'both', -expand => 1, -padx => 10, -pady => 10);
$splash->Splash;
$splash->update;
#---- create Backend object
my $CP = new CPANPLUS::Backend;
$splash->update;
$self->{CP} = $CP;
#---- setup menus
$self->_setup_menu();
#---- gather installed modules
$text = 'Looking for installed modules . . .';
$splash->update;
my $rv = $CP->installed;
$self->{INSTALLED} = $rv->rv();
#---- gather modules not up to date
$text = 'Looking for modules to be updated . . .';
$splash->update;
$rv = $CP->uptodate(modules => [keys %{$self->{INSTALLED}}]);
$self->{NOT_UPTODATE} = $rv->rv();
delete $self->{NOT_UPTODATE}->{$_} foreach map { $self->{NOT_UPTODATE}->{$_}->{uptodate} ? $_ : () } keys %{$self->{NOT_UPTODATE}};
#---- setup main window
$text = 'Setting up main window . . .';
$splash->update;
$self->_setup_contents();
#---- if available install inputhandler
if ($self->{CP}->can('set_input_handler')) {
$self->{CP}->set_input_handler( sub { $self->_get_input } );
}
#---- take off
$splash->Destroy;
$self->{MW}->deiconify;
MainLoop;
}
#------------------------------------------------------------------------
# use by cpui -H Tk
#
sub help {
print "
Tk user interface for CPANPLUS
No help available at the moment.
Start the gui and try.
\n";
}
#------------------------------------------------------------------------
# setup main window
#
lib/CPANPLUS/Shell/Tk.pm view on Meta::CPAN
$self->{HISTORY}->insert('end', "extract\t" . join(' ', @{$self->{MODS}}) . "\n");
$MW->Unbusy;
}],
[Button => 'Make',
-command => sub {
$MW->Busy;
$self->{$_}->packForget foreach qw(HISTORY POD INFO);
$self->{INFO}->pack(-fill => 'both', -expand => 1);
$self->{INFO}->delete('0.0', 'end');
$CP->make(modules => $self->{MODS});
$self->{HISTORY}->insert('end', "make\t" . join(' ', @{$self->{MODS}}) . "\n");
$MW->Unbusy;
}],
[Button => 'Pod',
-command => sub {
$self->{$_}->packForget foreach qw(HISTORY POD INFO);
$self->{POD}->configure(-file => $self->{MODS}->[0]);
print $self->{MODS}->[0], "\n";
$self->{POD}->pack(-fill => 'both', -expand => 1);
}],
],
);
return $menu;
}
#------------------------------------------------------------------------
# configure CPANPLUS
#
sub _config_cpanplus {
my $self = shift;
my $MW = $self->{MW};
my $CP = $self->{CP};
my $conf = $CP->configure_object();
my @options = $conf->subtypes('conf');
my %conf;
#---- attributes of config values, should be moved to CPANPLUS::Configure
my %conf_attrs = (cpantest => { type => 's', width => 1, comment => 'Send testreport to CPAN testers'},
debug => { type => 's', width => 1, comment => 'Output debug messages'},
flush => { type => 's', width => 1, comment => 'Flush cache automatically'},
force => { type => 's', width => 1, comment => 'Install even if tests fail'},
lib => { type => 'a', width => 20, comment => 'additional INC directories'},
makeflags => { type => 'h', width => 20, comment => 'Flags for the make command'},
makemakerflags => { type => 'h', width => 20, comment => 'Flags for makemaker'},
prereqs => { type => 's', width => 1, comment => 'Handle prerequesites'},
storable => { type => 's', width => 1, comment => 'Use Storable'},
verbose => { type => 's', width => 1, comment => 'Be verbose'},
md5 => { type => 's', width => 1, comment => 'Check md5 checksums'},
signature => { type => 's', width => 1, comment => 'Check gpg signature'},
shell => { type => 's', width => 25, comment => 'Default CPANPLUS shell'},
dist_type => { type => 's', width => 20, comment => 'Distribution type'},
skiptest => { type => 's', width => 1, comment => 'Skip tests'},
);
#---- window
my $confdlg = $MW->Toplevel(-title => 'CPANPLUS Configuration', -background => 'white');
$confdlg->geometry('500x500+200+100');
my $row = 0;
$confdlg->Label(-text => 'CPANPLUS Configuration', -background => 'white', -font => '{Helvetica} -20 {bold}')->pack(-side => 'top', -pady => 10);
$row++;
my $f = $confdlg->Frame(-background => 'white')->pack(-side => 'top');
#---- one line for each option
foreach (sort @options) {
$conf_attrs{$_} ||= { type => 's', width => 20, comment => 'unknown/new option'};
my $conf_attr;
if ($conf->can('conf_attr')) {
$conf_attr = $conf->conf_attr('conf', $_) || {type => 's', width => 20, comment => 'unknown/new option'};
} else {
$conf_attr = $conf_attrs{$_};
}
SWITCH: { # tried the Switch module here, but it choked on something
if ($conf_attr->{type} eq 'a') { $conf{$_} = join ';', @{$conf->get_conf($_)}; last SWITCH }
if ($conf_attr->{type} eq 's') { $conf{$_} = $conf->get_conf($_); last SWITCH }
if ($conf_attr->{type} eq 'h') { my %tempconf = %{$conf->get_conf($_)};
$conf{$_} = join ', ', map { "$_ => '$tempconf{$_}'"} keys %tempconf; }
}
$f->Label(-text => $_, -background => 'white')->grid(-column => 1, -row => $row, -sticky => 'w');
$f->Entry(-textvariable => \$conf{$_}, -width => $conf_attr->{width} || 20)->grid(-column => 2, -row => $row, -sticky => 'w');
$f->Label(-text => $conf_attr->{comment}, -background => 'white')->grid(-column => 3, -row => $row, -sticky => 'w');
$row++;
}
#---- the normal buttons
my $ok = $f->Button(-text => 'Ok',
-pady => -1,
-default => 'active',
-command => sub {
$confdlg->destroy();
foreach (@options) {
SWITCH: {
if ($conf_attrs{$_}->{type} eq 'a') { $conf->set_conf($_ => [split /;/, $conf{$_}]); last SWITCH }
if ($conf_attrs{$_}->{type} eq 's') { $conf->set_conf($_ => $conf{$_}); last SWITCH }
if ($conf_attrs{$_}->{type} eq 'h') { my %tempconf = eval "($conf{$_})";
$conf->set_conf($_ => \%tempconf); }
}
}
})->grid(-column => 1, -row => ++$row, -pady => 20);
$f->Button(-text => 'Cancel',
-pady => -1,
-command => sub {
$confdlg->destroy();
})->grid(-column => 2, -row => $row, -pady => 20);
$f->Button(-text => 'Save',
-pady => -1,
-command => sub {
$confdlg->destroy();
foreach (@options) {
SWITCH: {
if ($conf_attrs{$_}->{type} eq 'a') { $conf->set_conf($_ => [split /;/, $conf{$_}]); last SWITCH }
if ($conf_attrs{$_}->{type} eq 's') { $conf->set_conf($_ => $conf{$_}); last SWITCH }
if ($conf_attrs{$_}->{type} eq 'h') { my %tempconf = eval "($conf{$_})";
$conf->set_conf($_ => \%tempconf); }
}
}
$conf->save;
})->grid(-column => 3, -row => $row, -pady => 20);
$confdlg->bind('<Any-Key-Return>', [sub {$ok->invoke}]);
$confdlg->bind('<Any-Key-KP_Enter>', [sub {$ok->invoke}]);
$confdlg->bind('<Any-Key-Escape>', [sub {$confdlg->destroy()}]);
#---- show dialog
$confdlg->waitWindow();
}
#------------------------------------------------------------------------
# configure ftp and other sites
#
sub _config_sources {
my $self = shift;
my $MW = $self->{MW};
my $CP = $self->{CP};
my $conf = $CP->configure_object();
my ($scheme, $host, $path, $sel);
my $confdlg = $MW->Toplevel(-title => 'CPANPLUS Configuration', -background => 'white');
$confdlg->geometry('600x400+200+100');
my $row = 0;
$confdlg->Label(-text => 'CPANPLUS package sources', -background => 'white', -font => '{Helvetica} -20 {bold}')->pack(-side => 'top', -pady => 10);
my $sources = $confdlg->Scrolled('MListbox',
-scrollbars => 'ow',
-selectmode => 'single',
-moveable => 0,
-background => 'white',
)->pack(-side => 'top', -fill => 'both', -expand => 1);
$sources->Subwidget("yscrollbar")->configure(-width => 6);
$sources->Subwidget("xscrollbar")->configure(-width => 6);
$sources->columnInsert('end', -text => 'Scheme', -width => 10);
$sources->columnInsert('end', -text => 'Host', -width => 30);
$sources->columnInsert('end', -text => 'Path', -width => 50);
$sources->columnGet(0)->Subwidget('heading')->configure(-pady => -1);
$sources->columnGet(1)->Subwidget('heading')->configure(-pady => -1);
$sources->columnGet(2)->Subwidget('heading')->configure(-pady => -1);
$sources->bindRows('<ButtonPress-1>',
[ sub {
$sel = $sources->curselection;
my @a = $sources->get($sel, $sel);
($scheme, $host, $path) = @{$a[0]};
}
]
);
foreach (@{$conf->_get_ftp('urilist')}) {
$sources->insert('end', [$_->{scheme}, $_->{host}, $_->{path}]);
}
my $f = $confdlg->Frame(-background => 'white')->pack(-side => 'bottom', -fill => 'x', -expand => 1);
$f->Entry(-textvariable => \$scheme, -width => 10)->grid(-column => 1, -row => 0, -pady => 10);
$f->Entry(-textvariable => \$host, -width => 30)->grid(-column => 2, -row => 0, -pady => 10);
$f->Entry(-textvariable => \$path, -width => 50)->grid(-column => 3, -row => 0, -pady => 10);
$f->Button(-text => 'Enter new',
-pady => -1,
-command => sub {
if ($scheme && $host && $path) {
$sources->insert('end', [$scheme, $host, $path]);
}
})->grid(-column => 1, -row => 1, -padx => 10, -pady => 10);
$f->Button(-text => 'Change selected',
-pady => -1,
-command => sub {
if (defined $sel) {
$sources->delete($sel, $sel);
$sources->insert($sel, [$scheme, $host, $path]);
}
})->grid(-column => 2, -row => 1, -padx => 10, -pady => 10);
$f->Button(-text => 'Delete selected',
-pady => -1,
-command => sub {
if (defined $sel) {
$sources->delete($sel, $sel);
}
})->grid(-column => 3, -row => 1, -padx => 10, -pady => 10);
my $ok = $f->Button(-text => 'Ok',
-pady => -1,
-default => 'active',
-command => sub {
$conf->_set_ftp(urilist => [ map {
{ scheme => $_->[0],
host => $_->[1],
path => $_->[2]
}
} $sources->get(0, 'end')
]
);
$confdlg->destroy();
})->grid(-column => 1, -row => 2, -padx => 10, -pady => 10);
$f->Button(-text => 'Cancel',
-pady => -1,
-command => sub {
$confdlg->destroy();
})->grid(-column => 2, -row => 2, -padx => 10, -pady => 10);
$f->Button(-text => 'Save',
-pady => -1,
-command => sub {
$conf->_set_ftp(urilist => [ map {
{ scheme => $_->[0],
host => $_->[1],
path => $_->[2]
}
} $sources->get(0, 'end')
]
);
$confdlg->destroy();
$conf->save;
})->grid(-column => 3, -row => 2, -padx => 10, -pady => 10);
$confdlg->bind('<Any-Key-Return>', [sub {$ok->invoke}]);
$confdlg->bind('<Any-Key-KP_Enter>', [sub {$ok->invoke}]);
$confdlg->bind('<Any-Key-Escape>', [sub {$confdlg->destroy()}]);
$confdlg->waitWindow();
}
#------------------------------------------------------------------------
# show complete perl configuration
#
sub _perl_config {
my $self = shift;
my $MW = $self->{MW};
my $CP = $self->{CP};
my $conf = $CP->configure_object();
my ($scheme, $host, $path, $sel);
my $confdlg = $MW->Toplevel(-title => 'Perl configuration', -background => 'white');
$confdlg->geometry('600x400+200+100');
my $row = 0;
$confdlg->Label(-text => 'Perl configuration', -background => 'white', -font => '{Helvetica} -20 {bold}')->pack(-side => 'top', -pady => 10);
my $options = $confdlg->Scrolled('MListbox',
-scrollbars => 'ow',
-selectmode => 'single',
-moveable => 0,
-background => 'white',
)->pack(-side => 'top', -fill => 'both', -expand => 1);
$options->Subwidget("yscrollbar")->configure(-width => 6);
$options->Subwidget("xscrollbar")->configure(-width => 6);
$options->columnInsert('end', -text => 'Key', -width => 20);
$options->columnInsert('end', -text => 'Value', -width => 60);
$options->columnGet(0)->Subwidget('heading')->configure(-pady => -1);
$options->columnGet(1)->Subwidget('heading')->configure(-pady => -1);
foreach (sort keys %Config) {
$options->insert('end', [$_, $Config{$_}]);
}
my $ok = $confdlg->Button(-text => 'Ok',
-pady => -1,
-default => 'active',
-command => sub {
$confdlg->destroy();
})->pack(-side => 'bottom');
$confdlg->bind('<Any-Key-Return>', [sub {$ok->invoke}]);
$confdlg->bind('<Any-Key-KP_Enter>', [sub {$ok->invoke}]);
$confdlg->bind('<Any-Key-Escape>', [sub {$confdlg->destroy()}]);
$confdlg->waitWindow();
}
#------------------------------------------------------------------------
# restart shell with another perl version
#
sub _perl_restart {
my $self = shift;
my $MW = $self->{MW};
my $CP = $self->{CP};
my $restartdlg = $MW->Toplevel(-title => 'Restart', -background => 'white');
$restartdlg->geometry('200x300+200+100');
my $row = 0;
$restartdlg->Label(-text => "Restart with other\nPerl version", -background => 'white', -font => '{Helvetica} -20 {bold}')->pack(-side => 'top', -pady => 10);
my $versions = $restartdlg->Scrolled('MListbox',
-scrollbars => 'ow',
-selectmode => 'single',
-moveable => 0,
-height => 5,
-width => 30,
-background => 'white',
)->pack(-side => 'top', -fill => 'both', -expand => 1);
$versions->Subwidget("yscrollbar")->configure(-width => 6);
$versions->Subwidget("xscrollbar")->configure(-width => 6);
$versions->columnInsert('end', -text => 'Perl', -width => 20);
$versions->columnGet(0)->Subwidget('heading')->configure(-pady => -1);
find( sub {
return if !/^perl\d/;
$versions->insert('end', [$File::Find::name]);
}, '/usr/bin', '/usr/local/bin'); # hardcoded at the moment, should move to some config
my $ok = $restartdlg->Button( -text => 'Ok',
-pady => -1,
-default => 'active',
-command => sub {
my $sel = $versions->curselection;
if (defined $sel) {
my ($cmd) = $versions->get($sel);
$, = ", ";
print $cmd->[0], $0, @ARGV, "\n";
exec $cmd->[0], $0, @ARGV;
}
$restartdlg->destroy();
})->pack(-side => 'left', -pady => 10, -padx => 10);
$restartdlg->Button(-text => 'Cancel',
-pady => -1,
-command => sub {
$restartdlg->destroy();
})->pack(-side => 'right', -pady => 10, -padx => 10);
$restartdlg->bind('<Any-Key-Return>', [sub {$ok->invoke}]);
$restartdlg->bind('<Any-Key-KP_Enter>', [sub {$ok->invoke}]);
$restartdlg->bind('<Any-Key-Escape>', [sub {$restartdlg->destroy()}]);
$restartdlg->waitWindow();
}
#------------------------------------------------------------------------
# bring the history editor to front
#
sub _show_history {
my $self = shift;
$self->{$_}->packForget foreach qw(HISTORY POD INFO);
$self->{HISTORY}->pack(-fill => 'both', -expand => 1);
}
#------------------------------------------------------------------------
# load a history file
#
sub _load_history {
my $self = shift;
my $fs = $self->{MW}->FileSelect(-directory => $ENV{HOME});
my $file = $fs->Show;
if (open HISTORY, "<$file") {
$self->{HISTORY}->insert('end', <HISTORY>);
close HISTORY;
} else {
$self->{MW}->messageBox(-title => 'cpui - error', -message => $!, -type => 'OK');
}
}
#------------------------------------------------------------------------
# save the history to some file
#
sub _save_history {
my $self = shift;
my $fs = $self->{MW}->FileSelect(-directory => $ENV{HOME});
my $file = $fs->Show;
if (open HISTORY, ">$file") {
print HISTORY $self->{HISTORY}->get('0.0', 'end');
close HISTORY;
} else {
$self->{MW}->messageBox(-title => 'cpui - error', -message => $!, -type => 'OK');
}
}
#------------------------------------------------------------------------
# exit program, sub exists for some cleanup
#
sub _exit_ui {
exit;
}
#------------------------------------------------------------------------
# get input from user when installation process asks (not used by now)
#
sub _get_input {
my $self = shift;
my $MW = $self->{MW};
my $inputdlg = $MW->Toplevel(-title => 'User input', -background => 'white');
$inputdlg->geometry('500x200+200+100');
$inputdlg->Label(-text => 'User input required', -background => 'white', -font => '{Helvetica} -20 {bold}')->pack(-side => 'top', -pady => 10);
my $input;
$inputdlg->Entry(-textvariable => \$input, -width => 20)->pack(-side => 'left');
my $ok = $inputdlg->Button(-text => 'Ok',
-pady => -1,
-default => 'active',
-command => sub {
$inputdlg->destroy();
return $input;
}
)->pack(-side => 'right');
$inputdlg->bind('<Any-Key-Return>', [sub {$ok->invoke}]);
$inputdlg->bind('<Any-Key-KP_Enter>', [sub {$ok->invoke}]);
$inputdlg->waitWindow();
}
#------------------------------------------------------------------------
# show about dialog
#
sub _about {
my $self = shift;
my $dialog = $self->{MW}->MainWindow->Dialog(
-title => 'About CPANPLUS::Shell::Tk',
-text => "Tk User Interface for CPANPLUS\n\nVersion: $VERSION\n\n(C) Bernd Dulfer\n\n",
-default_button => 'Ok',
-buttons => ['Ok']
);
$dialog->configure(
-wraplength => '10i',
);
$dialog->Show();
$dialog->destroy();
$dialog = undef;
}
#------------------------------------------------------------------------
# show pod as online help
#
sub _help {
my $self = shift;
$self->{$_}->packForget foreach qw(HISTORY POD INFO);
$self->{POD}->configure(-file => 'CPANPLUS::Shell::Tk');
$self->{POD}->pack(-fill => 'both', -expand => 1);
}
#------------------------------------------------------------------------
1;
( run in 2.369 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )