1use strict;
2use warnings;
3
4use Prima;
5use Prima::Classes;
6use Prima::Label;
7use Prima::ComboBox;
8use Prima::Sliders;
9
10package Prima::Calendar;
11use vars qw(@ISA @non_locale_months @days_in_months $OB_format);
12@ISA = qw(Prima::Widget);
13
14my $posix_state;
15
16my @non_locale_months = qw(
17	January February March April May June
18	July August September October November December);
19
20@days_in_months = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
21
22sub profile_default
23{
24	my @date = (localtime(time))[3,4,5];
25	return {
26		%{$_[ 0]-> SUPER::profile_default},
27		scaleChildren  => 0,
28		date           => \@date,
29		useLocale      => 1,
30		day            => $date[0],
31		month          => $date[1],
32		year           => $date[2],
33		firstDayOfWeek => 0,
34	}
35}
36
37sub profile_check_in
38{
39	my ( $self, $p, $default) = @_;
40	$p-> {date} = $default-> {date} unless exists $p-> {date};
41	$p-> {date}-> [0] = $p-> {day}   if exists $p-> {day};
42	$p-> {date}-> [1] = $p-> {month} if exists $p-> {month};
43	$p-> {date}-> [2] = $p-> {year}  if exists $p-> {year};
44	$self-> SUPER::profile_check_in( $p, $default);
45}
46
47sub init
48{
49	my $self = shift;
50	$self-> {$_} = 0 for qw( day month year useLocale firstDayOfWeek);
51	$self-> {date} = [0,0,0];
52	my %profile = $self-> SUPER::init(@_);
53	$self-> {useLocale} = can_use_locale() if $profile{useLocale};
54
55	my $fh = $self-> font-> height;
56	my ( $w, $h) = $self-> size;
57	$self-> reset_days;
58
59	my $right_offset = $self-> font-> width * 9;
60	$self-> insert( ComboBox =>
61		origin   => [ 5, $h - $fh * 2 - 10 ],
62		size     => [ $w - $right_offset - 15, $fh + 4],
63		name     => 'Month',
64		items    => $self-> make_months,
65		style    => cs::DropDownList,
66		growMode => gm::GrowHiX | gm::GrowLoY,
67		delegations => [ 'Change' ],
68	);
69
70	$self-> insert( Label =>
71		origin => [ 5, $h - $fh - 4],
72		size   => [ $w - $right_offset - 15, $fh + 2],
73		text   => '~Month',
74		focusLink => $self-> Month,
75		growMode => gm::GrowHiX | gm::GrowLoY,
76	);
77
78	$self-> insert( SpinEdit =>
79		origin => [ $w - $right_offset - 5, $h - $fh * 2 - 10 ],
80		size   => [ $right_offset, $fh + 4],
81		name   => 'Year',
82		min    => 1900,
83		max    => 2099,
84		growMode => gm::GrowLoX | gm::GrowLoY,
85		delegations => [ 'Change' ],
86	);
87
88	$self-> insert( Label =>
89		origin => [ $w - $right_offset - 5, $h - $fh - 4],
90		size   => [ $right_offset, $fh + 2],
91		text   => '~Year',
92		focusLink => $self-> Year,
93		growMode => gm::GrowLoX | gm::GrowLoY,
94	);
95
96	$self-> insert( Widget =>
97		origin      => [ 5, 5 ],
98		size        => [ $w - 10, $h - $fh * 3 - 22 ],
99		name        => 'Day',
100		selectable  => 1,
101		current     => 1,
102		delegations => [ qw(
103			Paint MouseDown MouseMove MouseUp MouseWheel MouseLeave
104			KeyDown Size FontChanged Enter Leave
105		)],
106		growMode    => gm::Client,
107	);
108
109	$self-> insert( Label =>
110		origin => [ 5, $h - $fh * 3 - 15],
111		size   => [ $w - 10, $fh + 2],
112		text   => '~Day',
113		focusLink => $self-> Day,
114		growMode => gm::GrowHiX | gm::GrowLoY,
115	);
116	$self-> $_($profile{$_}) for qw( date useLocale firstDayOfWeek);
117}
118
119
120sub can_use_locale
121{
122	return $posix_state if defined $posix_state;
123	undef $@;
124	eval "use POSIX q(strftime);";
125	return $posix_state = 1 unless $@;
126	return $posix_state = 0;
127}
128
129sub month2str
130{
131	return $non_locale_months[$_[1]] unless $_[0]-> {useLocale};
132	return POSIX::strftime ( "%B", 0, 0, 0, 1, $_[1], 0 );
133}
134
135sub make_months
136{
137	return \@non_locale_months unless $_[0]-> {useLocale};
138	unless ( defined $OB_format) {
139		# %OB is a BSD extension for locale-specific date string
140		# for use without date
141		$OB_format = (
142			POSIX::strftime ( "%OB", 0, 0, 0, 1, 0, 0 ) eq
143			POSIX::strftime ( "%OB", 0, 0, 0, 1, 1, 0 )
144		) ? '%B' : '%OB';
145	}
146	return [ map {
147		POSIX::strftime ( $OB_format, 0, 0, 0, 1, $_, 0 )
148	} 0 .. 11 ];
149}
150
151sub day_of_week
152{
153	my ( $self, $day, $month, $year, $useFirstDayOfWeek) = @_;
154	$month++; $year += 1900;
155
156	$useFirstDayOfWeek = 1 unless defined $useFirstDayOfWeek;
157
158	if ( $month < 3) {
159		$month += 10;
160		$year--;
161	} else {
162		$month -= 2;
163	}
164	my $century = int($year / 100);
165	$year %= 100;
166	my $dow = ( int(( 26 * $month - 2) / 10) + $day + $year + int($year / 4) +
167		int($century / 4) - ( 2 * $century) -
168		(( $useFirstDayOfWeek ? 1 : 0) * $self-> {firstDayOfWeek}) + 7)
169		% 7;
170	return ($dow < 0) ? $dow + 7 : $dow;
171}
172
173sub reset_days
174{
175	my $self = $_[0];
176	my $dow = $self-> {firstDayOfWeek};
177	$self-> {days} = $self-> {useLocale} ?
178	[ map { strftime("%a", 0, 0, 0, $_, 0, 0) } 0 .. 6 ] :
179	[ qw( Sun Mon Tue Wed Thu Fri Sat ) ];
180	push @{$self-> {days}}, splice( @{$self-> {days}}, 0, $dow) if $dow;
181}
182
183sub useLocale
184{
185	return $_[0]-> {useLocale} unless $#_;
186	my ( $self, $useLocale) = @_;
187	$useLocale = can_use_locale if $useLocale;
188	$self-> {useLocale} = $useLocale;
189	$self-> Month-> items( $self-> make_months);
190	$self-> Month-> text( $self-> Month-> List-> get_item_text( $self-> Month-> focusedItem));
191	$self-> reset_days;
192	my $day = $self-> Day;
193	$self-> day_reset( $day, $day-> size);
194	$day-> repaint;
195}
196
197sub Day_Paint
198{
199	my ( $owner, $self, $canvas) = @_;
200
201	my @sz = $self-> size;
202	$canvas-> set( color => $self-> disabledColor, backColor => $self-> disabledBackColor)
203		unless $self-> enabled;
204	$canvas-> rect3d( Prima::rect->new(@sz)->inclusive, 2,
205		$self-> dark3DColor, $self-> light3DColor, $self-> backColor);
206
207	my @zs = ( $self-> {X}, $self-> {Y}, $self-> {CX1}, $self-> {CY});
208	my $i;
209	my $c = $canvas-> color;
210	$canvas-> color( $self-> prelight_color($canvas-> backColor));
211	$canvas-> bar( 2, $sz[1] - $zs[1] - 3, $sz[0] - 3, $sz[1] - 3);
212	$canvas-> color($c);
213	$canvas-> clipRect( Prima::rect->new(@sz)->shrink(2)->inclusive );
214	my $fdo = $owner-> firstDayOfWeek ? 6 : 0;
215	for ( $i = 0; $i < 7; $i++) {
216		my $tw = $canvas->get_text_width( $owner-> {days}-> [$i] );
217		$canvas-> color( 0xc00000 ) if $i == $fdo;
218		$canvas-> text_shape_out( $owner-> {days}-> [$i],
219			$i * $zs[0] + ($self->{X} - $tw)/2, $sz[1]-$zs[1]+$zs[3],
220		);
221		$canvas-> color( $c ) if $i == $fdo;
222	}
223
224	my ( $d, $m, $y) = @{$owner-> {date}};
225	my $dow = $owner-> day_of_week( 1, $m, $y);
226	my $v = $days_in_months[ $m] + (((( $y % 4) == 0) && ( $m == 1)) ? 1 : 0);
227	$y = $sz[1] - $zs[1] * 2 + $zs[3] - 3;
228	$d--;
229	my $prelight = ($self->{prelight} || 0) - 1;
230	for ( $i = 0; $i < $v; $i++) {
231		if ( $d == $i || $prelight == $i) {
232			my $bk = ($d == $i) ? cl::Hilite : cl::Back;
233			$bk = $self->prelight_color($bk) if $prelight == $i;
234			$canvas-> color($bk);
235			$canvas-> bar(
236				$dow * $zs[0] + 2, $y - $zs[3],
237				( 1 + $dow) * $zs[0] - 1, $y - $zs[3] + $zs[1] - 1
238			);
239			$canvas-> color(( $d == $i) ? cl::HiliteText : cl::Fore);
240			$canvas-> color( 0xc00000 ) if $d != $i && $dow == $fdo;
241			$canvas-> text_shape_out( $i + 1, $dow * $zs[0] + $zs[2], $y);
242			$canvas-> rect_focus(
243				$dow * $zs[0] + 2, $y - $zs[3],
244				( 1 + $dow) * $zs[0] - 1, $y - $zs[3] + $zs[1] - 1
245			) if $d == $i && $self-> focused;
246			$canvas-> color( $c);
247		} else {
248			$canvas-> color( 0xc00000 ) if $dow == $fdo;
249			$canvas-> text_shape_out( $i + 1, $dow * $zs[0] + $zs[2], $y);
250			$canvas-> color( $c ) if $dow == $fdo;
251		}
252		$zs[2] = $self-> {CX2} if $i == 8;
253		next unless $dow++ == 6;
254		$y -= $zs[1];
255		$dow = 0;
256	}
257}
258
259sub Day_KeyDown
260{
261	my ( $owner, $self, $code, $key, $mod, $repeat) = @_;
262	return unless grep { $key == $_ } (
263		kb::Left, kb::Right, kb::Down, kb::Up, kb::PgUp, kb::PgDn
264	);
265	my ( $d, $m, $y) = @{$owner-> {date}};
266	$d--  if $key == kb::Left;
267	$d++  if $key == kb::Right;
268	$d+=7 if $key == kb::Down;
269	$d-=7 if $key == kb::Up;
270	if ( $key == kb::PgDn) {
271		( $m == 11) ? ($y++, $m = 0) : $m++;
272	}
273	if ( $key == kb::PgUp) {
274		( $m == 0) ? ($y--, $m = 11) : $m--;
275	}
276	$self-> clear_event;
277	$owner-> date( $d, $m, $y);
278}
279
280sub xy2day
281{
282	my ($self, $x, $y) = @_;
283	my $widget = $self->Day;
284	my ( $day, $month, $year) = @{$self-> {date}};
285	my @zs = ( $widget-> {X}, $widget-> {Y});
286	my $v = $days_in_months[ $month] + (((( $year % 4) == 0) && ( $month == 1)) ? 1 : 0);
287	my @sz = $widget-> size;
288	$day = (int(($sz[1] - $y - 2) / $zs[1]) - 1) * 7 +
289		int(($x - 2) / $zs[0]) - $self-> day_of_week( 1, $month, $year) + 1;
290	return ($day <= 0 || $day > $v) ? undef : $day;
291}
292
293sub day2xy
294{
295	my ($self, $day) = @_;
296	my (undef, $month, $year) = @{$self-> {date}};
297	my $v = $days_in_months[ $month] + (((( $year % 4) == 0) && ( $month == 1)) ? 1 : 0);
298	return if $day <= 0 || $day > $v;
299	my $widget = $self->Day;
300	my @zs = ( $widget-> {X}, $widget-> {Y});
301	my @sz = $widget-> size;
302
303	$day = $day - 1 + $self->day_of_week(1, $month, $year);
304	my ($x, $y) =  ($zs[0] * ($day % 7) + 2, $sz[1] - 2 - $zs[1] * (2 + int($day / 7)) - 1);
305	return $x, $y, $x + $zs[0] + 1, $y + $zs[1];
306}
307
308sub Day_MouseDown
309{
310	my ( $owner, $self, $btn, $mod, $x, $y) = @_;
311	return unless $btn == mb::Left;
312	my ( undef, $month, $year) = @{$owner-> {date}};
313	my $day = $owner->xy2day($x,$y);
314	$self-> clear_event;
315	return unless defined $day;
316	$self-> {mouseTransaction} = 1;
317	delete $self->{prelight};
318	$owner-> date( $day, $month, $year);
319}
320
321sub Day_MouseMove
322{
323	my ( $owner, $self, $mod, $x, $y) = @_;
324	my ( undef, $month, $year) = @{$owner-> {date}};
325	my $day = $owner->xy2day($x,$y);
326	unless ($self-> {mouseTransaction}) {
327		if (( $self->{prelight} // -1 ) != ( $day // -1 )) {
328			my $p = $self->{prelight};
329			$self->{prelight} = $day;
330			my $r = Prima::rect->new( defined($p) ? $owner->day2xy($p) : ());
331			$r = $r->union( Prima::rect->new( $owner->day2xy($day) )) if defined $day;
332			$self->invalidate_rect( @$r ) unless $r->is_empty;
333		}
334		return;
335	}
336	$self-> clear_event;
337	$owner-> date( $day, $month, $year) if defined $day;
338}
339
340sub Day_MouseUp
341{
342	my ( $owner, $self, $btn, $mod, $x, $y) = @_;
343	return unless $btn == mb::Left && $self-> {mouseTransaction};
344	delete $self-> {mouseTransaction};
345	$self-> clear_event;
346}
347
348sub Day_MouseLeave
349{
350	my ($owner,$self) = @_;
351	my $p = delete $self->{prelight} or return;
352	my @p = $owner-> day2xy($p) or return;
353	$self-> invalidate_rect(@p);
354}
355
356sub Day_MouseWheel
357{
358	my ( $self, $widget, $mod, $x, $y, $z) = @_;
359	my ( $day, $month, $year) = @{$self-> {date}};
360	if ( $z > 0) {
361		if ( --$day < 1) {
362			if ( --$month < 0) {
363				return if --$year < 0;
364				$month = 11;
365			}
366			$day = $days_in_months[$month];
367		}
368	} elsif ( ++$day > $days_in_months[$month]) {
369		if ( ++$month > 11) {
370			return if ++$year > 199;
371			$month = 0;
372		}
373		$day = 1;
374	}
375	$self-> date( $day, $month, $year);
376	$widget-> clear_event;
377}
378
379sub day_reset
380{
381	my ( $owner, $self, $x, $y) = @_;
382	$self-> {X} = int(( $x - 4) / 7 );
383	$self-> {Y} = int(( $y - 4) / 7 );
384	$self-> begin_paint_info;
385	my ($x1,$x2,$x3) = (
386		$self-> get_text_width('8'),
387		$self-> get_text_width('28'),
388		$self-> get_text_width( $owner-> {days}-> [0])
389	);
390	$x3 += $x1/2;
391	$y = $self-> font-> height;
392	$self-> end_paint_info;
393	$self-> {X} = $x2 if $self-> {X} < $x2;
394	$self-> {X} = $x3 if $self-> {X} < $x3;
395	$self-> {Y} = $y if $self-> {Y} < $y;
396	$self-> {CX1} = int(( $self-> {X} - $x1 ) / 2) + 4;
397	$self-> {CX2} = int(( $self-> {X} - $x2 ) / 2) + 4;
398	$self-> {CY} = int(( $self-> {Y} - $y ) / 2);
399}
400
401sub Day_Size
402{
403	my ( $owner, $self, $ox, $oy, $x, $y) = @_;
404	$owner-> day_reset( $self, $x, $y);
405}
406
407sub Day_FontChanged
408{
409	$_[0]-> day_reset( $_[1], $_[1]-> size);
410}
411
412sub Day_Enter { $_[1]-> repaint }
413sub Day_Leave { $_[1]-> repaint }
414
415sub Month_Change
416{
417	my ( $owner, $self) = @_;
418	$owner-> month( $self-> focusedItem);
419}
420
421sub Year_Change
422{
423	my ( $owner, $self) = @_;
424	$owner-> year( $self-> value - 1900);
425}
426
427sub date
428{
429	return @{$_[0]-> {date}} unless $#_;
430	my $self = shift;
431	my ($day, $month, $year) = $#_ ? @_ : @{$_[0]} ;
432	$month = 11 if $month > 11;
433	$month = 0 if $month < 0;
434	$year = 0 if $year < 0;
435	$year = 199 if $year > 199;
436	$day = 1 if $day < 1;
437	my $v = $days_in_months[ $month] +
438		(((( $year % 4) == 0) && ( $month == 1)) ? 1 : 0);
439	$day = $v if $day > $v;
440	my @od = @{$self-> {date}};
441	return if $day == $od[0] && $month == $od[1] && $year == $od[2];
442	$self-> {date} = [ $day, $month, $year ];
443	$self-> Year-> value( $year + 1900);
444	$self-> Month-> focusedItem( $month);
445	my $widget = $self->Day;
446	if ( $month == $od[1] && $year == $od[2] ) {
447		my $r = Prima::rect->new( $self->day2xy($od[0]) );
448		$r = $r->union( Prima::rect->new(  $self->day2xy($day) ));
449		$widget->invalidate_rect( @$r ) unless $r->is_empty;
450	} else {
451		delete $widget->{prelight};
452		$widget->invalidate_rect( 2, 2, $widget-> width - 3, $widget-> height - $widget-> {Y} - 3);
453	}
454	$self-> notify(q(Change));
455}
456
457sub day
458{
459	return $_[0]-> {date}-> [0] unless $#_;
460	return if $_[0]-> {date}-> [0] == $_[1];
461	$_[0]-> date( $_[1], $_[0]-> {date}-> [1],$_[0]-> {date}-> [2]);
462}
463
464sub month
465{
466	return $_[0]-> {date}-> [1] unless $#_;
467	return if $_[0]-> {date}-> [1] == $_[1];
468	$_[0]-> date( $_[0]-> {date}-> [0],$_[1],$_[0]-> {date}-> [2]);
469}
470
471sub year
472{
473	return $_[0]-> {date}-> [2] unless $#_;
474	return if $_[0]-> {date}-> [2] == $_[1];
475	$_[0]-> date( $_[0]-> {date}-> [0],$_[0]-> {date}-> [1],$_[1]);
476}
477
478sub date_as_string
479{
480	my $self = shift;
481	my ( $d, $m, $y) = ( @_ ? ( $#_ ? @_ : @{$_[0]}) : @{ $self-> {date}});
482	$y += 1900;
483	return $self-> month2str( $m) . " $d, $y";
484}
485
486sub date_from_time
487{
488	$_[0]-> date( @_[4,5,6]);
489}
490
491sub firstDayOfWeek
492{
493	return $_[0]-> {firstDayOfWeek} unless $#_;
494	my ( $self, $dow) = @_;
495	$dow %= 7;
496	return if $dow == $self-> {firstDayOfWeek};
497	$self-> {firstDayOfWeek} = $dow;
498	$self-> reset_days;
499	$self-> Day-> repaint;
500}
501
5021;
503
504=pod
505
506=head1 NAME
507
508Prima::Calendar - standard calendar widget
509
510=head1 SYNOPSIS
511
512	use Prima qw(Calendar Application);
513	my $cal = Prima::Calendar-> create(
514		useLocale => 1,
515		size      => [ 150, 150 ],
516		onChange  => sub {
517			print $_[0]-> date_as_string, "\n";
518		},
519	);
520	$cal-> date_from_time( localtime );
521	$cal-> month( 5);
522	run Prima;
523
524=for podview <img src="calendar.gif">
525
526=for html <p><img src="https://raw.githubusercontent.com/dk/Prima/master/pod/Prima/calendar.gif">
527
528=head1 DESCRIPTION
529
530Provides interactive selection of date between 1900 and 2099 years.
531The main property, L<date>, is a three-integer array, day, month, and year,
532in the format of perl localtime ( see L<perlfunc/localtime> ) -
533day can be in range from 1 to 31,month from 0 to 11, year from 0 to 199.
534
535=head1 API
536
537=head2 Events
538
539=over
540
541=item Change
542
543Called when the L<date> property is changed.
544
545=back
546
547=head2 Properties
548
549=over
550
551=item date DAY, MONTH, YEAR
552
553Accepts three integers in format of C<localtime>.
554DAY can be from 1 to 31, MONTH from 0 to 11, YEAR from 0 to 199.
555
556Default value: today's date.
557
558=item day INTEGER
559
560Selects the day in month.
561
562=item firstDayOfWeek INTEGER
563
564Selects the first day of week, an integer between 0 and 6,
565where 0 is Sunday is the first day, 1 is Monday etc.
566
567Default value: 0
568
569=item month
570
571Selects the month.
572
573=item useLocale BOOLEAN
574
575If 1, the locale-specific names of months and days of week are used.
576These are read by calling C<POSIX::strftime>. If invocation of POSIX module
577fails, the property is automatically assigned to 0.
578
579If 0, the English names of months and days of week are used.
580
581Default value: 1
582
583See also: L<date_as_string>
584
585=item year
586
587Selects the year.
588
589=back
590
591=head2 Methods
592
593=over
594
595=item can_use_locale
596
597Returns boolean value, whether the locale information can be retrieved
598by calling C<strftime>.
599
600=item month2str MONTH
601
602Returns MONTH name according to L<useLocale> value.
603
604=item make_months
605
606Returns array of 12 month names according to L<useLocale> value.
607
608=item day_of_week DAY, MONTH, YEAR, [ USE_FIRST_DAY_OF_WEEK = 1 ]
609
610Returns integer value, from 0 to 6, of the day of week on
611DAY, MONTH, YEAR date. If boolean USE_FIRST_DAY_OF_WEEK is set,
612the value of C<firstDayOfWeek> property is taken into the account,
613so 0 is a Sunday shifted forward by C<firstDayOfWeek> days.
614
615The switch from Julian to Gregorian calendar is ignored.
616
617=item date_as_string [ DAY, MONTH, YEAR ]
618
619Returns string representation of date on DAY, MONTH, YEAR according
620to L<useLocale> property value.
621
622=item date_from_time SEC, MIN, HOUR, M_DAY, MONTH, YEAR, ...
623
624Copies L<date> from C<localtime> or C<gmtime> result. This helper method
625allows the following syntax:
626
627	$calendar-> date_from_time( localtime( time));
628
629=back
630
631=head1 AUTHOR
632
633Dmitry Karasik, E<lt>dmitry@karasik.eu.orgE<gt>.
634
635=head1 SEE ALSO
636
637L<Prima>, L<Prima::Widget>, L<POSIX>, L<perlfunc/localtime>, L<perlfunc/time>,
638F<examples/calendar.pl>.
639
640=cut
641