← Back to branch summary

~ubuntu-branches/ubuntu/lucid/perl-tk/lucid

« back to all changes in this revision

Viewing changes to Tk/Button.pm

  • Committer: Bazaar Package Importer
  • Author(s): Colin Tuckley
  • Date: 2008-02-15 13:56:59 UTC
  • mfrom: (1.1.3 upstream) (4.1.1 hardy)
  • Revision ID: james.westby@ubuntu.com-20080215135659-ru2oqlykuju20fav
Tags: 1:804.028-1
http://bugs.debian.org/463080
http://bugs.debian.org/411129
* New Upstream Release (Closes: #463080).
* Update to Debhelper v5.
* Build with XFT=1 (Closes: #411129).

Show diffs side-by-side

added added

removed removed

Lines of Context:
Tk/Button.pm
7
7
# This program is free software; you can redistribute it and/or
8
8
 
9
9
use vars qw($VERSION);
10
 
$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Button.pm#8 $
 
10
$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tk/Button.pm#8 $
11
11
 
12
12
# modify it under the same terms as Perl itself, subject
13
13
# to additional disclaimer in license.terms due to partial
18
18
require Tk::Widget;
19
19
use base  qw(Tk::Widget);
20
20
 
21
 
use vars qw($buttonWindow $relief);
 
21
use vars qw($buttonWindow $afterId $repeated);
22
22
 
23
23
Tk::Methods('deselect','flash','invoke','select','toggle');
24
24
 
52
52
 my $E = shift;
53
53
 if ($w->cget('-state') ne 'disabled')
54
54
  {
55
 
   $w->configure('-state' => 'active');
56
 
   $w->configure('-state' => 'active', '-relief' => 'sunken') if (defined($buttonWindow) && $w == $buttonWindow)
 
55
   # On unix the state is active just with mouse-over
 
56
   $w->configure(-state => 'active');
 
57
 
 
58
   # If the mouse button is down, set the relief to sunken on entry.
 
59
   # Overwise, if there's an -overrelief value, set the relief to that.
 
60
   $w->{__relief__} = $w->cget('-relief');
 
61
   if (defined $buttonWindow && $w == $buttonWindow)
 
62
    {
 
63
     $w->configure(-relief => 'sunken');
 
64
     $w->{__prelief__} = 'sunken';
 
65
    }
 
66
   elsif ((my $over = $w->cget('-overrelief')) ne '')
 
67
    {
 
68
     $w->configure(-relief => $over);
 
69
     $w->{__prelief__} = $over;
 
70
    }
57
71
  }
58
72
 $Tk::window = $w;
59
73
}
71
85
{
72
86
 my $w = shift;
73
87
 $w->configure('-state'=>'normal') if ($w->cget('-state') ne 'disabled');
74
 
 $w->configure('-relief' => $relief) if (defined($buttonWindow) && $w == $buttonWindow);
 
88
 # Restore the original button relief if it was changed by Tk.
 
89
 # That is signaled by the existence of Priv($w,prelief).
 
90
 if (exists $w->{__relief__})
 
91
  {
 
92
   if (exists $w->{__prelief__} &&
 
93
       $w->{__prelief__} eq $w->cget('-relief'))
 
94
    {
 
95
     $w->configure(-relief => $w->{__relief__});
 
96
    }
 
97
   delete $w->{__relief__};
 
98
   delete $w->{__prelief__};
 
99
  }
75
100
 undef $Tk::window;
76
101
}
77
102
 
86
111
sub butDown
87
112
{
88
113
 my $w = shift;
89
 
 $relief = $w->cget('-relief');
 
114
 
 
115
 # Only save the button's relief if it does not yet exist.  If there
 
116
 # is an overrelief setting, Priv($w,relief) will already have been set,
 
117
 # and the current value of the -relief option will be incorrect.
 
118
 
 
119
 if (!exists $w->{__relief__})
 
120
  {
 
121
   $w->{__relief__} = $w->cget('-relief');
 
122
  }
 
123
 
90
124
 if ($w->cget('-state') ne 'disabled')
91
125
  {
92
126
   $buttonWindow = $w;
93
 
   $w->configure('-relief' => 'sunken')
 
127
   $w->configure('-relief' => 'sunken', '-state' => 'active');
 
128
   $w->{__prelief__} = 'sunken';
 
129
 
 
130
   # If this button has a repeatdelay set up, get it going with an after
 
131
   $w->afterCancel($afterId);
 
132
   my $delay = $w->cget('-repeatdelay');
 
133
   $repeated = 0;
 
134
   if ($delay > 0)
 
135
    {
 
136
     $afterId = $w->after($delay, [$w, 'AutoInvoke']);
 
137
    }
94
138
  }
95
139
}
96
140
 
107
151
 if (defined($buttonWindow) && $buttonWindow == $w)
108
152
  {
109
153
   undef $buttonWindow;
110
 
   $w->configure('-relief' => $relief);
 
154
 
 
155
   # Restore the button's relief if it was cached.
 
156
   if (exists $w->{__relief__})
 
157
    {
 
158
     if (exists $w->{__prelief__} &&
 
159
         $w->{__prelief__} eq $w->cget('-relief'))
 
160
      {
 
161
       $w->configure(-relief => $w->{__relief__});
 
162
      }
 
163
     delete $w->{__relief__};
 
164
     delete $w->{__prelief__};
 
165
    }
 
166
 
 
167
   # Clean up the after event from the auto-repeater
 
168
   $w->afterCancel($afterId);
 
169
 
111
170
   if ($w->IS($Tk::window) && $w->cget('-state') ne 'disabled')
112
171
    {
113
 
     $w->invoke;
 
172
     $w->configure(-state => 'normal');
 
173
     # Only invoke the command if it wasn't already invoked by the
 
174
     # auto-repeater functionality
 
175
     if ($repeated == 0)
 
176
      {
 
177
       $w->invoke;
 
178
      }
114
179
    }
115
180
  }
116
181
}
136
201
  }
137
202
}
138
203
 
 
204
# ::tk::ButtonAutoInvoke --
 
205
#
 
206
#      Invoke an auto-repeating button, and set it up to continue to repeat.
 
207
#
 
208
# Arguments:
 
209
#      w       button to invoke.
 
210
#
 
211
# Results:
 
212
#      None.
 
213
#
 
214
# Side effects:
 
215
#      May create an after event to call ::tk::ButtonAutoInvoke.
 
216
sub AutoInvoke
 
217
{
 
218
 my $w = shift;
 
219
 $w->afterCancel($afterId);
 
220
 my $delay = $w->cget('-repeatinterval');
 
221
 if ($w->IS($Tk::window))
 
222
  {
 
223
   $repeated++;
 
224
   $w->invoke;
 
225
  }
 
226
 if ($delay > 0)
 
227
  {
 
228
   $afterId = $w->after($delay, [$w, 'AutoInvoke']);
 
229
  }
 
230
}
 
231
 
 
232
# Used for Tk::Widget::AmpWidget
 
233
sub AmpWidgetPostHook
 
234
{
 
235
 my $w = shift;
 
236
 $w->bind('<<AltUnderlined>>' => ['invoke']);
 
237
}
139
238
 
140
239
 
141
240
1;