line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#! /usr/bin/env perl |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
39964
|
use 5.014000; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
37
|
|
4
|
1
|
|
|
1
|
|
6
|
use warnings; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
32
|
|
5
|
1
|
|
|
1
|
|
6
|
use strict; |
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
75
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
package Tk::Month; |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
our $VERSION = '1.8'; |
10
|
|
|
|
|
|
|
|
11
|
1
|
|
|
|
|
130
|
use vars qw( |
12
|
|
|
|
|
|
|
@year @Year %year %a2year |
13
|
|
|
|
|
|
|
@week @Week %week %a2week |
14
|
|
|
|
|
|
|
$day %firstday |
15
|
1
|
|
|
1
|
|
5
|
); |
|
1
|
|
|
|
|
1
|
|
16
|
|
|
|
|
|
|
|
17
|
1
|
|
|
1
|
|
5
|
use Carp; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
98
|
|
18
|
1
|
|
|
1
|
|
1124
|
use POSIX; |
|
1
|
|
|
|
|
9186
|
|
|
1
|
|
|
|
|
6
|
|
19
|
1
|
|
|
1
|
|
4566
|
use Time::Local; |
|
1
|
|
|
|
|
2206
|
|
|
1
|
|
|
|
|
62
|
|
20
|
1
|
|
|
1
|
|
1048
|
use Text::Abbrev; |
|
1
|
|
|
|
|
49
|
|
|
1
|
|
|
|
|
47
|
|
21
|
1
|
|
|
1
|
|
493
|
use Tk; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
use Tk::Widget; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
use base qw/ Tk::Derived Tk::Frame /; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
Construct Tk::Widget 'Month'; |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
sub debug {}; |
29
|
|
|
|
|
|
|
#sub debug { print STDERR @_; }; |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
;# --------------------------------------------------------------------- |
32
|
|
|
|
|
|
|
;# class initialisation. |
33
|
|
|
|
|
|
|
{ |
34
|
|
|
|
|
|
|
$day = 24*60*60; # a day in seconds. |
35
|
|
|
|
|
|
|
%firstday = (); # first weekday in a month cache |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# set up week and month names. |
38
|
|
|
|
|
|
|
&setWeek(); |
39
|
|
|
|
|
|
|
&setYear(); |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
;# --------------------------------------------------------------------- |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
;## Constructor. Uses new inherited from base class |
45
|
|
|
|
|
|
|
sub Populate |
46
|
|
|
|
|
|
|
{ |
47
|
|
|
|
|
|
|
debug "args: @_\n"; |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
my $self = shift; |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
$self->SUPER::Populate(@_); |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
# Set up extra configuration |
54
|
|
|
|
|
|
|
$self->ConfigSpecs( |
55
|
|
|
|
|
|
|
'-month' => ['PASSIVE',undef,undef, ''], |
56
|
|
|
|
|
|
|
'-year' => ['PASSIVE',undef,undef, ''], |
57
|
|
|
|
|
|
|
'-command' => ['PASSIVE',undef,undef, \&defaultAction], |
58
|
|
|
|
|
|
|
'-press' => '-command', |
59
|
|
|
|
|
|
|
'-printformat' => ['PASSIVE',undef,undef, '%d %B %Y'], |
60
|
|
|
|
|
|
|
'-dayformat' => ['PASSIVE',undef,undef, '%d'], |
61
|
|
|
|
|
|
|
'-title' => ['PASSIVE',undef,undef, '%B %Y'], |
62
|
|
|
|
|
|
|
'-update' => ['PASSIVE',undef,undef, 0], |
63
|
|
|
|
|
|
|
#'-printcommand' => ['PASSIVE',undef,undef, \&defaultPrint], |
64
|
|
|
|
|
|
|
'-navigation' => ['PASSIVE',undef,undef, 1], |
65
|
|
|
|
|
|
|
'-side' => ['PASSIVE',undef,undef, 1], |
66
|
|
|
|
|
|
|
#'-close' => ['PASSIVE',undef,undef, $self], |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
# configurable from Xdefaults file. |
69
|
|
|
|
|
|
|
'-includeall' => ['PASSIVE','includeall','IncludeAll', 1], |
70
|
|
|
|
|
|
|
'-showall' => ['PASSIVE','showall','ShowAll', 0], |
71
|
|
|
|
|
|
|
'-first' => ['PASSIVE','first','First', 0], |
72
|
|
|
|
|
|
|
'-buttonhighlightcolor' => ['PASSIVE','buttonhighlightcolor','ButtonHighlightColor', ''], |
73
|
|
|
|
|
|
|
'-buttonhighlightbackground' => ['PASSIVE','buttonhighlightbackground','ButtonHighlightBackground', ''], |
74
|
|
|
|
|
|
|
'-buttonfg' => ['PASSIVE','buttonfg','ButtonFg', ''], |
75
|
|
|
|
|
|
|
'-buttonbg' => ['PASSIVE','buttonbg','ButtonBg', ''], |
76
|
|
|
|
|
|
|
'-buttonbd' => ['PASSIVE','buttonbd','ButtonBd', ''], |
77
|
|
|
|
|
|
|
'-buttonrelief' => ['PASSIVE','buttonrelief','ButtonRelief', ''], |
78
|
|
|
|
|
|
|
); |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
# Construct the subwidgets. |
81
|
|
|
|
|
|
|
$self->{frame} = $self->make(); |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
# decide when to tick....... |
84
|
|
|
|
|
|
|
my ($s, $m, $h) = localtime(); |
85
|
|
|
|
|
|
|
my $wait = $day - (($h *60 + $m)*60 + $s) + 10; |
86
|
|
|
|
|
|
|
$self->after($wait, [ 'tick', $self, $day, ]); |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
# return widget. |
89
|
|
|
|
|
|
|
$self; |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
# DoWhenIdle seems to be replaced by afterIdle in Tk800.018. |
93
|
|
|
|
|
|
|
sub afterIdle { &DoWhenIdle; } |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
;## Update the widget when you get a chance. |
96
|
|
|
|
|
|
|
sub DoWhenIdle |
97
|
|
|
|
|
|
|
{ |
98
|
|
|
|
|
|
|
debug "args: @_\n"; |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
my $self = shift; |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
# refresh the widget. |
103
|
|
|
|
|
|
|
$self->refresh(); |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
# update the widget now? |
106
|
|
|
|
|
|
|
$self->update if ($self->cget(-update)); |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
;# Create all the subwidgets needed for the month. |
110
|
|
|
|
|
|
|
sub make |
111
|
|
|
|
|
|
|
{ |
112
|
|
|
|
|
|
|
debug "args: @_\n"; |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
my $self = shift; |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
my $width = 2; |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
# First create all the buttons in a grid. |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
# navigation row. |
121
|
|
|
|
|
|
|
$self->{title} = $self->Menubutton( |
122
|
|
|
|
|
|
|
-width => 15, |
123
|
|
|
|
|
|
|
)->grid( |
124
|
|
|
|
|
|
|
-row => 0, |
125
|
|
|
|
|
|
|
-column => 2, |
126
|
|
|
|
|
|
|
-columnspan => 4, |
127
|
|
|
|
|
|
|
-sticky => 'nsew', |
128
|
|
|
|
|
|
|
); |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
# Positions (0,0), (0,1), (0,6), (0,7) are the |
132
|
|
|
|
|
|
|
# navigation buttons. |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
# other buttons...... |
135
|
|
|
|
|
|
|
for (my $c=0; $c<$#week+2; $c++) |
136
|
|
|
|
|
|
|
{ |
137
|
|
|
|
|
|
|
for (my $r=1; $r<8; $r++) |
138
|
|
|
|
|
|
|
{ |
139
|
|
|
|
|
|
|
$self->{'button'}->{$r}->{$c} = |
140
|
|
|
|
|
|
|
$self->Button( |
141
|
|
|
|
|
|
|
# width is in chars |
142
|
|
|
|
|
|
|
-width => $width, |
143
|
|
|
|
|
|
|
#-padx => 0, |
144
|
|
|
|
|
|
|
#-pady => 0, |
145
|
|
|
|
|
|
|
)->grid( |
146
|
|
|
|
|
|
|
'-row' => $r, |
147
|
|
|
|
|
|
|
'-column' => $c, |
148
|
|
|
|
|
|
|
'-sticky' => 'nsew', |
149
|
|
|
|
|
|
|
); |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
# Lets set up aliases for these buttons. |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# week day headings..... |
156
|
|
|
|
|
|
|
for (my $c=1; $c<= 1+$#week; $c++) |
157
|
|
|
|
|
|
|
{ |
158
|
|
|
|
|
|
|
$self->{week}->{$c} = $self->{'button'}->{1}->{$c}; |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# side buttons. |
162
|
|
|
|
|
|
|
#for (my $r=1; $r<8; $r++) |
163
|
|
|
|
|
|
|
#{ |
164
|
|
|
|
|
|
|
#$self->{side}->{$r} = $self->{'button'}->{$r}->{0}; |
165
|
|
|
|
|
|
|
#} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# date buttons. |
168
|
|
|
|
|
|
|
for (my $c=1; $c<$#week+2; $c++) |
169
|
|
|
|
|
|
|
{ |
170
|
|
|
|
|
|
|
for (my $r=2; $r<8; $r++) |
171
|
|
|
|
|
|
|
{ |
172
|
|
|
|
|
|
|
$self->{date}->{$r}->{$c} = |
173
|
|
|
|
|
|
|
$self->{'button'}->{$r}->{$c}; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
$self; |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
;# Toggle the side buttons on the left side |
181
|
|
|
|
|
|
|
sub side |
182
|
|
|
|
|
|
|
{ |
183
|
|
|
|
|
|
|
debug "args: @_\n"; |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
my $self = shift; |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
my $navigation = $self->{side}; |
188
|
|
|
|
|
|
|
my $width = 2; |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
# Don't do anything if there is really nothing to do. |
191
|
|
|
|
|
|
|
return if ( |
192
|
|
|
|
|
|
|
exists($self->{sideState}) && |
193
|
|
|
|
|
|
|
$self->cget('-side') eq $self->{sideState} |
194
|
|
|
|
|
|
|
); |
195
|
|
|
|
|
|
|
$self->{sideState} = $self->cget('-side'); |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
# Positions (0,0), (1,0), (2,0),..., (5,0) are the |
198
|
|
|
|
|
|
|
# the side buttons. |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
# side buttons. |
201
|
|
|
|
|
|
|
if ($self->cget('-side')) |
202
|
|
|
|
|
|
|
{ |
203
|
|
|
|
|
|
|
debug "creating side buttons.\n"; |
204
|
|
|
|
|
|
|
for (my $r=1; $r<8; $r++) |
205
|
|
|
|
|
|
|
{ |
206
|
|
|
|
|
|
|
$self->{side}->{$r} = $self->{'button'}->{$r}->{0}; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
else |
210
|
|
|
|
|
|
|
{ |
211
|
|
|
|
|
|
|
debug "removing side buttons.\n"; |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
# remove the side buttons. |
214
|
|
|
|
|
|
|
for (my $r=1; $r<8; $r++) |
215
|
|
|
|
|
|
|
{ |
216
|
|
|
|
|
|
|
next unless (exists($self->{'button'}->{$r}->{0})); |
217
|
|
|
|
|
|
|
$self->{'button'}->{$r}->{0}->destroy(); |
218
|
|
|
|
|
|
|
delete($self->{'button'}->{$r}->{0}); |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
;# Toggle the navigation buttons in the navigation frame. |
224
|
|
|
|
|
|
|
sub navigate |
225
|
|
|
|
|
|
|
{ |
226
|
|
|
|
|
|
|
debug "args: @_\n"; |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
my $self = shift; |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
my $navigation = $self->{navigation}; |
231
|
|
|
|
|
|
|
my $width = 2; |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
# Don't do anything if there is really nothing to do. |
234
|
|
|
|
|
|
|
return if ( |
235
|
|
|
|
|
|
|
exists($self->{navigationState}) && |
236
|
|
|
|
|
|
|
$self->cget('-navigation') eq $self->{navigationState} |
237
|
|
|
|
|
|
|
); |
238
|
|
|
|
|
|
|
$self->{navigationState} = $self->cget('-navigation'); |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
# Positions (0,0), (0,1), (0,6), (0,7) are the |
241
|
|
|
|
|
|
|
# the navigation buttons. |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
# ... and recreate. |
244
|
|
|
|
|
|
|
if ($self->cget('-navigation')) |
245
|
|
|
|
|
|
|
{ |
246
|
|
|
|
|
|
|
debug "creating navigation buttons.\n"; |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
$self->{'button'}->{0}->{0} = $self->Button( |
249
|
|
|
|
|
|
|
-text => '<<', |
250
|
|
|
|
|
|
|
-command=> [\&advance,$self, -1 - $#year ], |
251
|
|
|
|
|
|
|
-width => $width, |
252
|
|
|
|
|
|
|
#-padx => 0, |
253
|
|
|
|
|
|
|
#-pady => 0, |
254
|
|
|
|
|
|
|
)->grid( |
255
|
|
|
|
|
|
|
-row => 0, |
256
|
|
|
|
|
|
|
-column => 0, |
257
|
|
|
|
|
|
|
-sticky => 'nsew', |
258
|
|
|
|
|
|
|
); |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
$self->{'button'}->{0}->{1} = $self->Button( |
261
|
|
|
|
|
|
|
-text => '<', |
262
|
|
|
|
|
|
|
-command=> [\&advance,$self, -1 ], |
263
|
|
|
|
|
|
|
-width => $width, |
264
|
|
|
|
|
|
|
#-padx => 0, |
265
|
|
|
|
|
|
|
#-pady => 0, |
266
|
|
|
|
|
|
|
)->grid( |
267
|
|
|
|
|
|
|
-row => 0, |
268
|
|
|
|
|
|
|
-column => 1, |
269
|
|
|
|
|
|
|
-sticky => 'nsew', |
270
|
|
|
|
|
|
|
); |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
$self->{'button'}->{0}->{7} = $self->Button( |
273
|
|
|
|
|
|
|
-text => '>>', |
274
|
|
|
|
|
|
|
-command=> [\&advance,$self, 1+$#year ], |
275
|
|
|
|
|
|
|
-width => $width, |
276
|
|
|
|
|
|
|
#-padx => 0, |
277
|
|
|
|
|
|
|
#-pady => 0, |
278
|
|
|
|
|
|
|
)->grid( |
279
|
|
|
|
|
|
|
-row => 0, |
280
|
|
|
|
|
|
|
-column => 7, |
281
|
|
|
|
|
|
|
-sticky => 'nsew', |
282
|
|
|
|
|
|
|
); |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
$self->{'button'}->{0}->{6} = $self->Button( |
285
|
|
|
|
|
|
|
-text => '>', |
286
|
|
|
|
|
|
|
-command=> [\&advance,$self, +1 ], |
287
|
|
|
|
|
|
|
-width => $width, |
288
|
|
|
|
|
|
|
#-padx => 0, |
289
|
|
|
|
|
|
|
#-pady => 0, |
290
|
|
|
|
|
|
|
)->grid( |
291
|
|
|
|
|
|
|
-row => 0, |
292
|
|
|
|
|
|
|
-column => 6, |
293
|
|
|
|
|
|
|
-sticky => 'nsew', |
294
|
|
|
|
|
|
|
); |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
#--------------------------------- |
297
|
|
|
|
|
|
|
# create a pulldown menu attached to the title. |
298
|
|
|
|
|
|
|
my $title = $self->{title}; |
299
|
|
|
|
|
|
|
my $menu = $title->Menu(-tearoff => 0); |
300
|
|
|
|
|
|
|
$title->configure(-menu => $menu); |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
# would like to set a pull down menu here to set the month. |
304
|
|
|
|
|
|
|
$menu->command( |
305
|
|
|
|
|
|
|
'-label' => 'Today', |
306
|
|
|
|
|
|
|
'-command' => [ 'configure', $self, '-month' => '', '-year' => '' ], |
307
|
|
|
|
|
|
|
'-underline' => 0, |
308
|
|
|
|
|
|
|
); |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
my $mm = &Submenu($menu, |
311
|
|
|
|
|
|
|
'-label' => 'Set month', |
312
|
|
|
|
|
|
|
'-underline' => 4, |
313
|
|
|
|
|
|
|
); |
314
|
|
|
|
|
|
|
$mm->command( |
315
|
|
|
|
|
|
|
'-label' => 'Current', |
316
|
|
|
|
|
|
|
'-command' => [ 'configure', $self, '-month' => '' ], |
317
|
|
|
|
|
|
|
); |
318
|
|
|
|
|
|
|
$mm->separator(); |
319
|
|
|
|
|
|
|
for (@year) |
320
|
|
|
|
|
|
|
{ |
321
|
|
|
|
|
|
|
debug "adding month '$_' to pull down menu.\n"; |
322
|
|
|
|
|
|
|
$mm->command( |
323
|
|
|
|
|
|
|
'-label' => $_, |
324
|
|
|
|
|
|
|
'-command' => [ 'configure', $self, '-month' => $_ ], |
325
|
|
|
|
|
|
|
); |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
my $ym = &Submenu($menu, |
329
|
|
|
|
|
|
|
'-label' => 'Set year', |
330
|
|
|
|
|
|
|
'-underline' => 4, |
331
|
|
|
|
|
|
|
); |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
my $i; |
334
|
|
|
|
|
|
|
#my $year = $self->cget('-year'); |
335
|
|
|
|
|
|
|
my $year = POSIX::strftime('%Y', localtime()); |
336
|
|
|
|
|
|
|
$ym->command( |
337
|
|
|
|
|
|
|
'-label' => 'Current', |
338
|
|
|
|
|
|
|
'-command' => [ 'configure', $self, '-year' => '' ], |
339
|
|
|
|
|
|
|
); |
340
|
|
|
|
|
|
|
$ym->separator(); |
341
|
|
|
|
|
|
|
for ($i = -5; $i<6; ++$i) |
342
|
|
|
|
|
|
|
{ |
343
|
|
|
|
|
|
|
$ym->command( |
344
|
|
|
|
|
|
|
'-label' => $year+$i, |
345
|
|
|
|
|
|
|
'-command' => [ 'configure', $self, '-year' => $year+$i ], |
346
|
|
|
|
|
|
|
); |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
my $fm = &Submenu($menu, |
350
|
|
|
|
|
|
|
'-label' => 'First day of week', |
351
|
|
|
|
|
|
|
'-underline' => 0, |
352
|
|
|
|
|
|
|
); |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
for (@week) |
355
|
|
|
|
|
|
|
{ |
356
|
|
|
|
|
|
|
debug "radio button label is '$_'.\n"; |
357
|
|
|
|
|
|
|
$fm->radiobutton( |
358
|
|
|
|
|
|
|
'-label' => $_, |
359
|
|
|
|
|
|
|
'-variable' => \$self->{Configure}->{-first}, |
360
|
|
|
|
|
|
|
'-value' => &weekday2number($_), |
361
|
|
|
|
|
|
|
'-command' => [ 'refresh', $self ], |
362
|
|
|
|
|
|
|
); |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
$menu->checkbutton( |
366
|
|
|
|
|
|
|
'-label' => 'Include all', |
367
|
|
|
|
|
|
|
'-variable' => \$self->{Configure}->{'-includeall'}, |
368
|
|
|
|
|
|
|
'-command' => [ 'refresh', $self ], |
369
|
|
|
|
|
|
|
'-underline' => 0, |
370
|
|
|
|
|
|
|
); |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
$menu->checkbutton( |
373
|
|
|
|
|
|
|
'-label' => 'Show all', |
374
|
|
|
|
|
|
|
'-variable' => \$self->{Configure}->{'-showall'}, |
375
|
|
|
|
|
|
|
'-command' => [ 'refresh', $self ], |
376
|
|
|
|
|
|
|
'-underline' => 0, |
377
|
|
|
|
|
|
|
); |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
if (0) { |
380
|
|
|
|
|
|
|
$menu->command( |
381
|
|
|
|
|
|
|
'-label' => 'Print month', |
382
|
|
|
|
|
|
|
'-command' => [ sub { |
383
|
|
|
|
|
|
|
return unless ($self->cget(-printcommand)); |
384
|
|
|
|
|
|
|
&{$self->cget(-printcommand)}($self->{month}, $self->{year}, $self->{first}); |
385
|
|
|
|
|
|
|
} ], |
386
|
|
|
|
|
|
|
'-underline' => 0, |
387
|
|
|
|
|
|
|
); |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
$menu->command( |
390
|
|
|
|
|
|
|
'-label' => 'Close', |
391
|
|
|
|
|
|
|
'-command' => [ sub { (shift)->cget('-close')->destroy(); }, $self ], |
392
|
|
|
|
|
|
|
'-underline' => 0, |
393
|
|
|
|
|
|
|
); |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
else |
398
|
|
|
|
|
|
|
{ |
399
|
|
|
|
|
|
|
debug "removing navigation buttons.\n"; |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
# remove the navigation buttons. |
402
|
|
|
|
|
|
|
local ($_); |
403
|
|
|
|
|
|
|
for (0,1,6,7) |
404
|
|
|
|
|
|
|
{ |
405
|
|
|
|
|
|
|
next unless (exists($self->{'button'}->{0}->{$_})); |
406
|
|
|
|
|
|
|
$self->{'button'}->{0}->{$_}->destroy(); |
407
|
|
|
|
|
|
|
delete($self->{'button'}->{0}->{$_}); |
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
# destroy the pull-down menu. |
411
|
|
|
|
|
|
|
my $menu = $self->{'title'}->cget('-menu'); |
412
|
|
|
|
|
|
|
$menu->destroy() if ($menu); |
413
|
|
|
|
|
|
|
$self->{'title'}->configure('-menu' => undef) |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
debug "Title widget is now $self->{title}.\n"; |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
#$title; |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
;# Refreshes the calendar widget as it should be with respect to |
422
|
|
|
|
|
|
|
;# the current values of its configuration. |
423
|
|
|
|
|
|
|
sub refresh |
424
|
|
|
|
|
|
|
{ |
425
|
|
|
|
|
|
|
my $self = shift; |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
# week day cache of first day of month/year. |
428
|
|
|
|
|
|
|
# get various information from the object. |
429
|
|
|
|
|
|
|
my $month = &month2number($self->cget('-month')); |
430
|
|
|
|
|
|
|
my $year = &year2number($self->cget('-year')); |
431
|
|
|
|
|
|
|
my $command = $self->cget('-command'); |
432
|
|
|
|
|
|
|
my $title = $self->cget('-title'); |
433
|
|
|
|
|
|
|
my $printformat = $self->cget('-printformat'); |
434
|
|
|
|
|
|
|
my $dayformat = $self->cget('-dayformat'); |
435
|
|
|
|
|
|
|
my $first = $self->cget('-first'); |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
debug "refresh: month is $month and year is $year.\n"; |
438
|
|
|
|
|
|
|
debug "first = '$first'.\n"; |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
# check that the object still actually exists..... |
441
|
|
|
|
|
|
|
unless ($self->{title}->IsWidget()) |
442
|
|
|
|
|
|
|
{ |
443
|
|
|
|
|
|
|
debug "$self is no longer a widget!\n"; |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
# bail out now. |
446
|
|
|
|
|
|
|
return; |
447
|
|
|
|
|
|
|
} |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
##### Deal with navigation first.... #### |
450
|
|
|
|
|
|
|
$self->navigate(); |
451
|
|
|
|
|
|
|
$self->side(); |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
############ Refresh the widget. ################### |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
##### Work out the offset for the first day in month. |
456
|
|
|
|
|
|
|
my $offset = &firstday($month, $year) - $first; |
457
|
|
|
|
|
|
|
debug "$month, $year offset = $offset\n"; |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
# remember the month, year and first for print function. |
460
|
|
|
|
|
|
|
$self->{month} = $month; |
461
|
|
|
|
|
|
|
$self->{year} = $year; |
462
|
|
|
|
|
|
|
$self->{first} = $first; |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
# correct for a negative offset. |
465
|
|
|
|
|
|
|
$offset += 1 + $#week if ($offset < 0); |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
debug "after negative correction: offset = $offset\n"; |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
##### fix midday for the first day of month. |
470
|
|
|
|
|
|
|
my $start = timelocal(0, 0, 12, 1, $month, $year-1900); |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
# Get the correct current date. |
473
|
|
|
|
|
|
|
my $today = join('-', (localtime())[3,4,5]); |
474
|
|
|
|
|
|
|
debug "today is '$today'\n"; |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
# Deal with the title button... |
477
|
|
|
|
|
|
|
$title = POSIX::strftime($title, localtime($start)); |
478
|
|
|
|
|
|
|
$self->{title}->configure('-text' => $title); |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
# rewind to first day in grid. |
481
|
|
|
|
|
|
|
$start -= $day*$offset; |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
# Take colours from the title button..... |
484
|
|
|
|
|
|
|
my $fg = $self->{title}->cget('-fg'); |
485
|
|
|
|
|
|
|
my $bg = $self->{title}->cget('-bg'); |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
# other configuarations. |
488
|
|
|
|
|
|
|
my @config = (); |
489
|
|
|
|
|
|
|
local ($_); |
490
|
|
|
|
|
|
|
for (qw(fg bg highlightcolor highlightbackground bd relief)) |
491
|
|
|
|
|
|
|
{ |
492
|
|
|
|
|
|
|
next unless ($self->cget("-button$_")); |
493
|
|
|
|
|
|
|
push(@config, "-$_", $self->cget("-button$_")); |
494
|
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
|
debug "extra config = (@config)\n"; |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
# configure the top left button. |
498
|
|
|
|
|
|
|
if (Exists($self->{'button'}->{1}->{0})) |
499
|
|
|
|
|
|
|
{ |
500
|
|
|
|
|
|
|
$self->{'button'}->{1}->{0}->configure( |
501
|
|
|
|
|
|
|
'-text' => '?', |
502
|
|
|
|
|
|
|
'-command' => [ $command, $title, ( [ POSIX::strftime($printformat, localtime()) ] ) ], |
503
|
|
|
|
|
|
|
'-fg' => $fg, |
504
|
|
|
|
|
|
|
'-bg' => $bg, |
505
|
|
|
|
|
|
|
@config, |
506
|
|
|
|
|
|
|
); |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
# length of the week. |
510
|
|
|
|
|
|
|
my $weeklen = $#week + 1; |
511
|
|
|
|
|
|
|
debug "weeklen = $weeklen\n"; |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
my @when = (); # matrix of whens... |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
# fill in the dates. |
517
|
|
|
|
|
|
|
for (my $i=1; $i<=42; ++$i) |
518
|
|
|
|
|
|
|
{ |
519
|
|
|
|
|
|
|
my @lt = localtime($start); |
520
|
|
|
|
|
|
|
my $when = POSIX::strftime($printformat, @lt); |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
debug "setting button for '$when'.\n"; |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
my $col = ($i-1) % $weeklen; |
525
|
|
|
|
|
|
|
my $row = int(($i-1)/$weeklen); |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
# remember..... |
528
|
|
|
|
|
|
|
if ($self->cget('-includeall') || ($lt[4] == $month)) |
529
|
|
|
|
|
|
|
{ |
530
|
|
|
|
|
|
|
# pack a matrix of 'when's. |
531
|
|
|
|
|
|
|
$when[$row][$col] = $when; |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
debug "including $when.\n"; |
534
|
|
|
|
|
|
|
} |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
my $thisdate = POSIX::strftime($dayformat, @lt); |
537
|
|
|
|
|
|
|
$thisdate = '' unless ($self->cget('-showall') || ($lt[4] == $month)); |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
my $button = $self->{'date'}->{$row+2}->{$col+1}; |
540
|
|
|
|
|
|
|
$button->configure( |
541
|
|
|
|
|
|
|
'-text' => $thisdate, |
542
|
|
|
|
|
|
|
'-command' => [ $command, $title, ( [ $when ] ) ], |
543
|
|
|
|
|
|
|
'-fg' => $fg, |
544
|
|
|
|
|
|
|
'-bg' => $bg, |
545
|
|
|
|
|
|
|
@config, |
546
|
|
|
|
|
|
|
); |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
# if it is today, reverse the colours. |
549
|
|
|
|
|
|
|
my $thisday = join('-', (@lt)[3,4,5]); |
550
|
|
|
|
|
|
|
debug "thisday is '$thisday'.\n"; |
551
|
|
|
|
|
|
|
if ($today eq $thisday ) |
552
|
|
|
|
|
|
|
{ |
553
|
|
|
|
|
|
|
$button->configure('-fg'=>$bg, '-bg'=>$fg); |
554
|
|
|
|
|
|
|
debug "swapping colours for $today.\n"; |
555
|
|
|
|
|
|
|
} |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
# next day...... |
558
|
|
|
|
|
|
|
$start += $day; |
559
|
|
|
|
|
|
|
} |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
######## configure the week day headings. ############## |
562
|
|
|
|
|
|
|
my @fortnight = (@week, @week); |
563
|
|
|
|
|
|
|
for (my $c=1; $c<=1+$#week; $c++) |
564
|
|
|
|
|
|
|
{ |
565
|
|
|
|
|
|
|
my $wday = $fortnight[$c-1+$first]; |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
# grab a column from @when.... |
568
|
|
|
|
|
|
|
local ($_); |
569
|
|
|
|
|
|
|
my @dates = map { [ @{ $when[$_] } [ $c-1 ] ] } 0 .. $#when; |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
debug "Weekday position (0, $c) [$wday] -> @dates.\n"; |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
$self->{week}->{$c}->configure( |
574
|
|
|
|
|
|
|
'-text' => $fortnight[$c-1+$first], |
575
|
|
|
|
|
|
|
'-command' => [ $command, $title, @dates ], |
576
|
|
|
|
|
|
|
'-fg' => $fg, |
577
|
|
|
|
|
|
|
'-bg' => $bg, |
578
|
|
|
|
|
|
|
@config, |
579
|
|
|
|
|
|
|
); |
580
|
|
|
|
|
|
|
} |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
######## configure the week side buttons. ############## |
583
|
|
|
|
|
|
|
for (my $r=0; $r<6; $r++) |
584
|
|
|
|
|
|
|
{ |
585
|
|
|
|
|
|
|
my $button = $self->{side}->{$r+2}; |
586
|
|
|
|
|
|
|
my @dates = @{ $when[$r] ? $when[$r] : [] }; |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
next unless Exists($button); |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
# this debug causes uninitialised warnings.... |
591
|
|
|
|
|
|
|
#debug "Week position ($r, 0) => (@dates)\n"; |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
if (@dates) |
594
|
|
|
|
|
|
|
{ |
595
|
|
|
|
|
|
|
$button->configure( |
596
|
|
|
|
|
|
|
'-command' => [ $command, $title, [ @dates ]], |
597
|
|
|
|
|
|
|
'-text' => '=>', |
598
|
|
|
|
|
|
|
'-fg' => $fg, |
599
|
|
|
|
|
|
|
'-bg' => $bg, |
600
|
|
|
|
|
|
|
@config, |
601
|
|
|
|
|
|
|
); |
602
|
|
|
|
|
|
|
} |
603
|
|
|
|
|
|
|
else |
604
|
|
|
|
|
|
|
{ |
605
|
|
|
|
|
|
|
$button->configure( |
606
|
|
|
|
|
|
|
'-command' => undef, |
607
|
|
|
|
|
|
|
'-text' => '', |
608
|
|
|
|
|
|
|
'-fg' => $fg, |
609
|
|
|
|
|
|
|
'-bg' => $bg, |
610
|
|
|
|
|
|
|
@config, |
611
|
|
|
|
|
|
|
); |
612
|
|
|
|
|
|
|
} |
613
|
|
|
|
|
|
|
} |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
########### overload botton-right button. ################ |
616
|
|
|
|
|
|
|
my $button = $self->{'date'}->{7}->{7}; |
617
|
|
|
|
|
|
|
if ($self->cget('-side')) |
618
|
|
|
|
|
|
|
{ |
619
|
|
|
|
|
|
|
$button->configure( |
620
|
|
|
|
|
|
|
'-command' => [ $command, $title, @when ], |
621
|
|
|
|
|
|
|
'-text' => 'A', |
622
|
|
|
|
|
|
|
'-fg' => $fg, |
623
|
|
|
|
|
|
|
'-bg' => $bg, |
624
|
|
|
|
|
|
|
@config, |
625
|
|
|
|
|
|
|
); |
626
|
|
|
|
|
|
|
} |
627
|
|
|
|
|
|
|
else |
628
|
|
|
|
|
|
|
{ |
629
|
|
|
|
|
|
|
$button->configure( |
630
|
|
|
|
|
|
|
'-command' => undef, |
631
|
|
|
|
|
|
|
'-text' => '', |
632
|
|
|
|
|
|
|
'-fg' => $fg, |
633
|
|
|
|
|
|
|
'-bg' => $bg, |
634
|
|
|
|
|
|
|
@config, |
635
|
|
|
|
|
|
|
); |
636
|
|
|
|
|
|
|
} |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
debug "done\n"; |
640
|
|
|
|
|
|
|
} |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
;# increment and decrement the displayed month. |
643
|
|
|
|
|
|
|
sub advance |
644
|
|
|
|
|
|
|
{ |
645
|
|
|
|
|
|
|
debug "args: @_\n"; |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
my ($self, $inc) = @_; |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
my $month = &month2number($self->cget('-month')); |
650
|
|
|
|
|
|
|
my $year = &year2number($self->cget('-year')); |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
debug "before: month = $month, year = $year\n"; |
654
|
|
|
|
|
|
|
$month += $inc; |
655
|
|
|
|
|
|
|
debug "after inc: month = $month, year = $year\n"; |
656
|
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
# How many months in a year? |
658
|
|
|
|
|
|
|
my $nm = 1 + $#year; |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
# roll forward or back as needed. |
661
|
|
|
|
|
|
|
while ($month >= $nm) { $year ++; $month -= $nm; } |
662
|
|
|
|
|
|
|
while ($month < 0) { $year --; $month += $nm; } |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
debug "after: month = $month, year = $year\n"; |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
#$self->configure('-month'=>$year[$month], '-year'=>$year); |
667
|
|
|
|
|
|
|
$self->configure('-month'=>$month, '-year'=>$year); |
668
|
|
|
|
|
|
|
} |
669
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
;# create a sub menu ,,,,,, |
671
|
|
|
|
|
|
|
sub Submenu |
672
|
|
|
|
|
|
|
{ |
673
|
|
|
|
|
|
|
my $menu = shift; |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
my %info; |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
# inherit defaults... |
678
|
|
|
|
|
|
|
$info{'-tearoff'} = $menu->cget('-tearoff'); |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
# overload defaults... |
681
|
|
|
|
|
|
|
while (@_) |
682
|
|
|
|
|
|
|
{ |
683
|
|
|
|
|
|
|
$_ = shift; |
684
|
|
|
|
|
|
|
if (/^\-/) { $info{$_} = shift; } |
685
|
|
|
|
|
|
|
else { unshift(@_, $_); last; } |
686
|
|
|
|
|
|
|
} |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
my $submenu = $menu->Menu( |
689
|
|
|
|
|
|
|
-tearoff => "$info{'-tearoff'}", |
690
|
|
|
|
|
|
|
); |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
my $c = $menu->cascade( %info ); |
693
|
|
|
|
|
|
|
$c->configure(-menu => $submenu); |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
$submenu; |
696
|
|
|
|
|
|
|
} |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
# set up the weekday information. |
699
|
|
|
|
|
|
|
# pass the desired weekday names as arguments. |
700
|
|
|
|
|
|
|
sub setWeek |
701
|
|
|
|
|
|
|
{ |
702
|
|
|
|
|
|
|
debug "args: @_\n"; |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
# days of the week. |
705
|
|
|
|
|
|
|
@week = @_; |
706
|
|
|
|
|
|
|
@week = &abreviatedWeekDays() unless @week; |
707
|
|
|
|
|
|
|
%week = &invert(@week); |
708
|
|
|
|
|
|
|
%a2week = abbrev(LC(@week)); |
709
|
|
|
|
|
|
|
} |
710
|
|
|
|
|
|
|
|
711
|
|
|
|
|
|
|
# set up the month information. |
712
|
|
|
|
|
|
|
# pass the desired month names as arguments. |
713
|
|
|
|
|
|
|
sub setYear |
714
|
|
|
|
|
|
|
{ |
715
|
|
|
|
|
|
|
# months of the year. |
716
|
|
|
|
|
|
|
@year = @_; |
717
|
|
|
|
|
|
|
@year = &months() unless @year; |
718
|
|
|
|
|
|
|
%year = &invert(@year); |
719
|
|
|
|
|
|
|
%a2year = abbrev(LC(@year)); |
720
|
|
|
|
|
|
|
} |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
# convert weekday to number. |
723
|
|
|
|
|
|
|
sub weekday2number |
724
|
|
|
|
|
|
|
{ |
725
|
|
|
|
|
|
|
my ($arg) = @_; |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
$arg = lc($arg); |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
debug "arg is now '$arg'\n"; |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
# deal with abbreviations first.... |
732
|
|
|
|
|
|
|
$arg = $a2week{$arg} if (exists($a2week{$arg})); |
733
|
|
|
|
|
|
|
debug "unabbreviated arg '$arg'.\n"; |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
if (!defined($arg) || $arg eq '') |
736
|
|
|
|
|
|
|
{ |
737
|
|
|
|
|
|
|
# undefined or empty ... return current. |
738
|
|
|
|
|
|
|
$arg = (localtime())[6]; |
739
|
|
|
|
|
|
|
} |
740
|
|
|
|
|
|
|
elsif ($arg =~ /^-?\d+$/) |
741
|
|
|
|
|
|
|
{ |
742
|
|
|
|
|
|
|
# if its a number..... |
743
|
|
|
|
|
|
|
$arg %= (1 + $#week); |
744
|
|
|
|
|
|
|
$arg += (1 + $#week) if ($arg < 0); |
745
|
|
|
|
|
|
|
return $arg; |
746
|
|
|
|
|
|
|
} |
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
# look it up in the reverse array. |
749
|
|
|
|
|
|
|
return $week{$arg} if (exists($week{$arg})); |
750
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
# return current.... odd choice? |
752
|
|
|
|
|
|
|
(localtime())[6]; |
753
|
|
|
|
|
|
|
} |
754
|
|
|
|
|
|
|
|
755
|
|
|
|
|
|
|
# return lowercase version of array..... |
756
|
|
|
|
|
|
|
sub LC |
757
|
|
|
|
|
|
|
{ |
758
|
|
|
|
|
|
|
my @a; |
759
|
|
|
|
|
|
|
for my $a (@_) |
760
|
|
|
|
|
|
|
{ |
761
|
|
|
|
|
|
|
push (@a, lc($a)); |
762
|
|
|
|
|
|
|
} |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
@a; |
765
|
|
|
|
|
|
|
} |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
# convert month to number. |
768
|
|
|
|
|
|
|
sub month2number |
769
|
|
|
|
|
|
|
{ |
770
|
|
|
|
|
|
|
my ($arg) = @_; |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
$arg = '' unless (defined($arg)); |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
debug "arg '$arg'.\n"; |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
$arg = lc($arg); |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
# deal with abbreviations first.... |
779
|
|
|
|
|
|
|
$arg = $a2year{$arg} if (exists($a2year{$arg})); |
780
|
|
|
|
|
|
|
debug "unabbreviated arg '$arg'.\n"; |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
if (!defined($arg) || $arg eq '') |
783
|
|
|
|
|
|
|
{ |
784
|
|
|
|
|
|
|
# undefined or empty ... return current. |
785
|
|
|
|
|
|
|
$arg = (localtime())[4]; |
786
|
|
|
|
|
|
|
} |
787
|
|
|
|
|
|
|
elsif ($arg =~ /^-?\d+$/) |
788
|
|
|
|
|
|
|
{ |
789
|
|
|
|
|
|
|
debug "its the number $arg\n"; |
790
|
|
|
|
|
|
|
# if its a number..... |
791
|
|
|
|
|
|
|
$arg %= (1 + $#year); |
792
|
|
|
|
|
|
|
debug "modulo .... its $arg\n"; |
793
|
|
|
|
|
|
|
$arg += (1 + $#year) if ($arg < 0); |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
debug "finally its $arg\n"; |
796
|
|
|
|
|
|
|
} |
797
|
|
|
|
|
|
|
elsif (exists($year{$arg})) |
798
|
|
|
|
|
|
|
{ |
799
|
|
|
|
|
|
|
# look it up in the reverse array. |
800
|
|
|
|
|
|
|
$arg = $year{$arg}; |
801
|
|
|
|
|
|
|
} |
802
|
|
|
|
|
|
|
else |
803
|
|
|
|
|
|
|
{ |
804
|
|
|
|
|
|
|
# return current... odd choice? |
805
|
|
|
|
|
|
|
$arg = (localtime())[4]; |
806
|
|
|
|
|
|
|
} |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
debug "returns '$arg'.\n"; |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
$arg; |
811
|
|
|
|
|
|
|
} |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
# convert a year to a number...... |
814
|
|
|
|
|
|
|
sub year2number |
815
|
|
|
|
|
|
|
{ |
816
|
|
|
|
|
|
|
my ($arg) = @_; |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
$arg = '' unless (defined($arg)); |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
debug "arg '$arg'.\n"; |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
if (!defined($arg) || $arg eq '') |
823
|
|
|
|
|
|
|
{ |
824
|
|
|
|
|
|
|
# undefined or empty ... return current. |
825
|
|
|
|
|
|
|
$arg = (localtime())[5] + 1900; |
826
|
|
|
|
|
|
|
} |
827
|
|
|
|
|
|
|
elsif ($arg =~ /^-?\d+$/) |
828
|
|
|
|
|
|
|
{ |
829
|
|
|
|
|
|
|
debug "its a number - $arg\n"; |
830
|
|
|
|
|
|
|
} |
831
|
|
|
|
|
|
|
else |
832
|
|
|
|
|
|
|
{ |
833
|
|
|
|
|
|
|
# catch all. |
834
|
|
|
|
|
|
|
$arg = (localtime())[5] + 1900; |
835
|
|
|
|
|
|
|
} |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
$arg; |
838
|
|
|
|
|
|
|
} |
839
|
|
|
|
|
|
|
|
840
|
|
|
|
|
|
|
# Take an array and return the inverse associative array. |
841
|
|
|
|
|
|
|
sub invert |
842
|
|
|
|
|
|
|
{ |
843
|
|
|
|
|
|
|
#warn "args: @_\n"; |
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
my %i = (); |
846
|
|
|
|
|
|
|
for (my $i=0; $i<=$#_; ++$i) |
847
|
|
|
|
|
|
|
{ |
848
|
|
|
|
|
|
|
$i{lc($_[$i])} = $i; |
849
|
|
|
|
|
|
|
} |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
#warn "args: ", %i, "\n"; |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
%i; |
854
|
|
|
|
|
|
|
} |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
;# --------------------------------------------------------------------- |
857
|
|
|
|
|
|
|
;# return weekday for the first day of a month. |
858
|
|
|
|
|
|
|
sub firstday |
859
|
|
|
|
|
|
|
{ |
860
|
|
|
|
|
|
|
my $m = shift; |
861
|
|
|
|
|
|
|
my $y = shift; |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
debug "firstday: $m $y\n"; |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
$m = &month2number($m); |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
debug "firstday: $m $y\n"; |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
unless (defined($firstday{$y}->{$m})) |
870
|
|
|
|
|
|
|
{ |
871
|
|
|
|
|
|
|
my $t = timelocal (0,0,12,1,$m,$y-1900,0,0,0); |
872
|
|
|
|
|
|
|
$firstday{$y}->{$m} = (localtime($t))[6]; |
873
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
} |
875
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
debug "first day of $m $y is " . $firstday{$y}->{$m} . "\n"; |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
$firstday{$y}->{$m}; |
879
|
|
|
|
|
|
|
|
880
|
|
|
|
|
|
|
} |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
;# Return the abreviated week days. |
883
|
|
|
|
|
|
|
sub abreviatedWeekDays |
884
|
|
|
|
|
|
|
{ |
885
|
|
|
|
|
|
|
my @week = (); |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
my $now = time; |
888
|
|
|
|
|
|
|
my ($s, $m, $h, $wd) = (localtime($now))[0,1,2,6]; |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
# adjust... |
891
|
|
|
|
|
|
|
$now -= (($h-12)*60+$m)*60+$s; # to midday. |
892
|
|
|
|
|
|
|
$now -= $wd * $day; |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
# start looking for the days of the week. |
895
|
|
|
|
|
|
|
# the first one is .... |
896
|
|
|
|
|
|
|
$week[0] = POSIX::strftime("%a", localtime($now)); |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
for (my $i=1 ; ; ++$i) |
899
|
|
|
|
|
|
|
{ |
900
|
|
|
|
|
|
|
# what's the next week day? |
901
|
|
|
|
|
|
|
$now += $day; |
902
|
|
|
|
|
|
|
my $tmp = POSIX::strftime("%a", localtime($now)); |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
# Have we done a whole week yet? |
905
|
|
|
|
|
|
|
last if ($tmp eq $week[0]); |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
# its a new one! |
908
|
|
|
|
|
|
|
$week[$i] = $tmp; |
909
|
|
|
|
|
|
|
} |
910
|
|
|
|
|
|
|
debug "the week is @week.\n"; |
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
@week; |
913
|
|
|
|
|
|
|
} |
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
# generate the months of the year. |
916
|
|
|
|
|
|
|
sub months |
917
|
|
|
|
|
|
|
{ |
918
|
|
|
|
|
|
|
my @year = (); |
919
|
|
|
|
|
|
|
|
920
|
|
|
|
|
|
|
my $now = time; |
921
|
|
|
|
|
|
|
my ($s, $m, $h, $yd) = (localtime($now))[0,1,2,7]; |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
# adjust... |
924
|
|
|
|
|
|
|
$now -= (($h-12)*60+$m)*60+$s; # to midday. |
925
|
|
|
|
|
|
|
$now -= $yd * $day; # 1st Jan. |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
# start looking for the months of the year. |
928
|
|
|
|
|
|
|
# the first one is .... |
929
|
|
|
|
|
|
|
$year[0] = POSIX::strftime("%B", localtime($now)); |
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
for (my $i=1 ; ; ++$i) |
932
|
|
|
|
|
|
|
{ |
933
|
|
|
|
|
|
|
# what's the next month? |
934
|
|
|
|
|
|
|
$now += 32*$day; |
935
|
|
|
|
|
|
|
my $tmp = POSIX::strftime("%B", localtime($now)); |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
# Have we done a whole year yet? |
938
|
|
|
|
|
|
|
last if ($tmp eq $year[0]); |
939
|
|
|
|
|
|
|
|
940
|
|
|
|
|
|
|
# its a new one! |
941
|
|
|
|
|
|
|
$year[$i] = $tmp; |
942
|
|
|
|
|
|
|
} |
943
|
|
|
|
|
|
|
debug "the week is @week.\n"; |
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
warn "Tk::Month::months year has only $#year months!\n" if ($#year != 11); |
946
|
|
|
|
|
|
|
@year; |
947
|
|
|
|
|
|
|
} |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
;# This runs occationally updating the calendar. |
950
|
|
|
|
|
|
|
sub tick |
951
|
|
|
|
|
|
|
{ |
952
|
|
|
|
|
|
|
debug "args: ", @_, "\n"; |
953
|
|
|
|
|
|
|
|
954
|
|
|
|
|
|
|
# remember the period |
955
|
|
|
|
|
|
|
my $self = shift; |
956
|
|
|
|
|
|
|
my $p = shift; |
957
|
|
|
|
|
|
|
|
958
|
|
|
|
|
|
|
debug "tick period is $p msecs.\n"; |
959
|
|
|
|
|
|
|
|
960
|
|
|
|
|
|
|
# check that the object still actually exists..... |
961
|
|
|
|
|
|
|
unless ($self->{title}->IsWidget()) |
962
|
|
|
|
|
|
|
{ |
963
|
|
|
|
|
|
|
debug "$self is no longer a widget!\n"; |
964
|
|
|
|
|
|
|
|
965
|
|
|
|
|
|
|
# bail out now. |
966
|
|
|
|
|
|
|
return undef; |
967
|
|
|
|
|
|
|
} |
968
|
|
|
|
|
|
|
|
969
|
|
|
|
|
|
|
# update it. |
970
|
|
|
|
|
|
|
$self->refresh(); |
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
# ... and keep doing it! |
973
|
|
|
|
|
|
|
$self->after($p, [ 'tick', $self, $p, ]); |
974
|
|
|
|
|
|
|
} |
975
|
|
|
|
|
|
|
|
976
|
|
|
|
|
|
|
;# the default button press action. |
977
|
|
|
|
|
|
|
sub defaultAction |
978
|
|
|
|
|
|
|
{ |
979
|
|
|
|
|
|
|
my ($title, @x) = @_; |
980
|
|
|
|
|
|
|
|
981
|
|
|
|
|
|
|
my $header = '-'x20 . $title . '-'x20; |
982
|
|
|
|
|
|
|
print $header, "\n"; |
983
|
|
|
|
|
|
|
|
984
|
|
|
|
|
|
|
for my $i ( 0 .. $#x ) |
985
|
|
|
|
|
|
|
{ |
986
|
|
|
|
|
|
|
for my $j ( 0 .. $#{$x[$i]} ) |
987
|
|
|
|
|
|
|
{ |
988
|
|
|
|
|
|
|
#print "elt $i $j is $x[$i][$j]\n"; |
989
|
|
|
|
|
|
|
if (defined($x[$i][$j])) |
990
|
|
|
|
|
|
|
{ |
991
|
|
|
|
|
|
|
print "\t$x[$i][$j]"; |
992
|
|
|
|
|
|
|
} |
993
|
|
|
|
|
|
|
else |
994
|
|
|
|
|
|
|
{ |
995
|
|
|
|
|
|
|
print "\t."; |
996
|
|
|
|
|
|
|
} |
997
|
|
|
|
|
|
|
} |
998
|
|
|
|
|
|
|
print "\n"; |
999
|
|
|
|
|
|
|
} |
1000
|
|
|
|
|
|
|
$header =~ s/./-/g; |
1001
|
|
|
|
|
|
|
print $header, "\n"; |
1002
|
|
|
|
|
|
|
|
1003
|
|
|
|
|
|
|
#print join(', ', @_) . "\n"; |
1004
|
|
|
|
|
|
|
} |
1005
|
|
|
|
|
|
|
|
1006
|
|
|
|
|
|
|
#sub defaultPrint { print "@_\n"; } |
1007
|
|
|
|
|
|
|
|
1008
|
|
|
|
|
|
|
# Add an entry to the title menu. |
1009
|
|
|
|
|
|
|
sub command |
1010
|
|
|
|
|
|
|
{ |
1011
|
|
|
|
|
|
|
my $self = shift; |
1012
|
|
|
|
|
|
|
|
1013
|
|
|
|
|
|
|
unless ($self->{title}->IsWidget()) |
1014
|
|
|
|
|
|
|
{ |
1015
|
|
|
|
|
|
|
debug "$self is no longer a widget!\n"; |
1016
|
|
|
|
|
|
|
return; |
1017
|
|
|
|
|
|
|
} |
1018
|
|
|
|
|
|
|
|
1019
|
|
|
|
|
|
|
$self->{title}->command(@_); |
1020
|
|
|
|
|
|
|
} |
1021
|
|
|
|
|
|
|
|
1022
|
|
|
|
|
|
|
# Add a separator to the title menu. |
1023
|
|
|
|
|
|
|
sub separator |
1024
|
|
|
|
|
|
|
{ |
1025
|
|
|
|
|
|
|
my $self = shift; |
1026
|
|
|
|
|
|
|
|
1027
|
|
|
|
|
|
|
unless ($self->{title}->IsWidget()) |
1028
|
|
|
|
|
|
|
{ |
1029
|
|
|
|
|
|
|
debug "$self is no longer a widget!\n"; |
1030
|
|
|
|
|
|
|
return; |
1031
|
|
|
|
|
|
|
} |
1032
|
|
|
|
|
|
|
|
1033
|
|
|
|
|
|
|
$self->{title}->separator(@_); |
1034
|
|
|
|
|
|
|
} |
1035
|
|
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
;################################################################# |
1037
|
|
|
|
|
|
|
;# A default startup routine. |
1038
|
|
|
|
|
|
|
sub TkMonth |
1039
|
|
|
|
|
|
|
{ |
1040
|
|
|
|
|
|
|
# only use this when testing. |
1041
|
|
|
|
|
|
|
eval 'use Getopt::Long;'; |
1042
|
|
|
|
|
|
|
Getopt::Long::Configure("pass_through"); |
1043
|
|
|
|
|
|
|
GetOptions( |
1044
|
|
|
|
|
|
|
'd' => sub { |
1045
|
|
|
|
|
|
|
eval ' sub debug { |
1046
|
|
|
|
|
|
|
my ($package, $filename, $line, |
1047
|
|
|
|
|
|
|
$subroutine, $hasargs, $wantargs) = caller(1); |
1048
|
|
|
|
|
|
|
$line = (caller(0))[2]; |
1049
|
|
|
|
|
|
|
|
1050
|
|
|
|
|
|
|
print STDERR "$subroutine: "; |
1051
|
|
|
|
|
|
|
|
1052
|
|
|
|
|
|
|
if (@_) {print STDERR @_; } |
1053
|
|
|
|
|
|
|
else {print "Debug $filename line $line.\n";} |
1054
|
|
|
|
|
|
|
}; |
1055
|
|
|
|
|
|
|
'; |
1056
|
|
|
|
|
|
|
}, |
1057
|
|
|
|
|
|
|
); |
1058
|
|
|
|
|
|
|
|
1059
|
|
|
|
|
|
|
my ($month, $year) = (localtime(time))[4,5]; |
1060
|
|
|
|
|
|
|
$year += 1900; |
1061
|
|
|
|
|
|
|
|
1062
|
|
|
|
|
|
|
# Test script for the Tk Tk::Month widget. |
1063
|
|
|
|
|
|
|
use Tk; |
1064
|
|
|
|
|
|
|
use Tk::Optionmenu; |
1065
|
|
|
|
|
|
|
#use Tk::Month; |
1066
|
|
|
|
|
|
|
|
1067
|
|
|
|
|
|
|
my $top=MainWindow->new(); |
1068
|
|
|
|
|
|
|
|
1069
|
|
|
|
|
|
|
my $f = $top->Frame()->pack( |
1070
|
|
|
|
|
|
|
-side => 'top', |
1071
|
|
|
|
|
|
|
-fill => 'x', |
1072
|
|
|
|
|
|
|
-expand => 'yes', |
1073
|
|
|
|
|
|
|
); |
1074
|
|
|
|
|
|
|
my $m = $f->Menubutton( |
1075
|
|
|
|
|
|
|
'-text' => 'File', |
1076
|
|
|
|
|
|
|
)->pack( |
1077
|
|
|
|
|
|
|
-side => 'left', |
1078
|
|
|
|
|
|
|
); |
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
######################################################### |
1081
|
|
|
|
|
|
|
# can set the week days here but not recommended. |
1082
|
|
|
|
|
|
|
# Tk::Month::setWeek( qw(Su M Tu W Th F Sa) ); |
1083
|
|
|
|
|
|
|
|
1084
|
|
|
|
|
|
|
my $a = $top->Month( |
1085
|
|
|
|
|
|
|
'-printformat' => '%a %d', |
1086
|
|
|
|
|
|
|
#'-dayformat' => '%j', |
1087
|
|
|
|
|
|
|
'-includeall' => 0, |
1088
|
|
|
|
|
|
|
'-month' => $month, |
1089
|
|
|
|
|
|
|
'-year' => $year, |
1090
|
|
|
|
|
|
|
@ARGV, |
1091
|
|
|
|
|
|
|
)->pack(); |
1092
|
|
|
|
|
|
|
|
1093
|
|
|
|
|
|
|
$a->configure(@_) if @_; |
1094
|
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
|
$a->separator(); |
1096
|
|
|
|
|
|
|
$a->command( |
1097
|
|
|
|
|
|
|
-label => 'Print month', |
1098
|
|
|
|
|
|
|
-command => [ sub { my $s = shift; print $s->cget('-month'), " ", $s->cget('-year'), "\n"; }, $a, ], |
1099
|
|
|
|
|
|
|
-underline => 0, |
1100
|
|
|
|
|
|
|
); |
1101
|
|
|
|
|
|
|
$a->command( |
1102
|
|
|
|
|
|
|
-label => 'Close', |
1103
|
|
|
|
|
|
|
-command => [ sub { (shift)->destroy(); }, $a ], |
1104
|
|
|
|
|
|
|
-underline => 0, |
1105
|
|
|
|
|
|
|
); |
1106
|
|
|
|
|
|
|
######################################################### |
1107
|
|
|
|
|
|
|
|
1108
|
|
|
|
|
|
|
# modify the month.... |
1109
|
|
|
|
|
|
|
$m->command( |
1110
|
|
|
|
|
|
|
-label => 'New', |
1111
|
|
|
|
|
|
|
-command => sub { $top->Month()->pack(); }, |
1112
|
|
|
|
|
|
|
); |
1113
|
|
|
|
|
|
|
|
1114
|
|
|
|
|
|
|
$m->separator(); |
1115
|
|
|
|
|
|
|
|
1116
|
|
|
|
|
|
|
for my $i ( qw(raised flat sunken) ) |
1117
|
|
|
|
|
|
|
{ |
1118
|
|
|
|
|
|
|
$m->command( |
1119
|
|
|
|
|
|
|
-label => ucfirst($i), |
1120
|
|
|
|
|
|
|
-command => sub { $a->configure(-buttonrelief => $i); }, |
1121
|
|
|
|
|
|
|
); |
1122
|
|
|
|
|
|
|
} |
1123
|
|
|
|
|
|
|
|
1124
|
|
|
|
|
|
|
$m->separator(); |
1125
|
|
|
|
|
|
|
|
1126
|
|
|
|
|
|
|
for my $i ( qw(on off) ) |
1127
|
|
|
|
|
|
|
{ |
1128
|
|
|
|
|
|
|
$m->command( |
1129
|
|
|
|
|
|
|
-label => "Navigation $i", |
1130
|
|
|
|
|
|
|
-command => sub { $a->configure(-navigation => ($i eq 'on' ? 1 : 0)); }, |
1131
|
|
|
|
|
|
|
); |
1132
|
|
|
|
|
|
|
} |
1133
|
|
|
|
|
|
|
|
1134
|
|
|
|
|
|
|
for my $i ( qw(on off) ) |
1135
|
|
|
|
|
|
|
{ |
1136
|
|
|
|
|
|
|
$m->command( |
1137
|
|
|
|
|
|
|
-label => "Side $i", |
1138
|
|
|
|
|
|
|
-command => sub { $a->configure(-side => ($i eq 'on' ? 1 : 0)); }, |
1139
|
|
|
|
|
|
|
); |
1140
|
|
|
|
|
|
|
} |
1141
|
|
|
|
|
|
|
|
1142
|
|
|
|
|
|
|
for my $i ( qw(%e %d %j) ) |
1143
|
|
|
|
|
|
|
{ |
1144
|
|
|
|
|
|
|
$m->command( |
1145
|
|
|
|
|
|
|
-label => "Day format $i", |
1146
|
|
|
|
|
|
|
-command => sub { $a->configure(-dayformat => $i); }, |
1147
|
|
|
|
|
|
|
); |
1148
|
|
|
|
|
|
|
} |
1149
|
|
|
|
|
|
|
|
1150
|
|
|
|
|
|
|
$m->separator(); |
1151
|
|
|
|
|
|
|
$m->command( |
1152
|
|
|
|
|
|
|
-label => 'Exit', |
1153
|
|
|
|
|
|
|
-command => sub { exit; }, |
1154
|
|
|
|
|
|
|
); |
1155
|
|
|
|
|
|
|
|
1156
|
|
|
|
|
|
|
MainLoop(); |
1157
|
|
|
|
|
|
|
|
1158
|
|
|
|
|
|
|
} |
1159
|
|
|
|
|
|
|
|
1160
|
|
|
|
|
|
|
# If we are running this file then run the test function.... |
1161
|
|
|
|
|
|
|
&TkMonth if ($0 eq __FILE__); |
1162
|
|
|
|
|
|
|
|
1163
|
|
|
|
|
|
|
1; |
1164
|
|
|
|
|
|
|
|
1165
|
|
|
|
|
|
|
__END__ |