File Coverage

blib/lib/PlotCalendar/Month.pm
Criterion Covered Total %
statement 183 356 51.4
branch 27 88 30.6
condition 1 15 6.6
subroutine 24 31 77.4
pod 0 26 0.0
total 235 516 45.5


line stmt bran cond sub pod time code
1             package PlotCalendar::Month;
2              
3             #
4             # Version 1.0 - 3/99 - Alan Jackson : ajackson at icct.net
5             # Copyright 1999 may be used and distributed under the
6             # Gnu Copyleft.
7              
8             # Version 1.1 - 6/99 - major code cleanup and documentation
9              
10             # To do
11             # flag to drop empty rows (yes/no)
12             # actually add in the Tk stuff!
13             # should add something to support Javascript (I suppose)
14             #
15              
16              
17 2     2   1647 use strict;
  2         5  
  2         106  
18 2     2   13 use vars qw( $VERSION );
  2         4  
  2         108  
19              
20 2     2   13 use Carp;
  2         4  
  2         174  
21 2     2   758 use PlotCalendar::DateTools qw(Add_Delta_Days Day_of_Week Day_of_Year Days_in_Month Decode_Day_of_Week Day_of_Week_to_Text Month_to_Text);
  2         5  
  2         194  
22 2     2   678 use PlotCalendar::Day;
  2         5  
  2         7597  
