Tk::TOTD - Tip Of The Day dialog for Perl/Tk.

Tk-TOTD documentation Contained in the Tk-TOTD distribution.

Index

Code Index:

NAME

Top

Tk::TOTD - Tip Of The Day dialog for Perl/Tk.

SYNOPSIS

Top

  use Tk::TOTD;

  my $top = MainWindow->new();

  my $totd = $top->TOTD (
    -title    => 'Tip Of The Day -- MyPerlApp',
    -messages => \@messages,
  );

  $totd->Show;

DESCRIPTION

Top

Tk::TOTD provides a simple Tip of the Day dialog for Perl/Tk programs.

OPTIONS

Top

The options recognized by Show are as follows:

-title

Specify the title of the Tip Of The Day dialog. Defaults to "Tip Of The Day"

-messages

The array of tip messages. If omitted, a default 10 tips about this module will be used instead.

-slogan

Set the slogan at the top of the dialog. Default is "Did you know that..."

-image

A Tk::Photo object. If omitted, the default totd image is used. This default image is appropriate for most TOTD usages, but if you use this as something other than a Tip Of The Day you may want to use your own image. The default image's dimensions are 23x31.

-background

The main window's background color. Defaults to #BFBFBF

-leftbackground

Background color for the left panel (where the image and slide number is). Defaults to #808080

-mainbackground

The background color of the main content area. Defaults to #FFFFFF (white).

-slidecolor

The text color of the slide number (as on the left panel). Defaults to #FFFF99.

-foreground

Main foreground color of text. Defaults to #000000 (black).

-mainfont

The main font family used on most of the labels. Defaults to Arial.

-mainfontsize

Font size of the main font. Defaults to 10.

-titlefont

The font family used on the slogan text. Defaults to Times New Roman.

-titlefontsize

Font size on the slogan text. Defaults to 14.

-checklabel

The label on the checkbutton. Defaults to "Show tips at startup"

-checkvariable

The variable to store the state of the checkbutton. 1 for checked, 0 for not.

-closebutton

The text of the close button. Defaults to "Close"

-nextbutton

The text of the next button. Defaults to "Next Tip"

METHODS

Top

Show (? options ?)

Displays the Tip Of The Day dialog. The TOTD dialog is based from Tk::DialogBox and therefore will pause your main window.

configure (? options ?)

Reconfigure previously set options.

CHANGES

Top

  Version 0.2
  - The widget now behaves as a DialogBox as it should, blocking the main window
    until closed.

BUGS

Top

None known yet.

AUTHOR

Top

Cerone Kirsle kirsle "@" aichaos.com

This code is distributed under the same terms as Perl.

Tk-TOTD documentation Contained in the Tk-TOTD distribution. 
package Tk::TOTD;

use strict;
use warnings;
use Tk;
use Tk::ROText;
use Tk::DialogBox;
use Tk::Widget;

our $VERSION = '0.2';

Tk::Widget->Construct ('TOTD');

sub new {
	my $proto = shift;
	my $mw = shift;
	my $class = ref($proto) || $proto || 'Tk::TOTD';

	my $self = {
		mw => $mw,
		@_,
	};

	bless ($self,$class);
	return $self;
}

