root/Date-Range-Birth/trunk/lib/Date/Range/Birth.pm

Revision 368 (checked in by miyagawa, 18 years ago)

0.02

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
Line 
1 package Date::Range::Birth;
2
3 use strict;
4 use vars qw($VERSION);
5 $VERSION = '0.02';
6
7 require Date::Range;
8 use base qw(Date::Range);
9
10 use Date::Calc;
11 use Date::Simple;
12
13 sub _croak { require Carp; Carp::croak(@_) }
14
15 sub new {
16     my($class, $age, $date) = @_;
17     $date ||= Date::Simple->new; # default today
18     unless (UNIVERSAL::isa($date, 'Date::Simple')) {
19         _croak("date should be given as Date::Simple object: $date");
20     }
21
22     my($start, $end);
23     if (ref($age) && ref($age) eq 'ARRAY') {
24         ($start, $end) = $class->_from_array($age, $date);
25     }
26     elsif ($age =~ /^\d+$/) {
27         ($start, $end) = $class->_from_age($age, $date);
28     } else {
29         _croak("invalid argument for Date::Range::Birth: $age");
30     }
31     return $class->SUPER::new($start, $end);
32 }
33
34 sub _from_age {
35     my($class, $age, $date) = @_;
36
37     my @start = Date::Calc::Add_Delta_YMD(_ymd($date),  -$age - 1, 0, 1);
38     my @end   = Date::Calc::Add_Delta_YMD(_ymd($date),  -$age, 0, 0);
39
40     return Date::Simple->new(@start), Date::Simple->new(@end);
41 }
42
43 sub _from_array {
44     my($class, $age, $date) = @_;
45     my @ages = sort { $a <=> $b } @$age;
46     @ages == 2 or _croak("Date::Range::Birth: invalid number of args in age");
47
48     # old's start to young's end
49     my @start = Date::Calc::Add_Delta_YMD(_ymd($date),  -$ages[1] - 1, 0, 1);
50     my @end   = Date::Calc::Add_Delta_YMD(_ymd($date),  -$ages[0], 0, 0);
51
52     return Date::Simple->new(@start), Date::Simple->new(@end);
53 }
54
55 sub _ymd {
56     my $date = shift;
57     return $date->year, $date->month, $date->day;
58 }
59
60 1;
61 __END__
62
63 =head1 NAME
64
65 Date::Range::Birth - range of birthday for an age
66
67 =head1 SYNOPSIS
68
69   use Date::Range::Birth;
70
71   # birthday for those who are 24 years old now
72   my $range = Date::Range::Birth->new(24);
73
74   # birthday for those who are 24 years old in 2001-01-01
75   my $date   = Date::Simple->new(2001, 1, 1);
76   my $range2 = Date::Range::Birth->new(24, $date);
77
78   # birthday for those who are between 20 and 30 yeard old now
79   my $range3 = Date::Range::Birth->new([ 20, 30 ]);
80
81 =head1 DESCRIPTION
82
83 Date::Range::Birth is a subclass of Date::Range, which provides a way
84 to construct range of dates for birthday.
85
86 =head1 METHODS
87
88 =over 4
89
90 =item new
91
92   $range = Date::Range::Birth->new($age);
93   $range = Date::Range::Birth->new($age, $date);
94   $range = Date::Range::Birth->new([ $young, $old ]);
95   $range = Date::Range::Birth->new([ $young, $old ], $date);
96
97 returns Date::Range::Birth object for birthday of the age. If C<$date>
98 (Date::Simple object) provided, returns range of birthday for those
99 who are C<$age> years old in C<$date>. Default is today (now).
100
101 If the age is provided as array reference (like C<[ $young, $old ]>),
102 returns range of birthday for those who are between C<$young> -
103 C<$old> years old. It may be handy for searching teenagers, etc.
104
105 =back
106
107 Other methods are inherited from Date::Range. See L<Date::Range> for
108 details.
109
110 =head1 EXAMPLE
111
112 Your customer database schema:
113
114   CREATE TABLE customer (
115       name     varchar(64) NOT NULL,
116       birthday date NOT NULL
117   );
118
119 What you should do is to select name and birthday of the customers who are
120 2X years old (between 20 and 29).
121
122   use DBI;
123   use Date::Range::Birth;
124
125   my $dbh = DBI->connect( ... );
126   my $range = Date::Range::Birth->new([ 20, 29 ]);
127
128   my $sth = $dbh->prepare(<<'SQL')
129   SELECT name, birthday FROM customer WHERE birthday >= ? AND birthday <= ?
130   SQL
131
132   # Date::Simple overloads to 'yyyy-mm-dd'!
133   $sth->execute($range->start, $range->end);
134
135   while (my $data = $sth->fetchrow_arrayref) {
136       print "name: $data->[0] birthday: $data->[1]\n";
137   }
138   $dbh->disconnect;
139
140 =head1 AUTHOR
141
142 Original idea by ikechin E<lt>ikebe@cpan.orgE<gt>
143
144 Code implemented by Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
145
146 This library is free software; you can redistribute it and/or modify
147 it under the same terms as Perl itself.
148
149 =head1 SEE ALSO
150
151 L<Date::Range>, L<Date::Simple>, L<Date::Calc>
152
153 =cut
Note: See TracBrowser for help on using the browser.