23              
24             # Note : Day_of_Week returns 1=Mon, 7=Sun
25              
26             $VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ m#(\d+)\.(\d+)#;
27              
28             sub new {
29 1     1 0 34 my $proto = shift;
30 1   33     13 my $class = ref($proto) || $proto;
31 1         3 my $self = {};
32              
33             # Values to apply to all cells
34              
35 1         5 $self->{MONTH} = ''; # Month (1-12)
36 1         2 $self->{YEAR} = ''; # Year (4 digits, like 1999)
37 1         596 $self->{SIZE} = {}; # hash of dimensions, height and width
38 1         3 $self->{CLIPTEXT} = 0; # Clip text if too long? default = no.
39 1         2 $self->{FONT} = {}; # hash of font sizes, day, main, opt
40 1         4 $self->{STYLES} = {}; # hash of font styles, day, main, opt (n,b,i,u)
41 1         22 $self->{EXPAND} = 0; # Is height allowed to expand? default = no.
42 1         3 $self->{FIRST} = 'Sun'; # What day of the week is in the first column?
43 1         2 $self->{ARTWORK} = ''; # What is the path to the artwork directory?
44 1         2 $self->{CELLWIDTH} = ''; # total width / 7
45 1         2 $self->{TABLEBG} = '#66FFFF'; # Table Background color
46 1         3 $self->{'FONT_TABLE'}={}; # convert between points and html fonts
47 1         2 $self->{MONTHREF}=''; # html reference for month/year
48              
49             # Values that are arrays to be applied to each cell
50              
51 1         2 $self->{FGCOLOR} = []; # array of foreground colors
52 1         2 $self->{BGCOLOR} = []; # array of background colors
53 1         3 $self->{DAYNAME} = []; # What is the day called (like, "Christmas")
54 1         12 $self->{TEXT} = []; # array of pointers to arrays of lines of text
55 1         3 $self->{TEXTCOL} = []; # array of pointers to arrays of text colors
56 1         2 $self->{TEXTSIZE} = []; # array of pointers to arrays of text sizes
57 1         1 $self->{TEXTSTYLE} = []; # array of pointers to arrays of text styles
58 1         2 $self->{TEXTREF} = []; # array of pointers to arrays of text html refs
59 1         2 $self->{NAMEREF} = []; # array of html refs for the dayname
60              
61 1         2 $self->{COMMENTS} = []; # array of pointers to arrays for comment days
62             # These are "days" that will be put into the
63             # blank areas at the beginning and end of the
64             # calendar.
65             # [\@preference,\@text,\@color,\@style,\@size]
66             # preference = 'before' or 'after'. If the
67             # preferred position is not available, use
68             # the other. If neither is available, expand
69             # the month by adding a new row on the bottom.
70              
71 1         1 $self->{COMMFLAG} = 0; # Are there comments? 0=no, 1=yes
72 1         2 $self->{HTMLREF} = []; # array of html references to be applied to cells
73              
74 1         3 $self->{MONTH} = shift;
75 1         2 $self->{YEAR} = shift;
76              
77 1         2 &initialize($self);
78              
79 1         3 bless $self, $class;
80              
81 1         3 return $self;
82              
83             }
84              
85             # ****************************************************************
86             sub gettext {
87 0     0 0 0 my $self = shift;
88              
89 0         0 return \@{$self->{DATES}};
  0         0  
90             }
91              
92             # ****************************************************************
93             sub gethtml {
94 1     1 0 4 my $self = shift;
95              
96 1         1 my $string='';
97              
98 1         2 my $begday = $self->{FIRST}; # What day of the week is the first day of the month?
99              
100             # initialize table
101              
102 1         4 $string = "{TABLEBG} WIDTH=$self->{SIZE}{width} >\n";
103 1 50       3 if ($self->{CELLWIDTH} < 40) {
104 0         0 $string = "{TABLEBG} WIDTH=$self->{SIZE}{width} >\n"; \n"; \n"; \n"; \n"; \n"; \n"; \n"; \n"; \n"; \n";
105             }
106              
107             # Month-year header
108             # If there is no artwork directory, use bold headings,
109             # 1 size larger than digit
110              
111 1         5 my $month = Month_to_Text($self->{MONTH});
112 1         1 my $year = $self->{YEAR};
113 1         2 my ($r1,$r2) = ('','');
114 1 50       8 if ($self->{MONTHREF} ne '') {
115 0         0 $r1 = $self->{MONTHREF};
116 0         0 $r2 = '';
117             }
118 1         6 my $labels = "$r1{FONT_TABLE}{($self->{FONT}{day}+2)}>$month $year$r2";
119              
120 1 50       3 if ($self->{ARTWORK} ne '') {
121 1         3 my $mon = $self->{ARTWORK} . "/" . $month . ".gif";
122 1         1 my $yr = '';
123 1         34 foreach my $i (split('',$year)) {
124 4         11 $yr .= '' . "\n";
125             }
126 1         4 $labels = $r1 . '  ' . $yr . $r2;
127             }
128              
129 1         3 $string .= "
{SIZE}{width} >";
130 1         2 $string .= "
$labels
\n";
131 1         2 $string .= "
132              
133             # Weekday names
134              
135 1         1 $string .= "
136 1         4 my $frstdow = Decode_Day_of_Week($begday);
137 1         10 for (my $i=0;$i<7;$i++) {
138 7         8 my $dow = ($frstdow + $i)%7;
139 7 100       9 $dow = $dow ? $dow : 7; # if = 0, set = to 7
140 7         12 $string .= "{CELLWIDTH} NOSAVE NOWRAP>";
141 7         16 my $textdow = Day_of_Week_to_Text($dow);
142 7 50       14 if ($self->{CELLWIDTH} < 80) { $textdow = substr($textdow,0,3);}
  0         0  
143 7 50       11 if ($self->{CELLWIDTH} < 40) {
144 0         0 $textdow = substr($textdow,0,1);
145 0         0 $string .= "" . $textdow . "";
146             }
147             else {
148 7         12 $string .= "

" . $textdow . "

";
149             }
150 7         16 $string .= "
151             }
152 1         2 $string .= "
153              
154             # If there are comments, we'll need to deal with them
155              
156 1         2 my $comments = 0;
157 1         1 my (@prefs, @comments, @comcol, @comstyle, @comsize);
158 1 50       4 if ($self->{COMMFLAG}) {
159 1         2 @prefs = @{$self->{COMMENTS}[0]};
  1         8  
160 1         2 @comments = @{$self->{COMMENTS}[1]};
  1         3  
161 1         2 @comcol = @{$self->{COMMENTS}[2]};
  1         3  
162 1         1 @comstyle = @{$self->{COMMENTS}[3]};
  1         3  
163 1         1 @comsize = @{$self->{COMMENTS}[4]};
  1         3  
164 1         2 $comments = @prefs;
165             }
166              
167             # add in all the days
168              
169 1         6 my $numdays = Days_in_Month($year, $self->{MONTH}); # num days in month
170 0         0 my $dow = Day_of_Week($year, $self->{MONTH},1); # day of week of first
171 0         0 my $curday = 0; # current day of month
172 0 0       0 $dow = 0 if $dow == 7;
173 0 0       0 $frstdow = 0 if $frstdow == 7;
174              
175 0         0 my $valid=0;
176              
177 0         0 for (my $row=0;$row<6;$row++) {
178 0         0 $string .= "
179 0 0 0     0 last if $row >= 4 && $curday >= $numdays; # don't add an empty row
180 0         0 for (my $col=0;$col<7;$col++) {
181 0 0       0 if ( ($col+$frstdow)%7 == $dow){ $valid = 1 ;} # flag for starting
  0         0  
182 0 0       0 $curday++ if $valid;
183 0 0       0 if ($curday > $numdays) { $valid = 0 ;} # flag for stopping
  0         0  
184             # Is this and empty cell?
185 0 0       0 if ( $valid ) { # ---- actually build the day cell here ----
186 0         0 my $day = PlotCalendar::Day->new($curday);
187 0         0 $day -> size($self->{CELLWIDTH},$self->{CELLWIDTH});
188 0         0 $day -> font($self->{FONT}{day},$self->{FONT}{main},$self->{FONT}{opt},);
189 0         0 $day -> style($self->{STYLES}{day},$self->{STYLES}{main},$self->{STYLES}{opt},);
190 0         0 $day -> cliptext($self->{CLIPTEXT});
191 0         0 $day -> dayname($self->{DAYNAME}[$curday]);
192 0         0 $day -> nameref($self->{NAMEREF}[$curday]);
193 0         0 $day -> color($self->{FGCOLOR}[$curday],$self->{BGCOLOR}[$curday],'WHITE',);;
194 0         0 $day -> text(@{$self->{TEXT}[$curday]});
  0         0  
195 0         0 $day -> textcolor(@{$self->{TEXTCOL}[$curday]});
  0         0  
196 0         0 $day -> textsize(@{$self->{TEXTSIZE}[$curday]});
  0         0  
197 0         0 $day -> textstyle(@{$self->{TEXTSTYLE}[$curday]});
  0         0  
198 0         0 $day -> textref(@{$self->{TEXTREF}[$curday]});
  0         0  
199 0 0       0 if ($self->{HTMLREF}[$curday]) {
200 0         0 $day -> htmlref($self->{HTMLREF}[$curday]);
201             }
202 0         0 $string .= $day -> gethtml; # ---- add in cell
203             }
204             else {
205 0 0 0     0 if ($comments && $curday == 0 && grep(/before/,@prefs)) {
    0 0        
      0        
206             # I am in the before zone and can use it
207 0         0 my $k;
208 0         0 for ($k=0;$k<@prefs;$k++) {
209 0 0       0 last if $prefs[$k] eq 'before' ;
210             }
211 0         0 $string .= &makecomm($self,$comments[$k],$comcol[$k],$comstyle[$k],$comsize[$k]);
212 0         0 splice(@prefs,$k,1);
213 0         0 splice(@comments,$k,1);
214 0         0 splice(@comcol,$k,1);
215 0         0 splice(@comstyle,$k,1);
216 0         0 splice(@comsize,$k,1);
217 0         0 $comments--;
218             }
219             elsif ($comments && $curday > 0 ) {
220             # I am in the after zone and can use it
221 0         0 $string .= &makecomm($self,$comments[0],$comcol[0],$comstyle[0],$comsize[0]);
222 0         0 shift @prefs;
223 0         0 shift @comments;
224 0         0 shift @comcol;
225 0         0 shift @comstyle;
226 0         0 shift @comsize;
227 0         0 $comments--;
228             }
229             else {
230 0         0 $string .= "{CELLWIDTH} BGCOLOR=$self->{TABLEBG}> 
231             }
232             }
233             }
234 0         0 $string .= "
235             }
236             # If I have leftover comments, I have to create an extra row to display them
237 0 0       0 if ($comments) {
238 0         0 $string .= "
239 0         0 for (my $col=0;$col<7;$col++) {
240 0 0       0 if ($comments) {
241             # I am in the after zone and can use it
242 0         0 $string .= &makecomm($self,$comments[0],$comcol[0],$comstyle[0],$comsize[0]);
243 0         0 shift @prefs;
244 0         0 shift @comments;
245 0         0 shift @comcol;
246 0         0 shift @comstyle;
247 0         0 shift @comsize;
248 0         0 $comments--;
249             }
250             else {
251 0         0 $string .= "{CELLWIDTH} BGCOLOR=$self->{TABLEBG}> 
252             }
253            
254             }
255 0         0 $string .= "
256             }
257              
258             # finish up
259 0         0 $string .= "
\n";
260              
261 0         0 return $string;
262             }
263              
264             sub makecomm {
265 0     0 0 0 my $output = '';
266 0         0 my $self = shift;
267 0         0 my $comm = shift;
268 0         0 my $color = shift;
269 0         0 my $style = shift;
270 0         0 my $size = shift;
271 0         0 my $day = PlotCalendar::Day->new(0);
272 0         0 $day -> size($self->{CELLWIDTH},$self->{CELLWIDTH});
273 0         0 $day -> font($self->{FONT}{day},$self->{FONT}{main},$self->{FONT}{opt},);
274 0         0 $day -> style($self->{STYLES}{day},$self->{STYLES}{main},$self->{STYLES}{opt},);
275 0         0 $day -> color('BLACK',$self->{TABLEBG},'WHITE',);;
276              
277 0         0 $day -> text(@{$comm});
  0         0  
278 0         0 $day -> textcolor(($color)x@{$comm});
  0         0  
279 0         0 $day -> textsize(($size)x@{$comm});
  0         0  
280 0         0 $day -> textstyle(($style)x@{$comm});
  0         0  
281 0         0 $output = $day -> gethtml; # ---- add in cell
282              
283 0         0 return $output;
284             }
285              
286             # ****************************************************************
287             sub gettk {
288 0     0 0 0 my $self = shift;
289              
290 0         0 return 0;
291             }
292              
293             # ****************************************************************
294             sub getascii {
295 0     0 0 0 my $self = shift;
296              
297 0         0 my $string='';
298              
299 0         0 my $begday = $self->{FIRST}; # What day of the week is the first day of the month?
300              
301 0         0 my $month = Month_to_Text($self->{MONTH});
302 0         0 my $year = $self->{YEAR};
303 0         0 my $labels = "$month $year";
304 0         0 $string .= "$labels\n";
305              
306             # add in all the days
307              
308 0         0 my $numdays = Days_in_Month($year, $self->{MONTH}); # num days in month
309              
310 0         0 for (my $dom=1;$dom<=$numdays;$dom++) {
311 0         0 my $dayofweek = Day_of_Week_to_Text(Day_of_Week($year,$self->{MONTH},$dom));
312 0         0 $string .= "\n--- $self->{MONTH}/$dom $dayofweek ---\n";
313 0         0 my $day = PlotCalendar::Day->new($dom);
314 0         0 $day -> dayname($self->{DAYNAME}[$dom]);
315 0         0 $day -> text(@{$self->{TEXT}[$dom]});
  0         0  
316 0         0 $string .= $day -> getascii; # ------- add a day
317             }
318              
319             # [\@preference,\@text,\@color,\@style,\@size]
320             # print out comments, if there are any
321              
322 0 0       0 if ($self->{COMMFLAG}) {
323 0         0 my @text = @{$self->{COMMENTS}[1]};
  0         0  
324 0         0 $string .= join("\n",@text) . "\n";
325             }
326              
327              
328 0         0 return $string;
329             }
330              
331             # ****************************************************************
332             sub dayname {
333 1     1 0 5 my $self = shift;
334 1 50       2 if (@_) {
335 1         2 @{$self->{DAYNAME}} = @_;
  1         13  
336             }
337 0         0 else { return @{$self->{DAYNAME}};}
  0         0  
338             }
339              
340             # ****************************************************************
341             sub htmlref {
342 0     0 0 0 my $self = shift;
343 0 0       0 if (@_) {
344 0         0 @{$self->{HTMLREF}} = @_;
  0         0  
345             }
346 0         0 else { return @{$self->{HTMLREF}};}
  0         0  
347             }
348              
349             # ****************************************************************
350             sub text {
351 1     1 0 4 my $self = shift;
352 1 50       3 if (@_) {
353 1         2 @{$self->{TEXT}} = @_;
  1         4  
354             }
355 0         0 else { return @{$self->{TEXT}};}
  0         0  
356             }
357              
358             # ****************************************************************
359             sub textcolor {
360 1     1 0 4 my $self = shift;
361 1 50       2 if (@_) {
362 1         2 @{$self->{TEXTCOL}} = @_;
  1         4  
363             }
364 0         0 else { return @{$self->{TEXTCOL}};}
  0         0  
365             }
366              
367             # ****************************************************************
368             sub textsize {
369 1     1 0 4 my $self = shift;
370 1 50       3 if (@_) {
371 1         6 @{$self->{TEXTSIZE}} = @_;
  1         16  
372             }
373 0         0 else { return @{$self->{TEXTSIZE}};}
  0         0  
374             }
375              
376             # ****************************************************************
377             sub textstyle {
378 1     1 0 4 my $self = shift;
379 1 50       2 if (@_) {
380 1         2 @{$self->{TEXTSTYLE}} = @_;
  1         4  
381             }
382 0         0 else { return @{$self->{TEXTSTYLE}};}
  0         0  
383             }
384              
385             # ****************************************************************
386             sub textref {
387 1     1 0 4 my $self = shift;
388 1 50       2 if (@_) {
389 1         1 @{$self->{TEXTREF}} = @_;
  1         4  
390             }
391 0         0 else { return @{$self->{TEXTREF}};}
  0         0  
392             }
393              
394             # ****************************************************************
395             sub nameref {
396 1     1 0 5 my $self = shift;
397 1 50       2 if (@_) {
398 1         1 @{$self->{NAMEREF}} = @_;
  1         6  
399             }
400 0         0 else { return @{$self->{NAMEREF}};}
  0         0  
401             }
402              
403             # ****************************************************************
404             sub comments {
405 1     1 0 13 my $self = shift;
406 1 50       2 if (@_) {
407 1         2 @{$self->{COMMENTS}} = @_;
  1         2  
408 1         8 $self->{COMMFLAG}=1;
409             }
410 0         0 else { return @{$self->{COMMENTS}};}
  0         0  
411             }
412              
413             # ****************************************************************
414             sub htmlexpand {
415 0     0 0 0 my $self = shift;
416 0         0 my @ans = qw( no yes );
417 0 0       0 if (@_) {
418 0         0 $self->{EXPAND} = 0;
419 0 0       0 if ( $_[0] eq 'yes' ) {$self->{EXPAND} = 1;}
  0         0  
420             }
421 0         0 else { return $ans[$self->{EXPAND}];}
422             }
423              
424             # ****************************************************************
425             sub bgcolor {
426 1     1 0 4 my $self = shift;
427 1 50       3 if (@_) {
428 1 50       2 if ($#_ > 0) { # I have an array
429 1         8 @{$self->{BGCOLOR}} = @_;
  1         8  
430             }
431             else { # I have a single value
432 0         0 my $color = shift;
433 0         0 for (my $i=1;$i<=31;$i++) {
434 0         0 $self->{BGCOLOR}[$i] = $color;
435             }
436             }
437             }
438 0         0 else { return @{$self->{BGCOLOR}};}
  0         0  
439             }
440              
441             # ****************************************************************
442             sub fgcolor {
443 1     1 0 852 my $self = shift;
444 1 50       4 if (@_) {
445 1 50       9 if ($#_ > 0) { # I have an array
446 0         0 @{$self->{FGCOLOR}} = @_;
  0         0  
447             }
448             else { # I have a single value
449 1         2 my $color = shift;
450 1         5 for (my $i=1;$i<=31;$i++) {
451 31         59 $self->{FGCOLOR}[$i] = $color;
452             }
453             }
454             }
455 0         0 else { return @{$self->{FGCOLOR}};}
  0         0  
456             }
457              
458             # ****************************************************************
459             sub artwork {
460 1     1 0 3 my $self = shift;
461 1 50       2 if (@_) {
462 1         3 $self->{ARTWORK} = shift;
463             }
464 0         0 else { return $self->{ARTWORK};}
465             }
466              
467             # ****************************************************************
468             sub firstday {
469 1     1 0 4 my $self = shift;
470 1         2 my @tst = qw( Sun Mon Tue Wed Thu Fri Sat );
471 1         2 my %tst;
472 1         3 for (@tst) { $tst{$_} = 1; }
  7         10  
473 1 50       2 if (@_) {
474 1         2 my $day = shift;
475 1 50       4 if ( defined $tst{$day} ) {
476 1         5 $self->{FIRST} = $day;
477             }
478 0         0 else { die "Bad day value in call to firstday in Month.pm - $day\n";}
479             }
480 0         0 else { return $self->{FIRST};}
481             }
482              
483             # ****************************************************************
484             sub monthref {
485 0     0 0 0 my $self = shift;
486 0 0       0 if (@_) {
487 0         0 $self->{MONTHREF} = shift;
488             }
489 0         0 else { return $self->{MONTHREF}}
490             }
491              
492             # ****************************************************************
493             sub cliptext {
494 1     1 0 3 my $self = shift;
495 1 50       3 if (@_) {
496 1         2 $self->{CLIPTEXT} = shift;
497             }
498 0         0 else { return $self->{CLIPTEXT}}
499             }
500              
501             # ****************************************************************
502             sub size {
503 1     1 0 4 my $self = shift;
504 1 50       5 if (@_) {
505 1         7 $self->{SIZE}{height} = shift;
506 1         2 $self->{SIZE}{width} = shift;
507 1         6 $self->{CELLWIDTH} = int($self->{SIZE}{width}/7);
508             }
509 0         0 else { return ($self->{SIZE}{height},$self->{SIZE}{width});}
510             }
511              
512             # ****************************************************************
513             sub font {
514 1     1 0 4 my $self = shift;
515 1 50       2 if (@_) {
516 1         2 $self->{FONT}{day} = shift;
517 1         2 $self->{FONT}{main} = shift;
518 1         2 $self->{FONT}{opt} = shift;
519             }
520 0         0 else { return ($self->{FONT}{day},$self->{FONT}{main},$self->{FONT}{opt},);}
521             }
522              
523             # ****************************************************************
524             sub styles {
525 1     1 0 5 my $self = shift;
526 1 50       3 if (@_) {
527 1         2 $self->{STYLES}{day} = shift;
528 1         1 $self->{STYLES}{main} = shift;
529 1         3 $self->{STYLES}{opt} = shift;
530             }
531 0         0 else { return ($self->{STYLES}{day},$self->{STYLES}{main},$self->{STYLES}{opt},);}
532             }
533              
534             # ****************************************************************
535             sub initialize {
536 1     1 0 2 my $self = shift;
537            
538             # default values
539              
540 1         2 $self->{SIZE}{height} = 700;
541 1         2 $self->{SIZE}{width} = 700;
542 1         2 $self->{FONT}{day} = '14';
543 1         2 $self->{FONT}{main} = '10';
544 1         2 $self->{FONT}{opt} = '8';
545 1         2 $self->{STYLES}{day} = 'b';
546 1         1 $self->{STYLES}{main} = 'bi';
547 1         2 $self->{STYLES}{opt} = 'n';
548 1         6 for (my $i=1;$i<=31;$i++) {
549 31         37 $self->{FGCOLOR}[$i] = 'BLACK';
550 31         37 $self->{BGCOLOR}[$i] = '#33cc00'; # green
551 31         67 $self->{DAYNAME}[$i] = '';
552             }
553              
554             # utility values
555 1         2 %{$self->{'FONT_TABLE'}}=(
  1         10  
556             "3" => "-2",
557             "4" => "-2",
558             "5" => "-1",
559             "6" => "-1",
560             "7" => "+0",
561             "8" => "+0",
562             "9" => "+1",
563             "10" => "+1",
564             "11" => "+2",
565             "12" => "+2",
566             "13" => "+3",
567             "14" => "+3",
568             "15" => "+4",
569             "16" => "+4",
570             );
571              
572            
573             }
574              
575             1;
576             __END__