view release on metacpan or  search on metacpan

lib/Tk/Year.pm  view on Meta::CPAN

#! /usr/bin/env perl

;#                                                               
;# COPYRIGHT
;# Copyright (c) 1998-2007 Anthony R Fletcher.  All rights reserved.  This
;# module is free software; you can redistribute it and/or modify it
;# under the same terms as Perl itself.
;#
;# Please retain my name on any bits taken from this code.
;# This code is supplied as-is - use at your own risk.
;#                                                               
;#			AR Fletcher.

;# This is a Tk month browser.
;# Place into Tk/Year.pm somewhere in your perl-lib path.

use 5;
use warnings;
use strict;

package Tk::Year;

our $VERSION = '1.1';

use Carp;
use POSIX;
use Time::Local;
use Text::Abbrev;
use Tk;
use Tk::Widget;
use Tk::Month;

use base qw(Tk::Derived Tk::Frame);

Construct Tk::Widget 'Year';

sub debug {};
#sub debug { print STDERR @_; };

;# ---------------------------------------------------------------------

;## Constructor.  Uses new inherited from base class
sub Populate
{
	debug "args: @_\n";

	my $self = shift;
	my $args = shift;

	# Create all the widgets, but don't pack them.
	$self->SUPER::Populate($args);
	
	# Construct the subwidgets.
	$self->{frame} = $self->make();

	# Set up extra configuration
	$self->ConfigSpecs(
		'-cols'		=> ['METHOD',undef,undef, 3],
		'-year'		=> ['METHOD',undef,undef, (localtime())[5]+1900],

		'-press'	=> ['METHOD',undef,undef, undef],
		'-command'	=> '-press',

		# configurable from Xdefaults file.
		'-font'		=> ['CHILDREN','font','Font', undef],
		'-first'	=> ['METHOD','first','First', 0],
		'-sep'		=> ['METHOD','sep','Sep', 3],
		'-buttonhighlightcolor'	=> ['METHOD','buttonhighlightcolor','ButtonHighlightColor', ''],
		'-buttonhighlightbackground'	=> ['METHOD','buttonhighlightbackground','ButtonHighlightBackground', ''],
		'-buttonfg'	=> ['METHOD','buttonfg','ButtonFg', ''],
		'-buttonbg'	=> ['METHOD','buttonbg','ButtonBg', ''],
		'-buttonbd'	=> ['METHOD','buttonbd','ButtonBd', ''],
		'-buttonrelief'	=> ['METHOD','buttonrelief','ButtonRelief', ''],
	);

	# Any further contracts happen to the title widget.
	$self->Delegates(
		Construct => $self->{title},
		DEFAULT => $self->{title},
	);

	# return widget.
	$self;
}

;# Create all the subwidgets needed
sub make
{
	debug "args: @_\n";

	my $self	= shift;

	my $width = 2;