#!perl use strict; #use warnings; use Tk; use PPM; use Tk::MListbox; require Tk::DialogBox; require Tk::BrowseEntry; require Tk::LabEntry; use CPAN; eval {require PPM::Compat;}; my $ppmv = $@ ? 2 : 3; our ($type, $message, $no_case, $save, $repository, $VERSION); $type = 'Package'; $no_case = 1; $save = 1; $VERSION = 0.25; 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', )->pack(-side => 'left'); help_msg($package, 'Treat search term as a package name'); my $abstract = $options->Radiobutton(-text => 'Abstract', -variable => \$type, -value => 'ABSTRACT', )->pack(-side => 'left'); help_msg($abstract, 'Treat search term as part of the abstract'); my $author = $options->Radiobutton(-text => 'Author', -variable => \$type, -value => 'AUTHOR', )->pack(-side => 'left'); help_msg($author, 'Treat search term as an author name'); my $module = $options->Radiobutton(-text => 'Module', -variable => \$type, -value => 'Module', )->pack(-side => 'left'); help_msg($module, 'Treat search term as an (exact) 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('', [\&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 $inst = $top->Button(-text => 'Install', -command => [\&ppminstall_search], )->pack(-side => 'left', -padx => 10, -pady => 5); help_msg($inst, 'Search for and install a package'); 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 => 10, -pady => 5); help_msg($cb_case, 'Perform case sensitive/insensitive 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('', [\&display_info, 'local']); $local->bindRows('', [\&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'); 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('', [\&display_info]); $rep->bindRows('', [\&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 $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 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 = 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') { my $dist = mod_to_dist($RE); unless ($dist) { $error = qq{Could not find a distribution containing "$RE"}; return; } $RE = "^$dist\$"; $type = 'Package'; } else { if ($args{exact}) { $RE = "^$RE\$"; } else { $RE = "(?i)$RE" if ($no_case == 1); } } return $RE; } sub search_tag { return ($type eq 'AUTHOR' or $type eq 'ABSTRACT') ? $type : undef; } sub query { my $RE = search_term(all => 1); my $searchtag = search_tag(); unless ($RE) { dialog_error('Invalid search term', q{Could not perform the search.}); return; } 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; unless ($packages = search_for($searchRE) ) { dialog_error('No results found', qq{Search failed.}); return; } $rep->delete(0, 'end'); populate($packages->{$_}, $_) foreach (keys %$packages); } 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, fix_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 fix_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 $version = 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_search { my $searchtag = search_tag(); if ($searchtag and ($searchtag eq 'AUTHOR' or $searchtag eq 'ABSTRACT')) { dialog_error('Cannot install', qq{Cannot install "AUTHORS" or "ABSTRACTS"}); return; } my $searchRE; unless ($searchRE = search_term(exact => 1)) { dialog_error('Invalid search term', q{Could not perform the search.}); return; } my $packages; unless ($packages = search_for($searchRE) ) { dialog_error('No results found', qq{Search failed.}); return; } my @locs = keys %$packages; my @packs = keys %{$packages->{$locs[0]}}; ppminstall($packs[0], $locs[0], $packages->{$locs[0]}->{$packs[0]}->{version}); } sub ppminstall { my ($package, $location, $version) = @_; return unless ($package); my %installed = InstalledPackageProperties(); if (my $pkg = (grep {/^$package$/i} keys %installed)[0]) { my $version = fix_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 $version = fix_version($info->{$package}->{local}->{version}); my $index = 'end'; my $version = fix_version($info->{$package}->{local}->{version}); if ($index = get_index($package, $local)) { $local->delete($index); } $index ||= 'end'; $local->insert($index, [$package, $version]); } 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 => 2, -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 => 3, -pady => 10, -sticky => 'w', -padx => 5); $reps->Button( -text => 'New', -command => [\&new_rep, $reps], )->grid(-row => 2, -pady => 10, -padx => 10, -column => 1, -sticky => 'e'); $reps->Button( -text => 'Delete', -command => [\&del_rep, $reps, \$rep], )->grid(-row => 2, -pady => 10, -padx => 10, -column => 2, -sticky => 'w'); $reps->Checkbutton(-text => 'save changes', -variable => \$save, -onvalue => 1, -offvalue => 0, ) ->grid(-row => 2, -column => 0, -pady => 5, -sticky => 'e'); $reps->Button( -text => 'Close', -command => [ $reps => 'destroy'], )->grid(-row => 2, -pady => 10, -ipadx => 5, -padx => 10, -column => 3, -sticky => 'e'); } 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 populate { my ($data, $where) = @_; foreach my $package (sort keys %{$data}) { my $author = $data->{$package}->{AUTHOR}; my $version = fix_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->insert('end', [$package, $version]); } else { $rep->insert('end', [$package, $version, $alias{$where}]); } } } sub fix_version { local $_ = shift; s/(,0)*$//; tr/,/./; return $_; } sub trim { local $_ = shift; s/^\s*//; s/\s*$//; return $_; } 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 = fix_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('', [sub {$message = $_[1]; }, $msg]); $widget->bind('', [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; } sub mod_to_dist { my $mod = shift; my $ext = qr{\.(tar\.gz|tgz|tar\.Z|zip)}; $mod =~ s!-!::!g; msg_update(qq{Searching CPAN database for "$mod" - please wait ...}); my $module = CPAN::Shell->expand('Module', $mod); return unless $module; (my $file = $module->cpan_file) =~ s!.*/(.*)$ext!$1!; my ($dist, $version) = version($file); msg_update(qq{Done!}); return ($dist and $version) ? $dist : undef; } sub version { local ($_) = @_; # remove alpha/beta postfix s/([-_\d])(a|b|alpha|beta|src)$/$1/; # jperl1.3@4.019.tar.gz s/@\d.\d+//; # oraperl-v2.4-gk.tar.gz s/-v(\d)/$1/; # lettered versions - shudder s/([-_\d\.])([a-z])([\d\._])/sprintf "$1%02d$3", ord(lc $2) - ord('a') /ei; s/([-_\d\.])([a-z])$/sprintf "$1%02d", ord(lc $2) - ord('a') /ei; # thanks libwww-5b12 ;-) s/(\d+)b/($1-1).'.'/e; s/(\d+)a/($1-2).'.'/e; # replace '-pre' by '0.' s/-pre([\.\d])/-0.$1/; s/\.\././g; s/(\d)_(\d)/$1$2/g; # chop '[-.]' and thelike s/\W$//; # ram's versions Storable-0.4@p s/\@/./; if (s/[-_]?(\d+)\.(0\d+)\.(\d+)$//) { return($_, $1 + "0.$2" + $3 / 1000000); } elsif (s/[-_]?(\d+)\.(\d+)\.(\d+)$//) { return($_, $1 + $2/1000 + $3 / 1000000); } elsif (s/[-_]?(\d+\.[\d_]+)$//) { return($_, $1); } elsif (s/[-_]?([\d_]+)$//) { return($_, $1); } elsif (s/-(\d+.\d+)-/-/) { # perl-4.019-ref-guide return($_, $1); } else { if ($_ =~ /\d/) { # smells like an unknown scheme #warn "Odd version Numbering: $_ \n"; return($_, undef); } else { # assume version 0 #warn "No version Numbering: $_ \n"; return($_, 0); } } } __END__ =head1 NAME tk-ppm - Tk interface to the ppm utility =head1 SYNOPSIS C:\> perl tk-ppm or, first making a C 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 will bring up a main window through which one can do many of the operations of the command-line based C 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). =item * install packages from remote repositories. =item * add or delete entries from the list of repositories. =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 utility. =head1 PREREQUISITES This script requires C, C, C, and C. The C module must be first configured. =head1 OSNAMES any =head1 SEE ALSO L and L. =head1 COPYRIGHT This script is copyright (c) 2003 by Randy Kobes (Erandy@theory.uwinnipeg.caE). All rights reserved. You may use and distribute this code under the same terms as Perl itself. =head1 SCRIPT CATEGORIES Win32 =cut =cut