package ActivePerl::PPM::GUI; BEGIN { # Don't allow these env vars to disrupt ppm Tkx usage unless we are # ourselves in debug mode. unless ($ENV{ACTIVEPERL_PPM_DEBUG}) { delete $ENV{$_} for qw(PERL_TCL_DLL PERL_TCL_DL_PATH); } } use strict; use Tkx (); use ActiveState::Browser (); use ActivePerl::PPM::Logger qw(ppm_log ppm_status); use ActivePerl::PPM::Util qw(is_cpan_package clean_err join_with update_html_toc); # get our cwd for Tcl files use File::Basename qw(dirname); use File::Spec::Functions qw(devnull); use Cwd qw(cwd abs_path); my @pending_status_message; my $ppm = $::ppm; $ActiveState::Browser::HTML_DIR = $ppm->area("perl")->html; status_message("$::bad_proxy\n\n", "abstract") if $::bad_proxy; # these will be filled in the sync() my %REPOS; my $INSTALL_AREA; my $mw = Tkx::widget->new("."); $mw->g_wm_withdraw(); Tkx::tk(appname => "Perl Package Manager"); Tkx::lappend('::auto_path', abs_path(dirname(__FILE__)) . "/tcl"); my $windowingsystem = Tkx::tk('windowingsystem'); my $AQUA = ($windowingsystem eq "aqua"); my $plat_acc_ctrl = ($AQUA ? "Command-" : "Ctrl+"); my $plat_evt_ctrl = ($AQUA ? "Command-" : "Control-"); if ($ENV{'ACTIVEPERL_PPM_DEBUG'}) { Tkx::package_require('comm'); print "DEBUG COMM PORT: " . Tkx::comm__comm('self') . "\n"; Tkx::package_require('tkcon'); Tkx::bind(all => "<${plat_evt_ctrl}F12>", 'catch {tkcon show}'); Tkx::bind(all => "<${plat_evt_ctrl}F11>", 'catch {tkcon hide}'); Tkx::catch("tkcon hide"); } Tkx::package_require('tile'); Tkx::package_require('img::png'); Tkx::package_require('ppm::themes'); Tkx::package_require('tooltip'); Tkx::package_require('widget::dialog'); Tkx::package_require('widget::statusbar'); Tkx::package_require('widget::toolbar'); Tkx::package_require('widget::menuentry'); Tkx::package_require('widget::panelframe'); Tkx::package_require('ppm::pkglist'); Tkx::package_require('ppm::repolist'); Tkx::package_require('ppm::arealist'); Tkx::package_require('style::as'); Tkx::package_require('BWidget'); Tkx::Widget__theme(1); Tkx::style__as__init(); # This enables font-size control via for # pkglist and text widgets Tkx::style__as__enable("control-mousewheel"); if ($AQUA) { Tkx::set("::tk::mac::useThemedToplevel" => 1); # The console can pop up unexpectedly from the tkkit Tkx::catch("console hide"); eval { Tkx::package_require('tclCarbonProcesses'); Tkx::carbon__setProcessName('PPM'); }; } if ($windowingsystem eq "win32") { # Due to a bug in Tk when wrapped as tkkit, we need to call the # iconbitmap setting on the main window an extra time. my $icon = Tkx::wm_iconbitmap($mw); Tkx::wm_iconbitmap($mw, $icon); Tkx::wm_iconbitmap($mw, -default => $^X); } elsif ($windowingsystem eq "x11") { Tkx::wm_iconphoto($mw, "-default", Tkx::ppm__img('perl')); } # This code makes themed frames use the notebook's background color. # We restrict the use of this to those frames in notebooks. Tkx::ttk__style(layout => "NotebookPane", ["NotebookPane.background", -sticky => "news", -expand => 1]); Tkx::option_add("*TNotebook.TFrame.style", "NotebookPane"); Tkx::option_add("*TEntry.cursor", "xterm"); # Make invalid state entry/label widget change color scheme Tkx::ttk__style(map => "TEntry", -foreground => [invalid => "red"], -fieldbackground => [invalid => "yellow"]); Tkx::ttk__style(map => "TLabel", -foreground => [invalid => "red"]); # get 'tooltip' as toplevel command Tkx::namespace_import("::tooltip::tooltip"); # make tree widgets use theming on non-x11 platforms if ($windowingsystem ne "x11") { Tkx::option_add("*TreeCtrl.useTheme", 1); } # Since our treectrl's don't scroll horizontal, make sure Home/End work # for the vertical direction as well Tkx::bind(TreeCtrl => "", Tkx::bind(TreeCtrl => "")); Tkx::bind(TreeCtrl => "", Tkx::bind(TreeCtrl => "")); Tkx::bind(TreeCtrl => "", Tkx::bind(TreeCtrl => "")); Tkx::bind(TreeCtrl => "", Tkx::bind(TreeCtrl => "")); # purely for reciprocity debugging, expose the ppm command in Tcl Tkx::interp_alias("", "ppm", "", [\&ppm]); # Use Tk scroll on OS X, but Ttk scrollbar elsewhere by default if ($AQUA) { Tkx::interp_alias("", "::ttk::scrollbar", "", "::scrollbar"); Tkx::option('add', "*Scrollbar.borderWidth", 0); } else { Tkx::interp_alias("", "::scrollbar", "", "::ttk::scrollbar"); } # These variables are tied to UI elements my %FILTER; $FILTER{'id'} = ""; $FILTER{'delay'} = 1000; # filter delay on key in millisecs $FILTER{'filter'} = ""; $FILTER{'lastfilter'} = ""; $FILTER{'fields'} = "name abstract"; $FILTER{'lastfields'} = $FILTER{'fields'}; $FILTER{'type'} = "installed"; # all installed upgradable modified $FILTER{'lasttype'} = $FILTER{'type'}; my %VIEW; $VIEW{'name'} = 1; $VIEW{'area'} = 1; $VIEW{'installed'} = 1; $VIEW{'repo'} = 0; $VIEW{'available'} = 1; $VIEW{'abstract'} = 1; $VIEW{'author'} = 0; $VIEW{'toolbar'} = 1; $VIEW{'statusbar'} = 1; $VIEW{'sortcolumn'} = 'name'; $VIEW{'sortorder'} = '-increasing'; my %ACTION; my $dummy = 0; # used as a dummy tied variable my %IMG; $IMG{'refresh'} = [Tkx::ppm__img('refresh')]; $IMG{'prefs'} = [Tkx::ppm__img('config')]; $IMG{'install'} = [Tkx::ppm__img('package', 'install')]; $IMG{'remove'} = [Tkx::ppm__img('package', 'remove')]; $IMG{'go'} = [Tkx::ppm__img('go')]; $IMG{'f_all'} = [Tkx::ppm__img('available', 'filter')]; $IMG{'f_upgradable'} = [Tkx::ppm__img('package', 'filter', 'upgradable')]; $IMG{'f_installed'} = [Tkx::ppm__img('package', 'filter')]; $IMG{'f_modified'} = [Tkx::ppm__img('package', 'filter', 'modified')]; my $action_menu; my $fields_menu; my $sort_menu; my $view_menu; my $file_menu; # Create the menu structure menus(); Tkx::bind($mw, "", [ sub { my $w = shift; on_exit() if $w eq $mw->_mpath; }, Tkx::Ev('%W') ]); $mw->g_wm_protocol('WM_DELETE_WINDOW', [\&on_exit]); Tkx::option_add("*takeFocus", "0"); Tkx::option_add("*TEntry.takeFocus", "1"); # Main interface my $pw = $mw->new_ttk__panedwindow(-orient => "vertical"); my $pkglist = $pw->new_pkglist( -width => 550, -height => 350, -selectcommand => [\&select_item], -borderwidth => 1, -relief => 'sunken', -itembackground => ["#F7F7FF", ""], -takefocus => 1, ); Tkx::bind($pkglist, "<>", [ sub { my ($x, $y, $X, $Y) = @_; if ($pkglist->identify($x, $y) =~ "header") { $fields_menu->g_tk___popup($X, $Y); } else { $pkglist->selection('clear'); eval { # This will error silently if the list is empty $pkglist->selection('add', "nearest $x $y"); $action_menu->g_tk___popup($X, $Y); }; } }, Tkx::Ev("%x", "%y", "%X", "%Y"), ]); # Aqua swaps buttons 2 and 3 for historical reasons Tkx::event('add', "<>", ($AQUA ? "" : ""), ""); # Catch changes in sort behavior by widget for menus Tkx::bind($pkglist, "<>", sub { $VIEW{'sortorder'} = $pkglist->cget('-sortorder'); }); Tkx::bind($pkglist, "<>", sub { $VIEW{'sortcolumn'} = $pkglist->cget('-sortcolumn'); }); # Details / Status areas my @smallfont = (-font => "ASfont"); my @smallfontbold = (-font => "ASfontBold"); if ($AQUA) { @smallfont = (-font => "ASfont-1"); @smallfontbold = (-font => "ASfontBold-1"); } my @text_opts = ( -height => 7, -width => 40, -cursor => "", -borderwidth => 3, -highlightthickness => 0, -relief => "flat", -font => "ASfont", -state => "disabled", -wrap => "word", ); my $pw_nb = $pw->new_ttk__notebook(-padding => 0); my $status_sw = $pw_nb->new_widget__scrolledwindow(); my $status_box = $status_sw->new_text(@text_opts); $status_sw->setwidget($status_box); my $details_sw = $pw_nb->new_widget__scrolledwindow(); my $details = $details_sw->new_text( @text_opts, -tabs => ["10", "left", "90", "left"], ); $details_sw->setwidget($details); for my $tw ($details, $status_box) { # Allow each text widget the same tag set $tw->tag_configure('h1', -font => 'ASfontBold2'); $tw->tag_configure('h2', -font => 'ASfontBold1'); $tw->tag_configure('abstract', -font => 'ASfontBold', -lmargin1 => 10, -lmargin2 => 10, -rmargin => 10, ); $tw->tag_configure('link', -underline => 1, -foreground => 'blue'); $tw->tag_bind('link', "", sub { $tw->configure(-cursor => "hand2"); }); $tw->tag_bind('link', "", sub { $tw->configure(-cursor => ""); }); } $pw_nb->add($status_sw, -text => "Status"); $pw_nb->add($details_sw, -text => "Details"); $pw_nb->select($status_sw); status_message(@$_) for @pending_status_message; $pw->add($pkglist, -weight => 3); $pw->add($pw_nb, -weight => 1); my $scroll_cmd = sub { my $dir = shift; my $tw = ($pw_nb->select() eq $status_sw ? $status_box : $details); $tw->yview("scroll", $dir, "page"); }; Tkx::bind($mw, "", [$scroll_cmd, 1]); Tkx::bind($mw, "", [$scroll_cmd, -1]); my $toolbar = $mw->new_widget__toolbar(); my $statusbar = $mw->new_widget__statusbar(-ipad => [1, 2]); Tkx::grid($toolbar, -sticky => "ew", -padx => 2); Tkx::grid($pw, -sticky => "news", -padx => 0, -pady => 0); Tkx::grid($statusbar, -sticky => "ew"); Tkx::grid(rowconfigure => $mw, 1, -weight => 1); Tkx::grid(columnconfigure => $mw, 0, -weight => 1); my $prefs_dialog; my $repolist; my $arealist; ## Toolbar items # Filter state buttons my $filter_all = $toolbar->new_ttk__radiobutton( -text => "All", -image => $IMG{'f_all'}, -style => "Toolbutton", -variable => \$FILTER{'type'}, -command => [\&filter], -value => "all", ); $toolbar->add($filter_all, -pad => [0, 2]); Tkx::tooltip($filter_all, "View all packages [${plat_acc_ctrl}1]"); my $filter_inst = $toolbar->new_ttk__radiobutton( -text => "Installed", -image => $IMG{'f_installed'}, -style => "Toolbutton", -variable => \$FILTER{'type'}, -command => [\&filter], -value => "installed", ); $toolbar->add($filter_inst, -pad => [0, 2]); Tkx::tooltip($filter_inst, "View installed packages [${plat_acc_ctrl}2]"); my $filter_upgr = $toolbar->new_ttk__radiobutton( -text => "Upgradable", -image => $IMG{'f_upgradable'}, -style => "Toolbutton", -variable => \$FILTER{'type'}, -command => [\&filter], -value => "upgradable", ); $toolbar->add($filter_upgr, -pad => [0, 2]); Tkx::tooltip($filter_upgr, "View upgradable packages [${plat_acc_ctrl}3]"); my $filter_mod = $toolbar->new_ttk__radiobutton( -text => "Modified", -image => $IMG{'f_modified'}, -style => "Toolbutton", -variable => \$FILTER{'type'}, -command => [\&filter], -value => "modified", ); $toolbar->add($filter_mod, -pad => [0, 2]); Tkx::tooltip($filter_mod, "View packages to install/remove [${plat_acc_ctrl}4]"); Tkx::bind(all => "<${plat_evt_ctrl}Key-1>" => sub { $filter_all->invoke(); }); Tkx::bind(all => "<${plat_evt_ctrl}Key-2>" => sub { $filter_inst->invoke(); }); Tkx::bind(all => "<${plat_evt_ctrl}Key-3>" => sub { $filter_upgr->invoke(); }); Tkx::bind(all => "<${plat_evt_ctrl}Key-4>" => sub { $filter_mod->invoke(); }); # Filter entry with filter.fields menu my $filter_menu = $toolbar->new_menu(-name => "filter_menu"); my $filter = $toolbar->new_widget__menuentry( -width => 1, -takefocus => 1, -menu => $filter_menu, -textvariable => \$FILTER{'filter'}, ); Tkx::tooltip($filter, "Filter packages [${plat_acc_ctrl}F]"); $toolbar->add($filter, -weight => 2); $filter_menu->add('radiobutton', -label => "Name", -value => "name", -variable => \$FILTER{'fields'}, -command => [\&filter], ); $filter_menu->add('radiobutton', -label => "Abstract", -value => "abstract", -variable => \$FILTER{'fields'}, -command => [\&filter], ); $filter_menu->add('radiobutton', -label => "Name or Abstract", -value => "name abstract", -variable => \$FILTER{'fields'}, -command => [\&filter], ); $filter_menu->add('radiobutton', -label => "Author", -value => "author", -variable => \$FILTER{'fields'}, -command => [\&filter], ); $filter->g_bind('', [\&filter]); $filter->g_bind('', [\&filter_onkey]); Tkx::bind(all => "<${plat_evt_ctrl}f>" => sub { Tkx::focus($filter); }); # Action buttons my $install_btn = $toolbar->new_ttk__checkbutton( -text => "Install", -variable => \$dummy, -image => $IMG{'install'}, -style => "Toolbutton", -state => "disabled", ); $toolbar->add($install_btn, -separator => 1, -pad => [4, 2, 0]); Tkx::tooltip($install_btn, "Mark for install [+]"); my $remove_btn = $toolbar->new_ttk__checkbutton( -text => "Remove", -variable => \$dummy, -image => $IMG{'remove'}, -style => "Toolbutton", -state => "disabled", ); $toolbar->add($remove_btn, -pad => [0, 2]); Tkx::tooltip($remove_btn, "Mark for remove [-]"); my $go_btn = $toolbar->new_ttk__button( -text => "Go", -image => $IMG{'go'}, -style => "Toolbutton", -state => "disabled", -command => [\&run_actions], ); $toolbar->add($go_btn, -pad => [4, 2, 0]); Tkx::tooltip($go_btn, "Run marked actions [${plat_acc_ctrl}Enter]"); # Add [+] and [-] key bindings for install/remove to pkglist Tkx::bind($pkglist, "", sub { $install_btn->invoke(); }); Tkx::bind($pkglist, "", sub { $remove_btn->invoke(); }); # Sync/config buttons my $sync_btn = $toolbar->new_ttk__button( -text => "Refresh", -image => $IMG{'refresh'}, -style => "Toolbutton", -command => \&full_refresh, ); Tkx::bind("all", "", sub { $sync_btn->invoke(); }); Tkx::tooltip($sync_btn, "Refresh all data [F5]"); $toolbar->add($sync_btn, -separator => 1, -pad => [4, 2]); my $prefs_btn = $toolbar->new_ttk__button( -text => "Preferences", -image => $IMG{'prefs'}, -style => "Toolbutton", -command => [\&show_prefs_dialog], ); Tkx::bind("all", "<${plat_evt_ctrl}p>", sub { $prefs_btn->invoke(); }); Tkx::tooltip($prefs_btn, "PPM Preferences [${plat_acc_ctrl}P]"); $toolbar->add($prefs_btn); if ($AQUA) { # Aqua isn't properly displaying the button disabled, so get the # effect through a greyed image for my $w ($filter_all, $filter_inst, $filter_upgr, $filter_mod, $install_btn, $remove_btn, $go_btn, $sync_btn, $prefs_btn) { my $img = $w->cget("-image"); if ($img) { my $disimg = Tkx::ppm__img( Tkx::SplitList(Tkx::ppm__imgname($img)), "gray", ); $w->configure(-image => [$img, disabled => $disimg]); } } } ## Statusbar items my %NUM; $NUM{'total'} = 0; $NUM{'listed'} = 0; $NUM{'installed'} = 0; $NUM{'install'} = 0; $NUM{'remove'} = 0; my $lbl; $lbl = $statusbar->new_ttk__label(-textvariable => \$NUM{'total'}, @smallfont); $statusbar->add($lbl); Tkx::tooltip($lbl, "Total number of known packages"); $lbl = $statusbar->new_ttk__label(-text => "packages,", @smallfont); $statusbar->add($lbl); Tkx::tooltip($lbl, "Total number of known packages"); $lbl = $statusbar->new_ttk__label(-textvariable => \$NUM{'listed'}, @smallfont); $statusbar->add($lbl); Tkx::tooltip($lbl, "Number of packages in filtered view"); $lbl = $statusbar->new_ttk__label(-text => "listed", @smallfont); $statusbar->add($lbl); Tkx::tooltip($lbl, "Number of packages in filtered view"); $lbl = $statusbar->new_ttk__label(-textvariable => \$NUM{'installed'}, @smallfont); $statusbar->add($lbl, -separator => 1); Tkx::tooltip($lbl, "Number of packages installed"); $lbl = $statusbar->new_ttk__label(-text => "installed,", @smallfont); $statusbar->add($lbl); Tkx::tooltip($lbl, "Number of packages installed"); $lbl = $statusbar->new_ttk__label(-textvariable => \$NUM{'install'}, @smallfont); $statusbar->add($lbl); Tkx::tooltip($lbl, "Number of packages selected for install"); $lbl = $statusbar->new_ttk__label(-text => "to install,", @smallfont); $statusbar->add($lbl); Tkx::tooltip($lbl, "Number of packages selected for install"); $lbl = $statusbar->new_ttk__label(-textvariable => \$NUM{'remove'}, @smallfont); $statusbar->add($lbl); Tkx::tooltip($lbl, "Number of packages selected for removal"); $lbl = $statusbar->new_ttk__label(-text => "to remove", -anchor => 'w', @smallfont); $statusbar->add($lbl); Tkx::tooltip($lbl, "Number of packages selected for removal"); $lbl = $statusbar->new_ttk__label(-text => "Install Area:", -anchor => 'e', @smallfont); $statusbar->add($lbl, -separator => 1); $lbl = $statusbar->new_ttk__label(-textvariable => \$INSTALL_AREA, @smallfontbold); $statusbar->add($lbl); my $progress = -1; my $progressbar = $statusbar->new_ttk__progressbar( -mode => "determinate", -variable => \$progress, -max => 1, -length => 80, ); $statusbar->add($statusbar->new_ttk__frame, -separator => 1, -weight => 10); #$statusbar->add($progressbar, -weight => 1); # Run preferences loading handler after UI has been instantiated on_load(); # map all view items, but only call one of the sort* view items map view($_), grep($_ ne "sortorder", keys %VIEW); Tkx::interp_alias("", "pkg_upgradable", "", [sub { my($name, $area, $repo_pkg_id) = @_; my $ret = eval { my $installed = $ppm->area($area)->package($name); my $available = $ppm->package($repo_pkg_id); $available->better_than($installed); }; if ($@) { ppm_log("WARN", $@); } return $ret || 0; # Tcl need a real zero }]); # Now let's get started ... Tkx::update('idletasks'); Tkx::after(idle => sub { $mw->g_wm_deiconify(); Tkx::focus(-force => $filter); full_refresh(1); }); Tkx::MainLoop(); 1; sub refresh { $pkglist->clear(); $NUM{'listed'} = 0; my $area = merge_area_items(); $NUM{'installed'} = $pkglist->numitems(); my $repo = merge_repo_items(); $NUM{'total'} = $pkglist->numitems(); %ACTION = (); $NUM{'install'} = 0; $NUM{'remove'} = 0; update_actions(); $pkglist->sort(); filter(1); $NUM{'listed'} = $pkglist->numitems('visible'); } sub repo_sync { my $sync = shift; if ($sync) { %REPOS = (); $ppm->repo_sync; } $repolist->clear() if $repolist; for my $repo_id ($ppm->repos) { my $repo = $REPOS{$repo_id} = $ppm->repo($repo_id); if ($repolist) { $repolist->add($repo_id, repo => $repo->{name}, url => $repo->{packlist_uri}, num => $repo->{pkgs}, checked => $repo->{packlist_last_access}, ); $repolist->enable($repo_id, $repo->{enabled}); } } } sub area_sync { $arealist->clear() if $arealist; for my $area_name ($ppm->areas) { my $area = $ppm->area($area_name); if ($arealist) { $arealist->add($area->name, num => scalar $area->packages, prefix => $area->prefix, inc => $area->inc, ); $arealist->state($area->name, "readonly") if $area->readonly || $area_name eq "perl"; } } my $i_area = $ppm->area($INSTALL_AREA); if (!$i_area || $i_area->readonly) { $INSTALL_AREA = $ppm->default_install_area || ""; } if ($INSTALL_AREA && $arealist) { $arealist->state($INSTALL_AREA, "default"); } } my %GRAB; sub set_focus_grab { my $grab = shift; my $focus = shift || $grab; my $oldGrab = $GRAB{$grab}{$focus}{'grab'} = Tkx::grab(current => $grab); $GRAB{$grab}{$focus}{'focus'} = Tkx::focus(); $GRAB{$grab}{$focus}{'status'} = Tkx::winfo_exists($oldGrab) ? Tkx::grab(status => $oldGrab) : ""; eval { Tkx::grab($grab); Tkx::focus($focus); }; } sub restore_focus_grab { my $grab = shift; my $focus = shift || $grab; Tkx::grab(release => $grab); return unless defined($GRAB{$grab}{$focus}{'grab'}); my $oldFocus = $GRAB{$grab}{$focus}{'focus'}; my $oldGrab = $GRAB{$grab}{$focus}{'grab'}; my $oldStatus = $GRAB{$grab}{$focus}{'status'}; if (Tkx::winfo_exists($oldFocus)) { Tkx::focus($oldFocus); } if (Tkx::winfo_exists($oldGrab) && Tkx::winfo_ismapped($oldGrab)) { if ($oldStatus eq "global") { Tkx::grab("-global", $oldGrab); } else { Tkx::grab($oldGrab); } } $GRAB{$grab}{$focus} = undef; } sub full_refresh { my $first_time = shift; my $activity = ppm_status("begin", "Synchronizing Database"); $mw->configure(-cursor => "watch"); Tkx::update(); set_focus_grab($status_box); if ($first_time && $ppm->config_get("gui.skip_initial_repo_sync")) { status_message("\nExternal repositories not synced. Press F5 for manual sync.\n"); repo_sync(); } else { repo_sync(1); } area_sync(); refresh(); $activity->end; $mw->configure(-cursor => ""); restore_focus_grab($status_box); if ($first_time && $INSTALL_AREA eq "") { my $msg = "All activated install areas are read-only. You cannot currently install or remove packages."; # do we have any uninitialized areas if (grep !$_->initialized, map $ppm->area($_), $ppm->areas) { $msg .= " Try enabling the uninitialized Areas in the Preferences dialog"; } Tkx::tk___messageBox( -title => "No writable installarea", -icon => "info", -type => "ok", -message => $msg, ); } } sub merge_area_items { my $count = 0; for my $area_name ($ppm->areas) { my $area = $ppm->area($area_name); my @fields = ("name", "version", "abstract", "author"); for my $pkg ($area->packages(@fields)) { for (@$pkg) { $_ = "" unless defined } # avoid "Use of uninitialized value" warnings my ($name, $version, $abstract, $author) = @$pkg; $pkglist->add($name, area => $area_name, installed => $version, abstract => $abstract, author => $author, ); $count++; } } return $count; } sub merge_repo_items { my @fields = ("id", "name", "version", "abstract", "author", "repo_id"); my @res = $ppm->packages(@fields); my $count = @res; for (@res) { for (@$_) { $_ = "" unless defined } # avoid "Use of uninitialized value" warnings my ($id, $name, $version, $abstract, $author, $repo_id) = @$_; $pkglist->add($name, repo_pkg_id => $id, repo => $REPOS{$repo_id}->{name} || $repo_id, available => $version, abstract => $abstract, author => $author, ); } return $count; } sub filter { my $force = shift || 0; Tkx::after('cancel', $FILTER{'id'}); return if !$force && $FILTER{'filter'} eq $FILTER{'lastfilter'} && $FILTER{'fields'} eq $FILTER{'lastfields'} && $FILTER{'type'} eq $FILTER{'lasttype'}; my $fields = $FILTER{'fields'}; $fields =~ s/ / or /g; Tkx::tooltip($filter, "Filter packages by $fields [${plat_acc_ctrl}F]"); my $count = $pkglist->filter($FILTER{'filter'}, fields => $FILTER{'fields'}, type => $FILTER{'type'}, ); if ($count == -1) { # Something wrong with the filter $filter->delete(0, "end"); $filter->insert(0, $FILTER{'lastfilter'}); # No need to refilter - should not have changed } else { $FILTER{'lastfilter'} = $FILTER{'filter'}; $FILTER{'lastfields'} = $FILTER{'fields'}; $FILTER{'lasttype'} = $FILTER{'type'}; $NUM{'listed'} = $count; } } sub filter_onkey { Tkx::after('cancel', $FILTER{'id'}); $FILTER{'id'} = Tkx::after($FILTER{'delay'}, [\&filter]); } sub ppm { my $func = shift; $ppm->$func(@_); } sub view { my $view = shift; if ($view =~ '^sort') { $pkglist->sort($VIEW{'sortcolumn'}, $VIEW{'sortorder'}); } elsif ($view =~ 'bar$') { my $w = ($view eq 'statusbar' ? $statusbar : $toolbar); if ($VIEW{$view}) { Tkx::grid($w); } else { Tkx::grid('remove', $w); } } else { $pkglist->view($view, $VIEW{$view}); } } sub verify { my $package = shift; my @areas = grep $_->initialized, map $ppm->area($_), $ppm->areas; if ($package) { @areas = grep $_->package_id($package), @areas; unless (@areas) { # can't happen status_message("Package '$package' is not installed\n"); return; } status_message("Verifying $package ...\n", "h2"); } else { status_message("Verifying all packages ...\n", "h2"); } my %status; for my $area (@areas) { my %s = $area->verify( package => $package, badfile_cb => sub { my $what = shift; if ($what eq "wrong_mode") { status_message(sprintf "%s: wrong mode %03o expected %03o\n", @_); } else { status_message("$_[0]: $what\n"); } }, ); while (my($k,$v) = each %s) { $status{$k} += $v; } } for my $v (qw(verified missing modified)) { next if $v ne "verified" && !$status{$v}; my $s = $status{$v} == 1 ? "" : "s"; status_message("$status{$v} file$s $v\n"); } } sub menus { Tkx::option_add("*Menu.tearOff", 0); my $menu = $mw->new_menu(); $mw->configure(-menu => $menu); my ($sm, $ssm); # File menu $sm = $file_menu = $menu->new_menu(-name => "file"); $menu->add_cascade(-label => "File", -menu => $sm, -underline => 0); $sm->add_command( -label => "Refresh All Data", -underline => 1, -accelerator => "F5", -command => sub { $sync_btn->invoke(); }, ); $sm->add_command( -label => "Verify Packages", -underline => 0, -command => [\&verify], ); $sm->add_command( -label => "Run Marked Actions", -underline => 0, -state => "disabled", -accelerator => "${plat_acc_ctrl}Enter", -command => sub { $go_btn->invoke(); }, ); $mw->g_bind("<>" => sub { $go_btn->invoke(); }); Tkx::event("add", "<>", "<${plat_evt_ctrl}Key-Return>", "<${plat_evt_ctrl}Key-KP_Enter>"); Tkx::bind(all => "<${plat_evt_ctrl}q>" => [\&on_exit]); if (!$AQUA) { $sm->add_separator(); $sm->add_command( -label => "Exit", -underline => 1, -accelerator => "${plat_acc_ctrl}Q", -command => [\&on_exit], ); } # Edit menu $sm = $menu->new_menu(-name => "edit"); $menu->add_cascade(-label => "Edit", -menu => $sm, -underline => 0); $sm->add_command( -label => "Cut", -underline => 2, -accelerator => "${plat_acc_ctrl}X", -command => sub { Tkx::event_generate(Tkx::focus(), "<>"); }, ); $sm->add_command( -label => "Copy", -underline => 0, -accelerator => "${plat_acc_ctrl}C", -command => sub { Tkx::event_generate(Tkx::focus(), "<>"); }, ); $sm->add_command( -label => "Paste", -underline => 0, -accelerator => "${plat_acc_ctrl}V", -command => sub { Tkx::event_generate(Tkx::focus(), "<>"); }, ); if (!$AQUA) { $sm->add_separator(); $sm->add_command( -label => "Preferences", -underline => 1, -accelerator => "${plat_acc_ctrl}P", -command => [\&show_prefs_dialog], ); } # View menu $sm = $view_menu = $menu->new_menu(-name => "view"); $menu->add_cascade(-label => "View", -menu => $sm, -underline => 0); $sm->add_checkbutton( -label => "Toolbar", -underline => 0, -variable => \$VIEW{'toolbar'}, -command => [\&view, 'toolbar'], ); $sm->add_checkbutton( -label => "Status Bar", -underline => 0, -variable => \$VIEW{'statusbar'}, -command => [\&view, 'statusbar'], ); $sm->add_separator(); $sm->add_radiobutton( -label => "All Packages", -underline => 0, -variable => \$FILTER{'type'}, -value => "all", -accelerator => "${plat_acc_ctrl}1", -command => [\&filter], ); $sm->add_radiobutton( -label => "Installed Packages", -underline => 0, -variable => \$FILTER{'type'}, -value => "installed", -accelerator => "${plat_acc_ctrl}2", -command => [\&filter], ); $sm->add_radiobutton( -label => "Upgradable Packages", -underline => 0, -variable => \$FILTER{'type'}, -value => "upgradable", -accelerator => "${plat_acc_ctrl}3", -command => [\&filter], ); # this text linked in update_actions for entryconfigure $sm->add_radiobutton( -label => "Packages to Install/Remove", -underline => 0, -variable => \$FILTER{'type'}, -value => "modified", -accelerator => "${plat_acc_ctrl}4", -command => [\&filter], ); $sm->add_separator(); $ssm = $sm->new_menu(-name => "text"); $sm->add_cascade(-label => "Text Size", -menu => $ssm, -underline => 7); # These commands rely on the internal bindings by style::as MouseWheel my $incr_text_cmd = sub { my $X = Tkx::winfo_rootx($pkglist); my $Y = Tkx::winfo_rooty($pkglist); Tkx::style__as__CtrlMouseWheel($pkglist, $X, $Y, 120, ""); }; my $decr_text_cmd = sub { my $X = Tkx::winfo_rootx($pkglist); my $Y = Tkx::winfo_rooty($pkglist); Tkx::style__as__CtrlMouseWheel($pkglist, $X, $Y, -120, ""); }; $ssm->add_command( -label => "Increase", -underline => 0, -accelerator => "${plat_acc_ctrl}+", -command => $incr_text_cmd, ); $ssm->add_command( -label => "Decrease", -underline => 0, -accelerator => "${plat_acc_ctrl}-", -command => $decr_text_cmd, ); if (0) { # style::as currently has no sense of "Normal", just relative $ssm->add_separator(); $ssm->add_command( -label => "Normal", -underline => 0, ); } # Use both equal and plus so users don't have to hit Shift on US kbds $mw->g_bind("<${plat_evt_ctrl}plus>" => $incr_text_cmd); $mw->g_bind("<${plat_evt_ctrl}equal>" => $incr_text_cmd); $mw->g_bind("<${plat_evt_ctrl}minus>" => $decr_text_cmd); $sm->add_separator(); $ssm = $fields_menu = $sm->new_menu(-name => "cols"); $sm->add_cascade(-label => "View Columns", -menu => $ssm, -underline => 5); $ssm->add_checkbutton( -label => "Area", -underline => 1, -variable => \$VIEW{'area'}, -command => [\&view, 'area'], ); $ssm->add_checkbutton( -label => "Installed", -underline => 0, -variable => \$VIEW{'installed'}, -command => [\&view, 'installed'], ); $ssm->add_checkbutton( -label => "Repo", -underline => 1, -variable => \$VIEW{'repo'}, -command => [\&view, 'repo'], ); $ssm->add_checkbutton( -label => "Available", -underline => 1, -variable => \$VIEW{'available'}, -command => [\&view, 'available'], ); $ssm->add_checkbutton( -label => "Abstract", -underline => 1, -variable => \$VIEW{'abstract'}, -command => [\&view, 'abstract'], ); $ssm->add_checkbutton( -label => "Author", -underline => 1, -variable => \$VIEW{'author'}, -command => [\&view, 'author'], ); $ssm = $sort_menu = $sm->new_menu(-name => "sort"); $sm->add_cascade(-label => "Sort Column", -menu => $ssm, -underline => 1); my @sort_opts = ( -variable => \$VIEW{'sortcolumn'}, -command => [\&view, 'sort'], ); $ssm->add_radiobutton( -label => "Package Name", -underline => 0, -value => 'name', @sort_opts, ); $ssm->add_radiobutton( -label => "Area", -underline => 1, -value => 'area', @sort_opts, ); $ssm->add_radiobutton( -label => "Installed", -underline => 0, -value => 'installed', @sort_opts, ); $ssm->add_radiobutton( -label => "Repo", -underline => 1, -value => 'repo', @sort_opts, ); $ssm->add_radiobutton( -label => "Available", -underline => 1, -value => 'available', @sort_opts, ); $ssm->add_radiobutton( -label => "Abstract", -underline => 1, -value => 'abstract', @sort_opts, ); $ssm->add_radiobutton( -label => "Author", -underline => 1, -value => 'author', @sort_opts, ); $ssm->add_separator(); @sort_opts = ( -variable => \$VIEW{'sortorder'}, -command => [\&view, 'sort'], ); $ssm->add_radiobutton( -label => "Ascending", -underline => 0, -value => '-increasing', @sort_opts, ); $ssm->add_radiobutton( -label => "Descending", -underline => 0, -value => '-decreasing', @sort_opts, ); if ($ENV{'ACTIVEPERL_PPM_DEBUG'}) { $sm->add_separator(); $sm->add_command( -label => "Debug Console", -command => sub { Tkx::catch("tkcon show"); }, ); } # Action menu $action_menu = $sm = $menu->new_menu(-name => "action"); $menu->add_cascade(-label => "Action", -menu => $sm, -underline => 0); $sm->add_command(-label => "No Selected Package", -state => "disabled"); # Help menu - name it help for special behavior, but not on OS X, where # that causes us to not get cascades allowed. my $mname = ($AQUA ? "nothelp" : "help"); $sm = $menu->new_menu(-name => $mname); $menu->add_cascade(-label => "Help", -menu => $sm, -underline => 0); if (ActiveState::Browser::can_open("faq/ActivePerl-faq2.html")) { my $help_cmd = [\&ActiveState::Browser::open, "faq/ActivePerl-faq2.html"]; $sm->add_command( -label => "Contents", -underline => 0, -accelerator => "", -command => $help_cmd, ); Tkx::bind("all", "", $help_cmd); } if (ActiveState::Browser::can_open("index.html")) { $sm->add_command( -label => "ActivePerl User Guide", -underline => 11, -command => [\&ActiveState::Browser::open, "index.html"], ); } if (ActiveState::Browser::can_open("http://www.activestate.com")) { my $web = $sm->new_menu(-tearoff => 0); $sm->add_cascade( -label => "Web Resources", -underline => 0, -menu => $web, ); $web->add_command( -label => "Report Bug", -command => [\&ActiveState::Browser::open, "http://bugs.activestate.com/enter_bug.cgi?set_product=ActivePerl"], ); $web->add_command( -label => "ActiveState Repository", -command => [\&ActiveState::Browser::open, "http://ppm.activestate.com/"], ); $web->add_command( -label => "ActivePerl Home", -command => [\&ActiveState::Browser::open, "http://www.activestate.com/Products/ActivePerl/"], ); $web->add_command( -label => "ActiveState Home", -command => [\&ActiveState::Browser::open, "http://www.activestate.com"], ); } if (!$AQUA) { $sm->add_separator; $sm->add_command( -label => "About", -underline => 0, -command => sub { about(); }, ); } # Special menu on OS X if ($AQUA) { $sm = $menu->new_menu(-name => 'apple'); # must be named "apple" $menu->add_cascade(-label => "PPM", -menu => $sm); $sm->add_command( -label => "About PPM", -command => sub { about(); }, ); $sm->add_separator(); # OS X enables the Preferences item when you create this proc Tkx::proc("tk::mac::ShowPreferences", "args", [\&show_prefs_dialog]); Tkx::bind(all => "", "tk::mac::ShowPreferences"); } return $menu; } sub select_item { my $item = shift; $details->configure(-state => "normal"); $details->delete('1.0', 'end'); $details->configure(-state => "disabled"); my $menu = $action_menu; $menu->delete(0, 'end'); $menu->add_command(-label => "No selected package", -state => "disabled"); return unless $item; # We need to figure out how we want details formatted my %data = Tkx::SplitList($pkglist->data($item)); my $name = $data{'name'}; my $areaid = $data{'area'}; my $area = $ppm->area($areaid) if $areaid; my ($pkg, $repo_pkg); $pkg = $repo_pkg = $ppm->package($data{'repo_pkg_id'}); if ($areaid) { if (my $p = $area->package($name)) { $pkg = $p; } } return unless $pkg; my $pad = "\t"; $details->configure(-state => "normal"); $details->insert('1.0', "$pkg->{name}\n", 'h1'); $details->insert('end', "$pkg->{abstract}\n", 'abstract') if $pkg->{abstract}; $details->insert('end', "${pad}Version:\t$pkg->{version}\n"); if (my $date = $pkg->{release_date}) { $date =~ s/ .*//; # drop time $details->insert('end', "${pad}Released:\t$date\n"); } $details->insert('end', "${pad}Author:\t$pkg->{author}\n") if $pkg->{author}; if (my $name = is_cpan_package($pkg->{name})) { my $v = $pkg->{version}; $v =~ s/-r\d+$//; my $cpan_url = "http://search.cpan.org/dist/$name-$v/"; if ($pkg->{name} eq "Perl") { $cpan_url = sprintf "http://search.cpan.org/dist/perl-%vd", $^V; } $details->insert('end', "${pad}CPAN:\t"); if (ActiveState::Browser::can_open($cpan_url)) { $details->insert('end', $cpan_url, "link"); $details->tag_bind('link', "", [ \&ActiveState::Browser::open, $cpan_url ]); } else { $details->insert('end', $cpan_url); } $details->insert('end', "\n"); } if ($areaid) { $details->insert('end', "\nInstalled files:\n", 'h2'); for my $file ($area->package_files($pkg->{id})) { $details->insert('end', "\t$file\n"); } } # Remove trailing newline and prevent editing of widget $details->delete('end-1c'); $details->configure(-state => "disabled"); $pw_nb->select($details_sw); ## Record "allowable" actions based on package info # XXX work on constraints unless ($ACTION{$item}) { $ACTION{$item}{'install'} = 0; $ACTION{$item}{'remove'} = 0; $ACTION{$item}{'area'} = $area; $ACTION{$item}{'pkg'} = $pkg; $ACTION{$item}{'repo_pkg'} = $repo_pkg; $ACTION{$item}{'deps'} = []; } # The icon represents the current actionable state: # default installed upgradable install remove upgrade $remove_btn->configure(-state => "disabled", -variable => \$dummy); $install_btn->configure(-state => "disabled", -variable => \$dummy); $menu->delete(0, 'end'); my ($txt, $cmd); if ($data{'installed'}) { # installed items are removable $txt = "Remove $name $data{'installed'}"; if ($data{'area'} && (($data{'area'} eq "perl") || $ppm->area($data{'area'})->readonly)) { # perl area items should not be removed $menu->add_command(-label => $txt, -state => "disabled", -accelerator => '-'); } else { $cmd = sub { queue_action($item, $name, "remove"); }; $remove_btn->configure( -state => "normal", -command => $cmd, -variable => \$ACTION{$item}{'remove'}, ); $menu->add_checkbutton( -label => $txt, -command => $cmd, -variable => \$ACTION{$item}{'remove'}, -accelerator => '-', ); } } if ($data{'available'}) { # available items are installable if ($data{'available'} eq $data{'installed'}) { $txt = "Reinstall $name $data{'available'}"; } else { $txt = "Install $name $data{'available'}"; } if (!$INSTALL_AREA || $INSTALL_AREA eq "perl" || $ppm->area($INSTALL_AREA)->readonly) { $menu->add_command(-label => $txt, -state => "disabled", -accelerator => '+'); } else { $cmd = sub { queue_action($item, $name, "install"); }; $install_btn->configure( -state => "normal", -command => $cmd, -variable => \$ACTION{$item}{'install'}, ); $menu->add_checkbutton( -label => $txt, -command => $cmd, -variable => \$ACTION{$item}{'install'}, -accelerator => '+', ); } } if (!$data{'available'} && !$data{'installed'}) { # Oddball packages that have no version? $menu->add_command(-label => $name, -state => "disabled"); } if ($data{'installed'}) { # Add "Verify" action $menu->add_separator(); $menu->add_command( -label => "Verify $name $data{'installed'}", -command => [\&verify, $name], ); } } sub queue_action { my ($item, $name, $action) = @_; my $altact = ($action eq "install") ? "remove" : "install"; if ($ACTION{$item}{'remove'} && $ACTION{$item}{'install'}) { # only allow install OR remove, not both. $ACTION{$item}{$altact} = 0; $pkglist->state($item, "!$altact"); $NUM{$altact}--; status_message("$name unmarked for $altact\n"); } if ($ACTION{$item}{$action}) { $pkglist->state($item, $action); $NUM{$action}++; status_message("$name marked for $action\n"); } else { $pkglist->state($item, "!$action"); $NUM{$action}--; status_message("$name unmarked for $action\n"); } if ($ACTION{$item}{'install'}) { # Figure out what dependent modules are required my $repo_pkg = $ACTION{$item}{'repo_pkg'}; my @pkgs = map $ACTION{$_}{'repo_pkg'}, grep($ACTION{$_}{'install'}, keys %ACTION); if (my $err = $ppm->is_downgrade($repo_pkg)) { ppm_log("WARN", $err); status_message("\nWARNING: $err\n\n", "abstract"); } my @tmp = $ppm->packages_missing( have => \@pkgs, want_deps => [$repo_pkg], error_handler => sub { status_message("\nWARNING: $_\n\n", "abstract") for @_; }, ); my @need; for my $pkg (@tmp) { status_message("$repo_pkg->{name} depends on $pkg->{name}\n", "abstract"); push(@need, $pkg); } $ACTION{$item}{'deps'} = \@need; } if ($ACTION{$item}{'remove'}) { # Find out if removing this breaks dependencies my $name = $ACTION{$item}{'pkg'}->name; my @deps = $ppm->packages_depending_on($ACTION{$item}{'pkg'}, $ACTION{$item}{'area'}); $ACTION{$item}{'deps'} = \@deps; if (@deps) { my @dep_names = map $_->{name}, @deps; my $s = @dep_names == 1 ? "s" : ""; status_message("\nWARNING: " . join_with("and", sort @dep_names) . " depend$s on $name to be available\n\n", "abstract"); } } update_actions(); } sub update_actions { if ($NUM{'install'} || $NUM{'remove'}) { $go_btn->configure(-state => "normal"); $file_menu->entryconfigure("Run Marked Actions", -state => "normal"); $filter_mod->configure(-state => "normal"); $view_menu->entryconfigure("Packages to Install/Remove", -state => "normal", ); } else { $go_btn->configure(-state => "disabled"); $file_menu->entryconfigure("Run Marked Actions", -state => "disabled"); $filter_mod->configure(-state => "disabled"); $view_menu->entryconfigure("Packages to Install/Remove", -state => "disabled", ); } } sub run_actions { my $msg = "Ready to "; if ($NUM{'install'}) { $msg .= "install $NUM{'install'} package"; $msg .= "s" if $NUM{'install'} > 1; } if ($NUM{'remove'}) { $msg .= " and " if $NUM{'install'}; $msg .= "remove $NUM{'remove'} package"; $msg .= "s" if $NUM{'remove'} > 1; } $msg .= "?"; my @items = grep($ACTION{$_}{'install'} && @{$ACTION{$_}{'deps'}}, keys %ACTION); if (@items) { my $dep_cnt = 0; for my $item (@items) { my $repo_pkg = $ACTION{$item}{'repo_pkg'}; for my $pkg (@{$ACTION{$item}{'deps'}}) { $dep_cnt++; } } $msg .= "\nPPM will install $dep_cnt additional prerequisite packages."; } @items = grep($ACTION{$_}{'remove'} && @{$ACTION{$_}{'deps'}}, keys %ACTION); if (@items) { my $dep_cnt = 0; for my $item (@items) { my $name = $ACTION{$item}{'pkg'}->name; for my $pkg (@{$ACTION{$item}{'deps'}}) { $dep_cnt++; } } $msg .= "\n$dep_cnt dependent packages may become unusable."; } my $res = Tkx::tk___messageBox( -title => "Commit Actions?", -type => "okcancel", -parent => $mw, -icon => "question", -message => $msg, ); if ($res eq "ok") { commit_actions(); } } sub commit_actions { my $removed; for my $item (sort keys %ACTION) { # First remove any area pacakges if ($ACTION{$item}{'remove'}) { my $name = $pkglist->data($item, "name"); my $area = $ACTION{$item}{'area'}; my $area_name = $area->name; my $activity = ppm_status("begin", "Removing $name from $area_name area"); eval { my $pkg = $area->package($name); die "$name not installed in area $area_name" unless $pkg; $pkg->run_script("uninstall", $area, undef, { old_version => $pkg->{version}, packlist => $area->package_packlist($pkg->{id}), }, \&run_cmd); $area->uninstall($name); }; if ($@) { { local $@; $activity->end("failed"); } status_error(); return; } else { $removed++; } } } my @install_pkgs = map($ACTION{$_}{'repo_pkg'}, grep($ACTION{$_}{'install'}, keys %ACTION)); if (@install_pkgs) { eval { my @need = $ppm->packages_missing( have => \@install_pkgs, want_deps => \@install_pkgs, force => 1, # dependency warnings already displayed ); push(@install_pkgs, grep !$_->has_script("install"), @need); }; if ($@) { status_error(); } my $what = @install_pkgs > 1 ? (@install_pkgs . " packages") : "package"; my $activity = ppm_status("begin", "Installing $what"); eval { $ppm->install( area => $INSTALL_AREA, packages => \@install_pkgs, run_cb => \&run_cmd, ); }; if ($@) { { local $@; $activity->end("failed"); } status_error(); return; } } elsif ($removed) { update_html_toc(); } # Don't remain in "upgradable" or "modified" filter state $FILTER{'type'} = "installed" unless $FILTER{'type'} eq "all"; refresh(); } sub run_cmd { my @cmds = @_; my $ignore_err = $cmds[0] =~ s/^-//; if ($cmds[0] =~ s/^\s*\@(-)?//) { $ignore_err = 1 if $1; } #status_message("\n @_\n"); my $null = devnull(); $cmds[0] =~ s,\\,/,g; my $fh = Tkx::open("| @cmds <$null 2>\@1"); Tkx::fconfigure($fh, -blocking => 0); Tkx::fileevent($fh, readable => [\&run_watch, $fh]); # wait for the file to be closed before we return Tkx::vwait("run_done"); } sub run_watch { my $fh = shift; my($buf, $n); eval { $n = Tkx::gets($fh, \$buf); }; if ($@) { eval { Tkx::close($fh); }; Tkx::set(run_done => 1); return; } if ($n == -1) { if (Tkx::eof($fh)) { eval {Tkx::close($fh);}; Tkx::set(run_done => 1); } return; } status_message(" | $buf\n"); } sub select_repo_item { my $item = shift; return unless $item; my $what = shift || ""; my %data = Tkx::SplitList($repolist->data($item)); # We need to figure out how we want details formatted if ($what eq "remove") { my $msg = "Really remove $data{repo} repository?" . "\nDisabling a repository has the same effect" . "\nwithout losing its name or location."; my $res = Tkx::tk___messageBox( -title => "Remove Repository?", -icon => "warning", -type => "yesno", -message => $msg, -parent => $prefs_dialog, ); return unless $res eq "yes"; $ppm->repo_delete($data{id}); full_refresh(); return; } if ($what eq "enable") { my $state = $repolist->enable($data{id}); $state = $ppm->repo_enable($data{id}, $state); # feed back result, in case we aren't allowed to change state $repolist->enable($data{id}, $state); full_refresh(); return; } if ($what eq "setname") { my $newname = shift; $ppm->repo_set_name($data{id}, $newname); return; } if ($what eq "seturl") { my $newurl = shift; eval { $ppm->repo_set_packlist_uri($data{id}, $newurl); }; if ($@) { status_error("modifying repository URI"); } else { full_refresh(); } return; } }; sub select_area_item { my $item = shift; return unless $item; my $what = shift || ""; my %data = Tkx::SplitList($arealist->data($item)); if ($what eq "default") { if (!$ppm->area($data{name})->initialized) { my $res = Tkx::tk___messageBox( -title => "Initialize Area $data{name}?", -message => "Should PPM start tracking packages in $data{name}?", -type => "okcancel", -icon => "question", ); if ($res eq "ok") { eval { $ppm->area($data{name})->initialize(); }; if ($@) { status_error("initializing $data{name} area"); } elsif (!$ppm->area($data{name})->readonly) { $arealist->state($data{name}, "!readonly"); } } } if ($data{name} eq "perl" || $ppm->area($data{name})->readonly) { Tkx::bell(); return; } eval { $arealist->state($INSTALL_AREA, "!default"); }; $INSTALL_AREA = $data{name}; $arealist->state($INSTALL_AREA, "default"); } } sub show_prefs_dialog { if ($prefs_dialog && Tkx::winfo_exists($prefs_dialog)) { $prefs_dialog->display(); Tkx::focus(-force => $prefs_dialog); return; } my $top = $prefs_dialog = $mw->new_widget__dialog( -title => 'PPM Preferences', -padding => 4, -parent => $mw, -place => 'over', -type => 'ok', -modal => 'none', -synchronous => 0, -separator => 0, ); # Preferences tabs my $nb = $top->new_ttk__notebook(); Tkx::ttk__notebook__enableTraversal($nb); $top->setwidget($nb); my ($f, $sw); # Areas tab $f = $nb->new_ttk__frame(-padding => 8); $nb->add($f, -text => "Areas", -underline => 0); # Select this tab as default $nb->select($f); $sw = $f->new_widget__scrolledwindow(); $arealist = $sw->new_arealist( -width => 450, -height => 100, -selectcommand => [\&select_area_item], -borderwidth => 1, -relief => 'sunken', -itembackground => ["#F7F7FF", ""], ); $sw->setwidget($arealist); my $areal = $f->new_widget__panelframe(-text => "Add Area:"); my $areaf = $areal->new_ttk__frame(-padding => [6, 2]); $areal->setwidget($areaf); Tkx::grid(columnconfigure => $areaf, 0, -weight => 1); Tkx::grid($sw, -sticky => 'news'); #Tkx::grid($areal, -sticky => 'news', -pady => [4, 0]); Tkx::grid(columnconfigure => $f, 0, -weight => 1); Tkx::grid(rowconfigure => $f, 0, -weight => 1); # Repositories tab $f = $nb->new_ttk__frame(-padding => 8); $nb->add($f, -text => "Repositories", -underline => 0); $sw = $f->new_widget__scrolledwindow(); $repolist = $sw->new_repolist( -width => 450, -height => 100, -selectcommand => [\&select_repo_item], -borderwidth => 1, -relief => 'sunken', -itembackground => ["#F7F7FF", ""], ); $sw->setwidget($repolist); my $addl = $f->new_widget__panelframe(-text => "Add Repository:"); my $addf = $addl->new_ttk__frame(-padding => [6, 2]); $addl->setwidget($addf); my $name_var = ""; my $uri_var = ""; my $sug_repo_var = ""; my ($rnamel, $rnamee, $rlocnl, $rlocne); my $val_cmd = sub { my ($peek, $w) = @_; my $state = $peek ? "!invalid" : "invalid"; $w->state($state); return 1; }; $rnamel = $addf->new_ttk__label(-text => "Name:", -anchor => 'w'); $rnamee = $addf->new_ttk__entry( -textvariable => \$name_var, -validate => "all", -validatecommand => [$val_cmd, Tkx::Ev('%P'), $rnamel], ); $rlocnl = $addf->new_ttk__label(-text => "Location:", -anchor => 'w'); $rlocne = $addf->new_ttk__entry( -textvariable => \$uri_var, -validate => "all", -validatecommand => [$val_cmd, Tkx::Ev('%P'), $rlocnl], ); $rnamel->state("invalid"); $rlocnl->state("invalid"); my $lastdir = cwd(); my $dircmd = sub { my $dir = Tkx::tk___chooseDirectory( -title => "Repository Directory", -initialdir => $lastdir, -parent => $top, -mustexist => 1, ); if ($dir) { $uri_var = $lastdir = $dir; $rlocne->selection_clear(); $rlocne->icursor("end"); $rlocne->g_focus(); } }; my $dir_btn = $addf->new_ttk__button( -image => [Tkx::ppm__img('dir')], -command => $dircmd, ); my $add_sub = sub { return unless $name_var && $uri_var; # This requires duplication of code from do_repo if ($uri_var =~ m,\?urn:/,) { Tkx::tk___messageBox( -title => "Error Adding Repository", -message => "PPM3 SOAP repositories are not supported.", -type => "ok", -icon => "error", ); return; } if (-d $uri_var) { require URI::file; $uri_var = URI::file->new_abs($uri_var); } ($uri_var, my $uri_noarch) = split /\0/, $uri_var; eval { $ppm->repo_add(name => $name_var, packlist_uri => $uri_var); }; if ($uri_noarch && !$@) { eval { $ppm->repo_add(name => "$name_var-noarch", packlist_uri => $uri_noarch); }; } if ($@) { ppm_log("ERR", "Adding repository: $@"); Tkx::tk___messageBox( -title => "Error Adding Repository", -message => "Error adding repository:\n" . clean_err($@), -type => "ok", -icon => "error", ); } else { $name_var = ""; $uri_var = ""; $rnamel->state("invalid"); $rlocnl->state("invalid"); full_refresh(); } }; my $save_btn = $addf->new_ttk__button( -text => "Add", -command => $add_sub, ); my $ret_cmd = sub { my $next = shift; if ($name_var && $uri_var) { # Do add $save_btn->invoke(); } else { Tkx::focus($next); } }; $rnamee->g_bind("", [$ret_cmd, $rlocne]); $rlocne->g_bind("", [$ret_cmd, $rnamee]); my @repos; my $rsuglbl = $addf->new_ttk__label( -text => "Suggested:", ); my $rsugbox = $addf->new_ttk__combobox( -textvariable => \$sug_repo_var, -state => "readonly", ); eval { require PPM::Repositories; require ActivePerl; }; if ($@) { $rsugbox->set("Install PPM-Repositories"); $rsugbox->configure(-values => [], -state => "disabled"); } else { if (defined &PPM::Repositories::list) { for my $name (PPM::Repositories::list()) { # XXX Why don't we allow re-adding the ActiveState repo here? next if $name eq "activestate"; my %repo = PPM::Repositories::get($name); push(@repos, "$name :: $repo{desc}"); } $rsugbox->set("Select from list ..."); $rsugbox->configure(-values => [@repos], -state => "readonly"); my $rsugbox_cmd = sub { return unless defined &PPM::Repositories::get; return unless $sug_repo_var; $name_var = $sug_repo_var; $name_var =~ s/ ::.*$//; my %repo = PPM::Repositories::get($name_var); $uri_var = $repo{packlist} || $repo{packlist_noarch}; if ($repo{packlist_noarch} && $repo{packlist_noarch} ne $uri_var) { $uri_var .= "\0$repo{packlist_noarch}"; } }; Tkx::bind($rsugbox, "<>", $rsugbox_cmd); } else { for my $id (sort keys %PPM::Repositories::Repositories) { my $repo = $PPM::Repositories::Repositories{$id}; next unless $repo->{Active}; next if $repo->{Type} eq "PPMServer"; my $o = $repo->{PerlO} || []; next if @$o && !grep $_ eq $^O, @$o; my $v = $repo->{PerlV} || []; my $my_v = ActivePerl::perl_version; next if @$v && !grep $my_v =~ /^\Q$_\E\b/, @$v; push(@repos, "$id :: $repo->{Notes}"); } $rsugbox->set("Select from list ..."); $rsugbox->configure(-values => [@repos], -state => "readonly"); my $rsugbox_cmd = sub { return unless defined(%PPM::Repositories::Repositories); return unless $sug_repo_var; $name_var = $sug_repo_var; $name_var =~ s/ ::.*$//; $uri_var = $PPM::Repositories::Repositories{$name_var}->{location}; }; Tkx::bind($rsugbox, "<>", $rsugbox_cmd); } } Tkx::grid($rnamel, $rnamee, "-", "-", -sticky => 'ew', -padx => 1, -pady => 1 ); Tkx::grid($rlocnl, $rlocne, "-", $dir_btn, -sticky => 'ew', -padx => 1, -pady => 1, ); Tkx::grid($rsuglbl, $rsugbox, $save_btn, "-", -sticky => 'ew', -padx => 1, -pady => 1, ); Tkx::grid(configure => $save_btn, -padx => [20, 1]); Tkx::grid(columnconfigure => $addf, 1, -weight => 1, -minsize => 20); Tkx::grid($sw, -sticky => 'news'); Tkx::grid($addl, -sticky => 'news', -pady => [4, 0]); Tkx::grid(columnconfigure => $f, 0, -weight => 1); Tkx::grid(rowconfigure => $f, 0, -weight => 1); repo_sync(0); # refresh without sync/clear area_sync(); $prefs_dialog->display(); Tkx::focus(-force => $prefs_dialog); } sub on_load { # Restore state from saved information # We would need to make sure these are reflected in UI elements #$FILTER{'filter'} = $ppm->config_get("gui.filter") || ""; $FILTER{'fields'} = $ppm->config_get("gui.filter.fields") || "name abstract"; $FILTER{'type'} = $ppm->config_get("gui.filter.type") || "installed"; $INSTALL_AREA = $ppm->config_get("gui.install_area") || $ppm->default_install_area; my @view_keys = keys %VIEW; my @view_vals = $ppm->config_get(map "gui.view.$_", @view_keys); while (@view_keys) { my $k = shift @view_keys; my $v = shift @view_vals; $VIEW{$k} = $v if defined $v; } } sub on_exit { # We should save dialog and other state information ## Window location and size $ppm->config_save("gui.geometry", $mw->g_wm_geometry); ## Current filter $ppm->config_save( "gui.filter" => $FILTER{'lastfilter'}, "gui.filter.fields" => $FILTER{'lastfields'}, "gui.filter.type" => ($FILTER{'lasttype'} eq 'modified' ? "all" : $FILTER{'lasttype'}), ); ## Current selected package? ## Current install area $ppm->config_save("gui.install_area", $INSTALL_AREA || ""); ## Tree column order, widths, visibility, sort # this gets columns in current order (visible and not) my @cols = $pkglist->column('list'); for my $col (@cols) { #my $width = $pkglist->column('width', $col); } $ppm->config_save(map { ("gui.view.$_" => $VIEW{$_}) } keys %VIEW); exit; } sub about { require ActivePerl::PPM; require ActivePerl; my $perl_version = ActivePerl::perl_version; Tkx::tk___messageBox( -title => "About Perl Package Manager", -icon => "info", -type => "ok", -message => "PPM version $ActivePerl::PPM::VERSION ActivePerl version $perl_version \xA9 2007 ActiveState Software Inc.", ); } sub status_error { my $context = shift; my $err; if (@_) { $err = shift; ppm_log("ERR", $context ? "$context: $err" : $err); } elsif ($@) { $err = $@; ppm_log("ERR", $context ? "$context: $err" : $err); $err = clean_err($err); } if ($context) { status_message("\nERROR $context:\n\t$err\n", "abstract"); } else { status_message("\nERROR: $err\n", "abstract"); } } sub status_message { if ($pw_nb && $status_box) { $pw_nb->select($status_sw); $status_box->configure(-state => "normal"); $status_box->insert("end", @_); $status_box->configure(-state => "disabled"); $status_box->see("end"); Tkx::update('idletasks'); } else { push(@pending_status_message, [@_]); } if ($ENV{'ACTIVEPERL_PPM_DEBUG'}) { print $_[0]; } } BEGIN { package ActivePerl::PPM::GUI::Status; require ActivePerl::PPM::Status; our @ISA = qw(ActivePerl::PPM::Status); my $prefixed; sub begin { my $self = shift; my $what = shift; my $depth = $self->depth; ActivePerl::PPM::GUI::status_message("\n") if $prefixed; my $indent = " " x $depth; ActivePerl::PPM::GUI::status_message("$indent$what ... ", ($depth == 0 ? "h2" : "")); $prefixed = 1; $self->SUPER::begin($what, @_); } sub tick { my $self = shift; if (@_) { # update the progressbar $progress = shift; if (defined($progressbar) && !Tkx::winfo_ismapped($progressbar)) { # This works as progressbar should be last element $statusbar->add($progressbar, -weight => 1); } } Tkx::update('idletasks'); if ($ENV{'ACTIVEPERL_PPM_DEBUG'}) { print "#"; } } sub end { my $self = shift; my $outcome = shift || "done"; my $what = $self->SUPER::end; my $depth = $self->depth; unless ($prefixed) { my $indent = " " x $depth; $outcome = "$indent$what $outcome" unless $prefixed; } ActivePerl::PPM::GUI::status_message("$outcome\n", ($depth == 0 ? "h2" : "")); $prefixed = 0; $progress = -1; if (defined($progressbar) && Tkx::winfo_ismapped($progressbar)) { $statusbar->remove($progressbar); } } }