Commit c5c4d9b2 authored by Stefan Tauner's avatar Stefan Tauner
Browse files

DialogBoxUL: add support for keyboard accelerators

This patch adds support for key accelerators and -underline.
It parses the given button labels for ~, underlines the character
following it, and adds a binding of <Alt-character> for the
respective button. Strings for labels are cleaned of any ~ which
has the potential for regressions.
parent a64cb30d
......@@ -13,7 +13,7 @@ use strict;
use Carp;
use vars qw($VERSION);
$VERSION = '4.016'; # was: sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/;
$VERSION = '4.017'; # was: sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/;
use base qw(Tk::Toplevel);
......@@ -24,12 +24,13 @@ sub Populate {
$cw->SUPER::Populate($args);
my $buttons = delete $args->{'-buttons'};
$buttons = ['OK'] unless defined $buttons;
$buttons = ['~OK'] unless defined $buttons;
my $bl0 = ($buttons->[0] =~ tr/~//dr);
my $default_button = delete $args->{'-default_button'};
$default_button = $buttons->[0] unless defined $default_button;
$default_button = $bl0 unless defined $default_button;
my $cancel_button = delete $args->{'-cancel_button'};
if (!$cancel_button && @$buttons == 1) {
$cancel_button = $buttons->[0];
$cancel_button = $bl0;
}
$cw->{'selected_button'} = '';
......@@ -52,10 +53,24 @@ sub Populate {
$top->pack(qw/-side top -fill both -ipady 3 -ipadx 3 -expand 1/);
# create a row of buttons in the bottom.
my $bl; # foreach my $var: perl > 5.003_08
foreach $bl (@$buttons)
my $bo; # foreach my $var: perl > 5.003_08
foreach $bo (@$buttons)
{
my $b = $bot->Button(-text => $bl, -command => sub { $cw->{'selected_button'} = "$bl" } );
my $bl = ($bo =~ tr/~//dr); # Remove all ~ characters
my $underline = rindex($bo, '~');
my $accel;
if ($underline >= 0) {
if (substr($bo, $underline + 1, 1) !~ /[[:alpha:]]/) {
warn "First tilde must precede an alphanumeric character.";
} elsif ($underline >= 0) {
$accel = lc(substr($bo, $underline + 1, 1));
}
}
my $b = $bot->Button(
-text => $bl,
-command => sub { $cw->{'selected_button'} = "$bl" },
-underline => (defined($accel)) ? $underline : -1
);
$b->bind('<Return>' => [ $b, 'Invoke']);
$cw->Advertise("B_$bl" => $b);
if ($Tk::platform eq 'MSWin32')
......@@ -75,6 +90,9 @@ sub Populate {
if (defined $cancel_button && $bl eq $cancel_button) {
$cw->{'cancel_button'} = $b;
}
if (defined($accel)) {
$cw->bind("<Alt-$accel>" => [ $b, 'Invoke']);
}
}
if (defined $default_button && !$cw->{'default_button'}) {
warn "Default button `$default_button' does not exist.\n";
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment