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