File Coverage

blib/lib/Calendar/Simple.pm
Criterion Covered Total %
statement 64 64 100.0
branch 29 30 96.7
condition 15 20 75.0
subroutine 9 9 100.0
pod 2 2 100.0
total 119 125 95.2


line stmt bran cond sub pod time code
1             # $Id: Simple.pm 39 2006-10-16 19:41:18Z dave $
2              
3             =head1 NAME
4            
5             Calendar::Simple - Perl extension to create simple calendars
6            
7             =head1 SYNOPSIS
8            
9             use Calendar::Simple;
10            
11             my @curr = calendar; # get current month
12             my @this_sept = calendar(9); # get 9th month of current year
13             my @sept_2002 = calendar(9, 2002); # get 9th month of 2002
14             my @monday = calendar(9, 2002, 1); # get 9th month of 2002,
15             # weeks start on Monday
16            
17             my @span = date_span(mon => 10, # returns span of dates
18             year => 2006,
19             begin => 15,
20             end => 28);
21            
22             =cut
23              
24             package Calendar::Simple;
25              
26 4     4   130 use strict;
  4         56  
  4         72  
27 4     4   99 use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
  4         40  
  4         68  
28              
29             require Exporter;
30              
31             @ISA = qw(Exporter);
32              
33             @EXPORT = qw(calendar);
34             @EXPORT_OK = qw(date_span);
35             $VERSION = '1.17';
36              
37 4     4   200 use Time::Local;
  4         39  
  4         90  
38 4     4   72 use Carp;
  4         137  
  4         64  
39              
40 4     4   166 eval 'use DateTime';
  4         1076  
  4         84  
