view release on metacpan or  search on metacpan

DateEntry.pm  view on Meta::CPAN

use base qw(Tk::Frame);
Construct Tk::Widget 'DateEntry';

sub ClassInit {
    my($class, $mw) = @_;
    $class->SUPER::ClassInit($mw);
    $mw->bind($class, "<Button-1>" => 'buttonDown');
}

sub Populate {
    my ($w, $args) = @_;

    $w->SUPER::Populate($args);

    # entry widget and arrow button
    my $e = $w->Entry;
    my $b = $w->Button(-bitmap => '@' . Tk->findINC("cbxarrow.xbm"));
    my $tl = $w->{_toplevel} = $w->Toplevel(-bd=>2,-relief=>'raised');

    $w->Advertise("entry" => $e);
    $w->Advertise("arrow" => $b);

    $tl->transient($w);
    $tl->overrideredirect(1);
    $tl->OnDestroy(sub { $w->{_status} = 'done' }); # XXX really needed?

    $b->pack(-side => "right", -padx => 0);
    $e->pack(-side => "right", -fill => 'x', -expand => 1, -padx => 0);

    # other initializations
    $b->bind("<Button-1>", [ $w => 'buttonDown' ]);
    $b->bind("<space>", [ $w => 'buttonDown' ]);
    $b->bind("<Key-Return>", [ $w => 'buttonDown' ]);
    $e->bind("<Key-Return>", [ $w => 'buttonDown' ]);
    $e->bind("<Up>",   [$w => 'rotateDay', +1, 1] );
    $e->bind("<Down>", [$w => 'rotateDay', -1, 1] );
    $e->bind("<Shift-Up>",   [$w => 'rotateDay', +1, 7] );
    $e->bind("<Shift-Down>", [$w => 'rotateDay', -1, 7] );
    $e->bind("$_",   [$w => 'rotateMonth', +1] )
	for qw(<Control-Up> <Prior>);
    $e->bind("$_", [$w => 'rotateMonth', -1] )
	for qw(<Control-Down> <Next>);
    $e->bind("<Shift-Control-Up>",   [$w => 'rotateYear', +1] );
    $e->bind("<Shift-Control-Down>", [$w => 'rotateYear', -1] );

    # XXX Not uses anymore due to problems with grab
    #$w->bind("<FocusOut>", sub { $w->popDown });

    # Create the buttons on the dropdown.
    my $fr = $w->{_frame} = $tl->Frame->pack(-anchor=>'n');

    # check whether Tk::FireButton is installed
    my $Button = eval { require Tk::FireButton; 1 } ? 'FireButton' : 'Button';

    # 1. Previous month:
    $w->{_backbutton}=$fr->$Button(-text=>'<<',-pady=>1,-padx=>1,-bd=>1,
				   -command=> ['prevMonth', $w])
	->grid(-row=>0,-column=>0);

    # 2. Label to put the monthname in:
    $w->{_monthlabel} = $fr->Label->grid(-row=>0,-column=>1,-columnspan=>5);

    # 3. Next month:
    $w->{_nextbutton}=$fr->$Button(-text=>'>>',-pady=>1,-padx=>1,-bd=>1,
				   -command=>['nextMonth', $w])
	->grid(-row=>0,-column=>6);

    # 4. Dayname labels:
    for (0..6) {
	$w->{_daylabel}->[$_] = $fr->Label->grid(-column=>$_,-row=>1);
    }

    # 5. Daybuttons. Note that we create button for six weeks, since it
    #    is possible that a month might span over six different weeks.
    #    The text on the buttons are just a dummy to force them to the
    #    correct size. When the calendar is popped up, the right text
    #    is inserted an unused buttons are gridForget'ed.
    for my $week (0..5) {
	for my $wday (0..6) {
	    $w->{_daybutton}->[$week]->[$wday] =
		$fr->Button(-bd=>1, -padx=>1, -pady=>1, -text=>'00',
			    -command => ['selectDay', $w, $week, $wday])
		    ->grid(-row=>$week+2,-column=>$wday,-sticky=>'nsew');
	}
    }
    $tl->withdraw;

    $w->{_popped} = 0;

    $w->Delegates(DEFAULT => $e);

    $w->ConfigSpecs
	(-arrowimage  => [{-image => $b}, qw/arrowImage ArrowImage/],
 	 -variable    => "-textvariable",
         -dateformat  => [qw/PASSIVE dateFormat DateFormat 1/],
	 -background  => [qw/METHOD background Background/],
# XXX should the class for these be Background?
	 -buttonbackground
           	      => [qw/METHOD buttonBackground ButtonBackground/],
	 -boxbackground
                      => [qw/METHOD boxBackground BoxBackground/],
	 -todaybackground
                      => [qw/PASSIVE todayBackground TodayBackground/],
	 -font        => [qw/DESCENDANTS font Font/],
	 -daynames    => [qw/PASSIVE daynames Daynames/,[qw/S M Tu W Th F S/]],
	 -weekstart   => [qw/PASSIVE weekstart Weekstart 0/],
	 -formatcmd   => [qw/CALLBACK formatCmd FormatCmd/,
			  ['defaultFormat',$w]],
	 -parsecmd    => [qw/CALLBACK parseCmd ParseCmd/,
			  ['defaultParse', $w]],
	 -configcmd   => [qw/CALLBACK configCmd ConfigCmd/, undef],
	 -headingfmt  => [qw/PASSIVE headingFmt HeadingFmt/, '%B %Y'],
	 -state       => [qw/METHOD state State normal/],
	 -width       => [$e, undef, undef, 10],
	 DEFAULT      => [$e] );
}

#---------------------------------------------------------------------------
# Configuration methods:
#
# -state works like the BrowseEntry's -state, in addition to 'normal'