sub Show {
	my ($args) = @_;

	my $self = $args->{mw}->DialogBox (
		-title      => $args->{'-title'} || 'Tip Of The Day',
		-background => $args->{'-background'} || '#BFBFBF',
		-buttons    => [],
	);
	$self->geometry ('460x260');
	$self->resizable (0,0);

	my $header = $args->{'-slogan'} || 'Did you know that...',

	my $totd;
	if (exists $args->{'-image'}) {
		$totd = $args->{'-image'};
	}
	else {
		$totd = $self->Photo (-data => &hint, -format => 'gif');
	}

	my @messages = (
		'This is the Tk::TOTD module, for incorporating Tip Of The Day '
			. 'functionality into any Perl/Tk program!',
		"As you can see,\n\neven if your messages are\n\nVERY,\nVERY\n\n"
			. "long,\n\na scrollbar is made available to see the rest\n\n"
			. "of the contents\n\nof your tip!",
		'If all tips are displayed, the queue starts over again to make the '
			. 'tip rotation infinite.',
		'If you use B<-checkvariable> you can have your program allow the user '
			. 'to choose whether he/she wants to have your Tip Of The Day '
			. 'pop up on every startup.',
		'You can have as many tips as you like.',
		'You can incorporate TOTD into a program with only one function call!',
		'You can customize all the colors and fonts used in this dialog window--'
			. 'even the labels such as "Did you know that..." and "Show tips '
			. 'at startup"!',
		'The messages are displayed randomly each time you spawn a TOTD window.',
		'The number of the tip you are viewing and the whole number of tips is '
			. 'displayed in the lower left edge of the window. This is to '
			. 'help you keep track of which tips you have read and to know how '
			. 'many to expect!',
		'There are 10 tips here--so there\'s plenty for you to read!',
	);

	if (exists $args->{'-messages'}) {
		@messages = @{$args->{'-messages'}};
	}

	$self->{colors} = {
		bg    => $args->{'-background'} || '#BFBFBF',
		left  => $args->{'-leftbackground'} || '#808080',
		main  => $args->{'-mainbackground'} || '#FFFFFF',
		slide => $args->{'-slidecolor'}     || '#FFFF99',
		fg    => $args->{'-foreground'}     || '#000000',
	};
	$self->{fonts} = {
		main => {
			family => $args->{'-mainfont'} || 'Arial',
			size   => $args->{'-mainfontsize'} || 10,
		},
		title => {
			family => $args->{'-titlefont'} || 'Times New Roman',
			size   => $args->{'-titlefontsize'} || 14,
		},
	};

	my $top = $self->Frame (
		-width      => 440,
		-height     => 200,
		-background => $self->{colors}->{bg},
	);
	my $bot = $self->Frame (
		-height     => 40,
		-width      => 440,
		-background => $self->{colors}->{bg},
	);
	$bot->pack (-side => 'bottom', -fill => 'both', -ipady => 3, -ipadx => 3);
	$top->pack (-side => 'top', -fill => 'both', -pady => 10, -padx => 10, -expand => 1);

	my $pan = $top->Frame (
		-width      => 60,
		-height     => 200,
		-border     => 0,
		-background => $self->{colors}->{left},
	)->pack (-side => 'left', -fill => 'y', -pady => 0, -padx => 0, -expand => 1);

	$pan->Label (
		-image      => $totd,
		-background => $self->{colors}->{left},
	)->place (-x => 15, -y => 10);

	my $pos = $pan->Label (
		-text       => "1/" . scalar(@messages),
		-foreground => $self->{colors}->{slide},
		-background => $self->{colors}->{left},
		-font       => [
			-family => $self->{fonts}->{main}->{family},
			-size   => $self->{fonts}->{main}->{size},
			-weight => 'bold',
		],
	)->place (-x => 15, -y => 170);

	my $main = $top->Frame (
		-width      => 380,
		-height     => 200,
		-border     => 0,
		-background => $self->{colors}->{main},
	)->pack (-side => 'right', -fill => 'both', -pady => 0, -padx => 0, -expand => 1);

	my $ttab = $main->Frame (
		-width      => 380,
		-height     => 50,
		-border     => 0,
		-background => $self->{colors}->{main},
	)->pack (-side => 'top', -fill => 'x', -pady => 0, -padx => 0, -expand => 1);

	my $title = $ttab->Label (
		-text       => $header,
		-foreground => $self->{colors}->{fg},
		-background => $self->{colors}->{main},
		-font       => [
			-family => $self->{fonts}->{title}->{family},
			-size   => $self->{fonts}->{title}->{size},
			-weight => 'bold',
		],
	)->place (-x => 25, -y => 10);

	my $mtab = $main->Frame (
		-width      => 380,
		-height     => 125,
		-border     => 0,
		-background => $self->{colors}->{main},
	)->pack (-side => 'bottom', -fill => 'both', -pady => 0, -padx => 0, -expand => 1);

	my $pod = $mtab->Scrolled ('ROText',
		-foreground => $self->{colors}->{fg},
		-background => $self->{colors}->{main},
		-scrollbars => 'e',
		-wrap       => 'word',
		-relief     => 'flat',
		-font       => [
			-family => $self->{fonts}->{main}->{family},
			-size   => $self->{fonts}->{main}->{size},
		],
	)->pack (-fill => 'both', -expand => 1);

	my $void = 1;

	my $bl = $bot->Frame (
		-height     => 40,
		-background => $self->{colors}->{bg},
	);
	my $br = $bot->Frame (
		-height     => 40,
		-background => $self->{colors}->{bg},
	);
	$bl->pack (-side => 'left', -fill => 'both', -ipady => 0, -ipadx => 0, -expand => 1);
	$br->pack (-side => 'right', -fill => 'both', -ipady => 0, -ipadx => 0, -expand => 1);

	my $checkbox = $bl->Checkbutton (
		-text       => $args->{'-checklabel'} || 'Show tips at startup',
		-variable   => $args->{'-checkvariable'} || \$void,
		-foreground => $self->{colors}->{fg},
		-background => $self->{colors}->{bg},
		-activeforeground => $self->{colors}->{fg},
		-activebackground => $self->{colors}->{bg},
		-onvalue    => 1,
		-offvalue   => 0,
		-font       => [
			-family => $self->{fonts}->{main}->{family},
			-size   => $self->{fonts}->{main}->{size},
		],
	)->place (-x => 10, -y => 15);

	# Shuffle the messages array.
	srand;
	my @new = ();
	while (@messages) {
		push (@new, splice (@messages, rand @messages, 1));
	}
	(@messages) = (@new);

	# Begin keeping track of things.
	my $index = 0;
	$pod->insert ('end',$messages[0]);

	my $close = $br->Button (
		-text       => $args->{'-closebutton'} || 'Close',
		-foreground => $self->{colors}->{fg},
		-background => $self->{colors}->{bg},
		-activeforeground => $self->{colors}->{fg},
		-activebackground => $self->{colors}->{bg},
		-font       => [
			-family => $self->{fonts}->{main}->{family},
			-size   => $self->{fonts}->{main}->{size},
		],
		-command    => sub {
			$self->destroy;
		},
	)->pack (-side => 'right', -padx => 10);

	my $next = $br->Button (
		-text       => $args->{'-nextbutton'} || 'Next Tip',
		-foreground => $self->{colors}->{fg},
		-background => $self->{colors}->{bg},
		-activeforeground => $self->{colors}->{fg},
		-activebackground => $self->{colors}->{bg},
		-font       => [
			-family => $self->{fonts}->{main}->{family},
			-size   => $self->{fonts}->{main}->{size},
		],
		-command    => sub {
			$index++;
			my $num = $index + 1;

			if ($num > scalar(@messages)) {
				$num = 1;
				$index = 0;
			}

			$pos->configure (-text => "$num/" . scalar(@messages));

			my $data = $messages[$index];
			$pod->delete ('1.0','end');
			$pod->insert ('end',$data);
			$pod->insert ('end',"\n");
			$self->update;
		},
	)->pack (-side => 'right', -padx => 5);

	$self->Show;
}

sub configure {
	my ($cw,%args) = @_;

	foreach my $arg (keys %args) {
		$cw->{$arg} = $args{$arg};
	}
}

sub hint {
	return 'R0lGODlhFwAfAOYAAAAAAICAAP//AAD//8DAwP///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP///yH5
BAEAAH8ALAAAAAAXAB8AAAfVgH+Cg4SFhoeEAYqKiIiKApCQjI2DAQIFl5mYAZR/lgWgfwB/mJCj
jpegBQCsmgKnhgGqoKwAmKWwiamqta4BuYKfs6KkmQK/sbeztr7AnpG3r67Hzpau0dHIhgCRl8Sl
1IgA1pi9t9qH45HEkeiHA+rXv/CIA6vW3dQF9IX2tI+SfqniJ8hfKFaLas2iB8BgKFqsCBCwtXBU
w2GiCkhUOBDWRVWkak2sWOhjAUEaJ1Lc50yUwVqsOjYyyZFlJ5MkO7mcZVOnIJMEfe4MKtRlS6FH
BwUCADs=
';
}

sub Exit {
	my $cw = shift;

	undef $cw;
}


1;