File Coverage

blib/lib/Tk/Month.pm
Criterion Covered Total %
statement 25 27 92.5
branch n/a
condition n/a
subroutine 9 9 100.0
pod n/a
total 34 36 94.4


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__