File Coverage

blib/lib/Tk/TOTD.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Tk::TOTD;

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

our $VERSION = '0.4';

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

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

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

	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);

	# Keep a reference to get back to it later.
	$args->{dialog} = $self;

	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->{'selected_button'} = 'Close';
		},
	)->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;
}

sub destroy {
	my $self = shift;

	if ($self->{dialog}) {
		$self->{dialog}->{selected_button} = 'Close';
	}
}

=head1 NAME

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

=head1 SYNOPSIS

  use Tk::TOTD;

  my $top = MainWindow->new();

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

  $totd->Show;

=head1 DESCRIPTION

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

=head1 OPTIONS

The options recognized by B are as follows:

=over 4

=item B<-title>

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

=item B<-messages>

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

=item B<-slogan>

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

=item B<-image>

A L 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 B<23x31>.

=item B<-background>

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

=item B<-leftbackground>

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

=item B<-mainbackground>

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

=item B<-slidecolor>

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

=item B<-foreground>

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

=item B<-mainfont>

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

=item B<-mainfontsize>

Font size of the main font. Defaults to 10.

=item B<-titlefont>

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

=item B<-titlefontsize>

Font size on the slogan text. Defaults to 14.

=item B<-checklabel>

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

=item B<-checkvariable>

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

=item B<-closebutton>

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

=item B<-nextbutton>

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

=back

=head1 METHODS

=over 4

=item B

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

=item B

Reconfigure previously set options.

=item B

Completely clean up the TOTD DialogBox. This method is a workaround for an
underlying bug in C wherein if a DialogBox is open, and you
close the C by clicking on the "X" button from the window manager,
your program doesn't exit completely because the DialogBox is waiting on a
variable that's only set when a button has been clicked.

You can work around this bug by calling C on your C
object when your C is exited.

  $mw->protocol('WM_DELETE_WINDOW', sub {
    $totd->destroy();
    exit(0);
  });

=back

=head1 CHANGES

  Version 0.4 - Nov 11 2013
  - Add the destroy() method to allow for a workaround to a bug in
    Tk::DialogBox.

  Version 0.3 - Nov  1 2013
  - Fix a bug where using the "Close" button on the dialog wouldn't dismiss the
    dialog properly, and the program would never exit gracefully again.

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

=head1 BUGS

None known yet.

=head1 AUTHOR

Noah Petherbridge, http://www.kirsle.net/

This code is distributed under the same terms as Perl.

=cut

1;