#*** Schedule.pm ***#
# Copyright (C) 2006 by Torsten Knorr
# torstenknorr@tiscali.de
# All rights reserved!
#-------------------------------------------------
package Tk::Schedule;
#-------------------------------------------------
use strict;
use warnings;
use Tk::Frame;
use Tk::TimePick;
use Tk::ChooseDate;
use Time::Local qw(timelocal timelocal_nocheck);
use Storable;
use B::Deparse;
#-------------------------------------------------
$Tk::Schedule::VERSION = '0.01';
@Tk::Schedule::ISA = qw(Tk::Frame);
Construct Tk::Widget "Schedule";
#-------------------------------------------------
sub Populate
{
require Tk::Entry;
require Tk::Listbox;
require Tk::Button;
require Tk::Radiobutton;
#-------------------------------------------------
my ($s, $args) = @_;
#-------------------------------------------------
# -interval
# time to check the action list in seconds
$s->{_interval} = (defined($args->{-interval})) ?
delete($args->{-interval}) : 10;
# -command
# pointer to a subroutine which is called at scheduled times
# or an array reference
$s->{_command} = (defined($args->{-command})) ?
delete($args->{-command}) : sub { warn("\n--- NO action defined ---\n"); };
# -repeat
# "once", "yearly", "monthly", "weekly", "daily", "hourly"
# maybe "minute" or "second" do not any sense
$s->{_repeat} = (defined($args->{-repeat})) ?
delete($args->{-repeat}) : "once";
# -comment
# a comment to show
$s->{_comment} = (defined($args->{-comment})) ?
delete($args->{-comment}) : "comment";
# -time
# for the case that the time is to be defined by the program
$s->{_scheduletime} = (defined($args->{-scheduletime})) ?
delete($args->{-scheduletime}) : time();
$s->SUPER::Populate($args);
#-------------------------------------------------
$s->{frame} = $s->Frame(
)->pack(
-side => "right"
);
#-------------------------------------------------
$s->{listbox} = $s->Scrolled(
"Listbox",
-width => 60,
)->pack(
-fill => 'y',
-side => "left",
);
#-------------------------------------------------
$s->{entry_comment} = $s->{frame}->Entry(
-textvariable => \$s->{_comment}
)->pack(
-fill => 'x'
);
#-------------------------------------------------
$s->{choose_date} = $s->{frame}->ChooseDate(
-dateformat => 2,
-textvariable => \$s->{date}
)->pack(
-fill => 'x',
);
my @t = localtime();
$s->{choose_date}->set(
y => ($t[5] + 1900),
m => ($t[4] + 1),
d => $t[3]
);
#-------------------------------------------------
$s->{time_pick} = $s->{frame}->TimePick(
)->pack(
);
$s->{time_pick}->Subwidget("EntryTime")->pack(
-fill => 'x'
);
#-------------------------------------------------
# "once", "yearly", "monthly", "weekly", "daily", "hourly"
$s->{radio_once} = $s->{frame}->Radiobutton(
-text => "once",
-variable => \$s->{_repeat},
-value => "once"
)->pack(
-anchor => 'w'
);
#-------------------------------------------------
$s->{radio_yearly} = $s->{frame}->Radiobutton(
-text => "yearly",
-variable => \$s->{_repeat},
-value => "yearly"
)->pack(
-anchor => 'w'
);
#-------------------------------------------------
$s->{radio_monthly} = $s->{frame}->Radiobutton(
-text => "monthly",
-variable => \$s->{_repeat},
-value => "monthly"
)->pack(
-anchor => 'w'
);
#-------------------------------------------------
$s->{radio_weekly} = $s->{frame}->Radiobutton(
-text => "weekly",
-variable => \$s->{_repeat},
-value => "weekly"
)->pack(
-anchor => 'w'
);
#-------------------------------------------------
$s->{radio_daily} = $s->{frame}->Radiobutton(
-text => "daily",
-variable => \$s->{_repeat},
-value => "daily"
)->pack(
-anchor => 'w'
);
#-------------------------------------------------
$s->{radio_hourly} = $s->{frame}->Radiobutton(
-text => "hourly",
-variable => \$s->{_repeat},
-value => "hourly"
)->pack(
-anchor => 'w'
);
#-------------------------------------------------
$s->{button_add} = $s->{frame}->Button(
-text => "Add Time",
-command => [\&AddTime, $s]
)->pack(
-fill => 'x'
);
#-------------------------------------------------
$s->{button_delete} = $s->{frame}->Button(
-text => "Delete Time",
-command => [\&DeleteTime, $s]
)->pack(
-fill => 'x'
);
#-------------------------------------------------
$s->{childs} =
{
"ScheduleFrame" => $s->{frame},
"ScheduleEntryComment" => $s->{entry_comment},
"ScheduleChooseDate" => $s->{choose_date},
"ScheduleTimePick" => $s->{time_pick},
"ScheduleRadioOnce" => $s->{radio_once},
"ScheduleRadioYearly" => $s->{radio_yearly},
"ScheduleRadioMonthly" => $s->{radio_monthly},
"ScheduleRadioWeekly" => $s->{radio_weekly},
"ScheduleRadioDaily" => $s->{radio_daily},
"ScheduleRadioHourly" => $s->{radio_hourly},
"ScheduleListbox" => $s->{listbox},
"ScheduleButtonDelete" => $s->{button_delete},
"ScheduleButtonAdd" => $s->{button_add}
};
$s->Advertise($_, $s->{childs}{$_}) for(keys(%{$s->{childs}}));
$s->Delegates(
DEFAULT => $s->{listbox}
);
$s->ConfigSpecs(
-interval => [qw/METHOD interval Interval/, $s->{_interval}],
-command => [qw/METHOD command Command/, $s->{_command}],
-repeat => [qw/METHOD repeat Repeat/, $s->{_repeat}],
-comment => [qw/METHOD comment Comment/, $s->{_comment}],
-scheduletime => [qw/METHOD scheduletime Scheduletime/, $s->{_scheduletime}],
DEFAULT => ["ADVERTISED"]
);
#-------------------------------------------------
if(-f "schedule")
{
$s->{schedule} = retrieve("schedule");
}
else
{
$s->{schedule} = undef;
}
$s->ShowSchedule();
}
#-------------------------------------------------
sub interval
{
my ($self, $seconds) = @_;
$self->{_interval} = $seconds;
$self->{repeat_id}->cancel() if(defined($self->{repeat_id}));
$self->{repeat_id} = $self->{listbox}->repeat(($seconds * 1000), [\&CheckForTime, $self]);
return($self->{repeat_id});
}
#-------------------------------------------------
sub command
{
$_[0]->{_command} = $_[1];
return($_[0]->{_command});
}
#-------------------------------------------------
sub repeat
{
$_[0]->{_repeat} = $_[1];
return($_[0]->{_repeat});
}
#-------------------------------------------------
sub comment
{
$_[0]->{_comment} = $_[1];
return($_[0]->{_comment});
}
#-------------------------------------------------
sub scheduletime
{
my ($self, $time) = @_;
$self->{_scheduletime} = $time;
my @t = localtime($time);
$self->{time_pick}->SetSeconds($t[0]);
$self->{time_pick}->SetMinutes($t[1]);
$self->{time_pick}->SetHours($t[2]);
$self->{choose_date}->set(
d => $t[3],
m => ($t[4] + 1),
y => ($t[5] + 1900)
);
return($self->{_scheduletime});
}
#-------------------------------------------------
sub insert
{
my ($self, %args) = @_;
$self->{_command} = $args{-command} if(defined($args{-command}));
$self->{_repeat} = $args{-repeat} if(defined($args{-repeat}));
$self->{_comment} = $args{-comment} if(defined($args{-comment}));
$self->scheduletime($args{-scheduletime}) if(defined($args{-scheduletime}));
$self->AddTime();
return(1);
}
#-------------------------------------------------
sub CheckForTime
{
my ($self) = @_;
for my $schedule_time (keys(%{$self->{schedule}}))
{
if($schedule_time <= time())
{
my @temp_command = @{$self->{schedule}{$schedule_time}[0]};
my $code = shift(@temp_command);
my $ref_sub = sub { eval($code); };
if($@)
{
warn($@);
return(0);
}
$ref_sub->(@temp_command);
$self->ReworkSchedule($schedule_time);
}
}
return(1);
}
#-------------------------------------------------
# "once", "yearly", "monthly", "weekly", "daily", "hourly"
sub ReworkSchedule
{
my ($self, $schedule_time) = @_;
return(0) if(!(defined($self->{schedule}{$schedule_time})));
my $repeat = $self->{schedule}{$schedule_time}[1];
my @old_time = localtime($schedule_time);
SWITCH:
{
($repeat eq "once") && do
{
delete($self->{schedule}{$schedule_time});
$self->ShowSchedule();
last(SWITCH);
};
($repeat eq "hourly") && do
{
$old_time[2]++;
$self->{schedule}{timelocal_nocheck(@old_time)} = delete($self->{schedule}{$schedule_time});
$self->ShowSchedule();
last(SWITCH);
};
($repeat eq "daily") && do
{
$old_time[3]++;
$self->{schedule}{timelocal_nocheck(@old_time)} = delete($self->{schedule}{$schedule_time});
$self->ShowSchedule();
last(SWITCH);
};
($repeat eq "weekly") && do
{
$old_time[3] += 7;
$self->{schedule}{timelocal_nocheck(@old_time)} = delete($self->{schedule}{$schedule_time});
$self->ShowSchedule();
last(SWITCH);
};
($repeat eq "monthly") && do
{
if($old_time[4] >= 11)
{
$old_time[4] = 0;
$old_time[5]++;
}
else
{
$old_time[4]++;
}
$self->{schedule}{timelocal_nocheck(@old_time)} = delete($self->{schedule}{$schedule_time});
$self->ShowSchedule();
last(SWITCH);
};
($repeat eq "yearly") && do
{
$old_time[5]++;
$self->{schedule}{timelocal_nocheck(@old_time)} = delete($self->{schedule}{$schedule_time});
$self->ShowSchedule();
last(SWITCH);
};
warn("invalid repeat value\n");
}
store($self->{schedule}, "schedule");
return(1);
}
#-------------------------------------------------
# $object->{schedule}{time} = [ref_code or ref_array, repeat, comment];
sub AddTime
{
my ($self) = @_;
my @d = $self->{choose_date}->get();
my $t = timelocal(
$self->{time_pick}->GetSeconds(),
$self->{time_pick}->GetMinutes(),
$self->{time_pick}->GetHours(),
$d[2],
($d[1] - 1),
($d[0] - 1900)
);
$t++ while(defined($self->{schedule}{$t}));
my $deparse= B::Deparse->new();
if(ref($self->{_command}) eq "ARRAY")
{
my @temp_command = @{$self->{_command}};
my $code = $deparse->coderef2text(shift(@temp_command));
$self->{schedule}{$t} = [[$code, @temp_command], $self->{_repeat}, $self->{_comment}];
}
elsif(ref($self->{_command}) eq "CODE")
{
my $code = $deparse->coderef2text($self->{_command});
$self->{schedule}{$t} = [[$code], $self->{_repeat}, $self->{_comment}];
}
else
{
warn("\n--- $self->{_command} is neihter a ARRAY nor a CODE reference ---\n");
}
$self->ShowSchedule();
store($self->{schedule}, "schedule");
return(1);
}
#-------------------------------------------------
sub ShowSchedule
{
my ($self) = @_;
$self->{listbox}->delete(0, "end");
my $number = 0;
for(sort { $a <=> $b } keys(%{$self->{schedule}}))
{
$self->{listbox}->insert(
"end",
localtime($_) . " $self->{schedule}{$_}[1] $self->{schedule}{$_}[2]"
);
$self->{number}[$number] = $_;
$number++;
}
return(1);
}
#-------------------------------------------------
sub DeleteTime
{
my ($self) = @_;
my $number = ($self->{listbox}->curselection())[0];
delete($self->{schedule}{$self->{number}[$number]});
store($self->{schedule}, "schedule");
$self->ShowSchedule();
return(1);
}
#-------------------------------------------------
sub DESTROY
{
print("\n" . ref($_[0]) . " object destroyed\n");
store($_[0]->{schedule}, "schedule");
}
#-------------------------------------------------
1;
__END__
#-------------------------------------------------
=head1 NAME
Tk::Schedule - Perl extension for a graphical user interface to carrying out tasks up to schedule
=head1 SYNOPSIS
my $schedule = $parent->Schedule(options);
=head1 EXAMPLE
use Tk;
use Tk::Schedule;
my $mw = MainWindow->new();
my $s = $mw->Schedule(
-interval => 30,
-repeat => "once",
-command => sub { print("Hello World\n") for(1..10); },
-comment => "check Mail-Box"
)->pack();
MainLoop();
=head1 SUPER-CLASS
Schedule is derived from the Frame class.
This megawidget is comprised of an
ChooseDate
TimePick
Entry
Listbox
Button
Radiobutton
allowing to create a schedule.
=head1 DESCRIPTION
With this Widget function at a certain time can be called.
A schedule can be made for longer periods.
The call of functions can be repeated in certain course of time.
Possible repetition times are:
hourly
daily
weekly
monthly
yearly
For seconds or minutes the functions
$widget->after(time, call) or
$widget->repeat(time, call)
can be better used.
=head1 CONSTRUCTOR AND INITIALIZATION
my $s = $mw->Schedule(
-interval => 30, # default 10
-repeat => "daily", # default once
-comment => "send E-Mail to mail@addresse.com",
-command => sub { print("Hello World\n") for(1..10); },
# -command => [\&DownloadWebsite, $server, $agrs],
# -command => \&ShowPicture,
-scheduletime => time()
)->pack();
=head1 WIDGET SPECIFIC OPTINOS
All options not specified below are delegated to the Listbox widget.
=item -interval
After how much seconds the program checks the schedule.
default = 10
=item -command
A reference to a function or array.
The first element of the array must be a reference to a function.
=item -repeat
In which periods the call of the function is repeated.
Possible repetition times are:
"hourly", "daily", "weekly", "monthly", "yearly"
default "once" that does mean NO repetition
=item -comment
This comment is indicated in the list box.
=item -scheduletime
Time in seconds to indicate.
default return value of time();
=head1 INSERTED WIDGETS
=item ChooseDate
Popup Calendar with support for dates prior to 1970.
Author Jack Dunnigan
=item TimePick
A graphical user interface to pick timestrings syntax mistake-secure.
Author Torsten Knorr
=item Button
=item Listbox
=item Radiobutton
=item Entry
=head1 ADVERTISED WIDGETS
The following widgets are advertised:
=item ScheduleFrame
=item ScheduleEntryComment
=item ScheduleChooseDate
=item ScheduleTimePick
=item ScheduleRadioOnce
=item ScheduleRadioYearly
=item ScheduleRadioMonthly
=item ScheduleRadioWeekly
=item ScheduleRadioDaily
=item ScheduleRadioHourly
=item ScheduleListbox
=item ScheduleButtonDelete
=item ScheduleButtonAdd
=head1 METHODS
The following functions should be used like private functions.
=item CheckForTime
=item ReworkSchedule
=item AddTime
=item ShowSchedule
=item DeleteTime
The following functions should be used like public functions.
=item insert
With this method you can add a task from the program.
As parameter you can use the options
-repeat, -command, -comment or -scheduletime
in every combination.
$widget->insert();
$widget->insert(-repeat => "once");
$widget->insert(-command => sub { });
$widget->insert(-comment => "new task");
$widget->insert(-scheduletime => time());
$widget->insert(
-repeat => "hourly",
-command => sub { print("every hour\n"); },
-comment => "every hour",
-scheduletime => time()
);
=item scheduletime
Set the time to indicate.
$widget->scheduletime(time_in_seconds); or
$widget->configure(
-scheduletime => time()
);
=head1 WIDGET METHODS
Call configure to use the following functions.
$schedule->configure(
-interval => 20,
-command => \&DailyDuty,
-repeat => "daily",
-comment => "every day the same task",
-scheduletime => time(),
);
=item interval
=item command
=item repeat
=item comment
=item scheduletime
=head1 PREREQUISITES
=item Tk
=item Tk::Frame
=item Tk::Photo
=item Tk::TimePick
=item Tk::ChooseDate
=item Date::Calc
=item Bit::Vector
=item Carp::Clan
=item Time::Local
=item Storable
=item B::Deparse
=head2 EXPORT
None by default.
=head1 SEE ALSO
Tk::TimePick
Tk::ChooseDate
=head1 BUGS
Maybe you'll find some. Please let me know.
=head1 AUTHOR
Torsten Knorr, E<lt>torsten@mshome.netE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2006 by Torsten Knorr
torstenknorr@tiscali.de
http://www.planet-interkom.de/t.knorr
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.9.2 or,
at your option, any later version of Perl 5 you may have available.
=cut