41             my $dt = ! $@;
42             $dt = 0 if $ENV{CAL_SIMPLE_NO_DT};
43              
44             my @days = qw(31 xx 31 30 31 30 31 31 30 31 30 31);
45              
46             =head1 DESCRIPTION
47            
48             A very simple module that exports one function called C<calendar>.
49            
50             =head2 calendar
51            
52             This function returns a data structure representing the dates in a month.
53             The data structure returned is an array of array references. The first
54             level array represents the weeks in the month. The second level array
55             contains the actual days. By default, each week starts on a Sunday and
56             the value in the array is the date of that day. Any days at the beginning
57             of the first week or the end of the last week that are from the previous or
58             next month have the value C<undef>.
59            
60             If the month or year parameters are omitted then the current month or
61             year are assumed.
62            
63             A third, optional parameter, start_day, allows you to set the day each
64             week starts with, with the same values as localtime sets for wday
65             (namely, 0 for Sunday, 1 for Monday and so on).
66            
67             =cut
68              
69             sub calendar {
70 32     32 1 332   my ($mon, $year, $start_day) = @_;
71              
72 32         895   my @now = (localtime)[4, 5];
73              
74 32 100       1052   $mon = ($now[0] + 1) unless $mon;
75 32 100       369   $year = ($now[1] + 1900) unless $year;
76 32 100       330   $start_day = 0 unless defined $start_day;
77              
78 32 100 100     389   croak "Year $year out of range" if $year < 1970 && !$dt;
79 31 100 100     461   croak "Month $mon out of range" if ($mon < 1 || $mon > 12);
80 27 100 100     370   croak "Start day $start_day out of range"
81                 if ($start_day < 0 || $start_day > 6);
82              
83 23         196   my $first;
84              
85 23 100       218   if ($dt) {
86 14         230     $first = DateTime->new(year => $year,
87             month => $mon,
88             day => 1)->day_of_week % 7;
89               } else {
90 9         116     $first = (localtime timelocal 0, 0, 0, 1, $mon -1, $year - 1900)[6];
91               }
92              
93 22         336   $first -= $start_day;
94 22 100       247   $first += 7 if ($first < 0);
95              
96 22         413   my @mon = (1 .. _days($mon, $year));
97              
98 22         325   my @first_wk = (undef) x 7;
99 22         297   @first_wk[$first .. 6] = splice @mon, 0, 6 - $first + 1;
100              
101 22         233   my @month = (\@first_wk);
102              
103 22         293   while (my @wk = splice @mon, 0, 7) {
104 86         1877     push @month, \@wk;
105               }
106              
107 22         186   $#{$month[-1]} = 6;
  22         375  
108              
109 22 100       416   return wantarray ? @month : \@month;
110             }
111              
112             =head2 date_span
113            
114             This function returns a cur-down version of a month data structure which
115             begins and ends on dates other than the first and last dates of the month.
116             Any weeks that fall completely outside of the date range are removed from
117             the structure and any days within the remaining weeks that fall outside
118             of the date range are set to C<undef>.
119            
120             As there are a number of parameters to this function, they are passed
121             using a named parameter interface. The parameters are as follows:
122            
123             =over 4
124            
125             =item year
126            
127             The required year. Defaults to the current year if omitted.
128            
129             =item mon
130            
131             The required month. Defaults to the current month if omitted.
132            
133             =item begin
134            
135             The first day of the required span. Defaults to the first if omitted.
136            
137             =item end
138            
139             The last day of the required span. Defaults to the last day of the month
140             if omitted.
141            
142             =item start_day
143            
144             Indicates the day of the week that each week starts with. This takes the same
145             values as the optional third parameter to C<calendar>. The default is 0
146             (for Sunday).
147            
148             =back
149            
150             This function isn't exported by default, so in order to use it in your
151             program you need to use the module like this:
152            
153             use Calendar::Simple 'date_span';
154            
155             =cut
156              
157             sub date_span {
158 3     3 1 39   my %params = @_;
159              
160 3         1027   my @now = (localtime)[4, 5];
161              
162 3   33     37   my $mon = $params{mon} || ($now[0] + 1);
163 3   33     33   my $year = $params{year} || ($now[1] + 1900);
164 3   100     38   my $begin = $params{begin} || 1;
165 3   66     33   my $end = $params{end} || _days($mon, $year);
166 3 50       32   my $start_day = defined $params{start_day} ? $params{start_day} : 0;
167              
168 3         31   my @cal = calendar($mon, $year, $start_day);
169              
170 3         38   while ($cal[0][6] < $begin) {
171 4         45     shift @cal;
172               }
173              
174 3         26   my $i = 0;
175 3         34   while ($cal[0][$i] < $begin) {
176 2         23     $cal[0][$i++] = undef;
177               }
178              
179 3         34   while ($cal[-1][0] > $end) {
180 2         25     pop @cal;
181               }
182              
183 3         27   $i = -1;
184 3         1635   while ($cal[-1][$i] > $end) {
185 4         41     $cal[-1][$i--] = undef;
186               }
187              
188 3         59   return @cal;
189             }
190              
191             sub _days {
192 23     23   228   my ($mon, $yr) = @_;
193              
194 23 100       2148   return $days[$mon - 1] unless $mon == 2;
195 8 100       82   return _isleap($yr) ? 29 : 28;
196             }
197              
198             sub _isleap {
199 8 100   8   109   return 1 unless $_[0] % 400;
200 6 100       71   return unless $_[0] % 100;
201 5 100       78   return 1 unless $_[0] % 4;
202 2         41   return;
203             }
204              
205             1;
206             __END__
207            
208             =head2 EXAMPLE
209            
210             A simple C<cal> replacement would therefore look like this:
211            
212             #!/usr/bin/perl -w
213            
214             use strict;
215             use Calendar::Simple;
216            
217             my @months = qw(January February March April May June July August
218             September October November December);
219            
220             my $mon = shift || (localtime)[4] + 1;
221             my $yr = shift || (localtime)[5] + 1900;
222            
223             my @month = calendar($mon, $yr);
224            
225             print "\n$months[$mon -1] $yr\n\n";
226             print "Su Mo Tu We Th Fr Sa\n";
227             foreach (@month) {
228             print map { $_ ? sprintf "%2d ", $_ : ' ' } @$_;
229             print "\n";
230             }
231            
232             A version of this example, called C<pcal>, is installed when you install this
233             module.
234            
235             =head2 Date Range
236            
237             This module will make use of DateTime.pm if it is installed. By using
238             DateTime.pm it can use any date that DateTime can represent. If DateTime
239             is not installed it uses Perl's built-in date handling and therefore
240             can't deal with dates before 1970 and it will also have problems with dates
241             after 2038 on a 32-bit machine.
242            
243             =head2 EXPORT
244            
245             C<calendar>
246            
247             =head1 AUTHOR
248            
249             Dave Cross <dave@mag-sol.com>
250            
251             =head1 ACKNOWLEDGEMENTS
252            
253             With thanks to Paul Mison <cpan@husk.org> for the start day patch.
254            
255             =head1 COPYRIGHT
256            
257             Copyright (C) 2002-2006, Magnum Solutions Ltd.. All Rights Reserved.
258            
259             This script is free software; you can redistribute it and/or
260             modify it under the same terms as Perl itself.
261            
262             =head1 SEE ALSO
263            
264             L<perl>, L<localtime>, L<DateTime>
265            
266             =cut
267