Schedule-Cron-1.07/0000755€@cR€@cR0000000000015233011176014307 5ustar nhubbardnhubbardSchedule-Cron-1.07/t/0000755€@cR€@cR0000000000015233011176014552 5ustar nhubbardnhubbardSchedule-Cron-1.07/t/timeshift.t0000644€@cR€@cR0000000063415233005403016732 0ustar nhubbardnhubbard#!/usr/bin/perl use Test::More tests => 1; use Schedule::Cron; use strict; my $count = 0; my $second = (localtime)[0]; my $cron = new Schedule::Cron(sub {},{nofork => 1,timeshift => 10}); $cron->add_entry("* * * * * " . ($second + 12) % 60,{subroutine => sub { die } }); my $now = time; eval { $cron->run(); }; my $delta = time - $now; ok($delta <= 3,"Call was shifted by " . $delta . " seconds (<= 3)"); Schedule-Cron-1.07/t/pretty_print_args.t0000644€@cR€@cR0000000062015233005403020510 0ustar nhubbardnhubbard#!/usr/bin/perl use Test::More tests => 1; use Schedule::Cron; use strict; my @args = ( [ "bla", "blub", { "deeper" => 1, "and" => {deeper => "stop" } } ], 3, { "blub" => "bla", 3 => 2 } ); my $out = join(",",Schedule::Cron->_format_args(@args)); like($out,qr/\['bla','blub',\{.*?'and'\s*=>\s*'HASH\(.*?\)'.*?}\],3,\{.*?'blub'\s*=>\s*'bla'.*?}/); Schedule-Cron-1.07/t/kwalitee.t0000644€@cR€@cR0000000027615233005403016545 0ustar nhubbardnhubbard#!/usr/bin/perl use Test::More; eval { require Test::Kwalitee; }; if ($@) { plan( skip_all => 'Test::Kwalitee not installed; skipping' ); } else { Test::Kwalitee->import(); } Schedule-Cron-1.07/t/nofork.t0000644€@cR€@cR0000000400015233005403016223 0ustar nhubbardnhubbard#!perl -w # Check no-fork option: use Test::More tests => 5; use Schedule::Cron; $| = 1; # Simple no fork execution my $toggle = 0; my $count = 0; my $dispatch_1 = sub { print "# Job 1.1\n"; $toggle = 1; }; my $dispatch_2 = sub { print "# Job 1.2\n"; if ($toggle) { pass("Simple nofork - Second Job finished"); die "ok\n"; } $count++; fail("Job 1 has not run") if $count == 2; sleep 2; }; my $cron = new Schedule::Cron($dispatch_1,{nofork => 1}); $cron->add_entry("* * * * * *",$dispatch_2); $cron->add_entry("* * * * * *"); eval { $cron->run(); }; my $error = $@; chomp $error; ok($error eq "ok","Simple nofork - Cron has been run: $error"); # No fork with 'skip' option $count = 0; $dispatch_1 = sub { print "# Job 2.1 ",scalar(localtime),"\n"; if ($count == 1) { pass("Nofork with skip - Skip test passed"); die "ok\n"; } $count++; sleep(3); sleep(1) if ((localtime)[0] % 3 == 0); }; $dispatch_2 = sub { print "# Job 2.2 ",scalar(localtime),"\n"; die "Job 2.2 should never run\n"; }; $cron = new Schedule::Cron($dispatch_1,{nofork => 1,log => sub {print "# ",$_[1],"\n"}}); $cron->add_entry("* * * * * *"); $cron->add_entry("* * * * * */3",$dispatch_2); eval { $cron->run(skip => 1); }; $error = $@; chomp $error; ok($error eq "ok","Nofork with skip - Cron has been run: $error"); # No-Fork with 'catch' option. $count = 0; SKIP: { eval { alarm 0 }; skip "alarm() not available", 1 if $@; $dispatch_1 = sub { $count++; die "Exception"; }; $SIG{ALRM} = sub { ok($count > 0,"Nofork with skip - Job has run"); exit; }; $cron = new Schedule::Cron($dispatch_1,{nofork => 1,log => sub {print "# ",$_[1],"\n"}}); $cron->add_entry("* * * * * *"); eval { alarm(3); $cron->run(catch => 1); }; ok(!$@,"Nofork with skip - Job has died: $@"); } Schedule-Cron-1.07/t/entry.t0000644€@cR€@cR0000000473615233005403016106 0ustar nhubbardnhubbard#!/usr/bin/perl # # Test management methods for adding/deleting/updating entries use Test::More tests => 19; use Schedule::Cron; use Data::Dumper; use strict; my $dispatcher = sub { print "Dispatcher\n"}; my $special_dispatch = sub { print "Special Dispatcher\n"}; my $cron = new Schedule::Cron($dispatcher); eval { $cron->add_entry("*"); }; ok($@," invalid add arguments: $@"); eval { $cron->add_entry("* * * * *",{'subroutine' => \&dispatch, 'arguments' => [ "first",2,"third" ], 'eval' => 1}); }; ok($@," invalid add arguments: $@"); # get my $timespec = "5 * * * *"; $cron->add_entry($timespec,"doit"); ok (scalar($cron->list_entries()) == 1,"3 list entries"); my $entry = $cron->get_entry(0); ok ($entry->{time} eq $timespec,"entry 0 timespec"); ok ($entry->{dispatcher} eq $dispatcher,"entry 0 dispatcher"); ok ($entry->{args}->[0] eq "doit","entry 0 args"); ok (!defined($cron->get_entry(2)),"entry: invalid index"); # Add two extras $cron->add_entry($timespec,$special_dispatch); my $timespec3 = "* * * * * */2"; $cron->add_entry($timespec3,"yet","some","arguments"); ok (scalar($cron->list_entries()) == 3,"3 list entries"); ok ($cron->get_entry(1)->{dispatcher} eq $special_dispatch,"entry 1 dispatcher"); my $args_2 = [ 10,12,13 ]; my $timespec_2 = "12 13 7 7 *"; my $old_entry = $cron->update_entry(1,{time => $timespec_2,args => $args_2}); # Update ok ($old_entry->{time} eq $timespec && $old_entry->{dispatcher} == $special_dispatch && @{$old_entry->{args}} == 0, "update: old entry"); $entry = $cron->get_entry(1); ok ($entry->{time} eq $timespec_2 && $entry->{dispatcher} eq $dispatcher, "update: new entry"); ok ($entry->{args} != $args_2,"update: deep copy"); ok (scalar(grep { $args_2->[$_] == $entry->{args}->[$_] } (0,1,2)) == 3,"update: deep copy 2"); # Delete $old_entry = $cron->delete_entry(1); ok ($old_entry->{time} eq $timespec_2 && $entry->{dispatcher} eq $dispatcher,"delete: old entry"); ok (scalar($cron->list_entries) == 2,"delete: nr. entries"); $entry = $cron->get_entry(1); ok ($entry->{time} eq $timespec3 && $entry->{dispatcher} == $dispatcher && $entry->{args}->[1] eq "some","delete: splicing"); $old_entry = $cron->delete_entry(0); ok ($old_entry->{time} eq $timespec && $entry->{dispatcher} eq $dispatcher,"delete: old entry (2)"); ok (scalar($cron->list_entries) == 1,"delete: nr. entries"); # Clean all $cron->clean_timetable; ok (scalar($cron->list_entries) == 0,"clean"); Schedule-Cron-1.07/t/pod.t0000644€@cR€@cR0000000022215233005403015511 0ustar nhubbardnhubbard#!/usr/bin/perl use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Schedule-Cron-1.07/t/same_time_with_reschedule.t0000644€@cR€@cR0000000263215233005403022137 0ustar nhubbardnhubbard#!/usr/bin/perl use Test::More tests => 6; use Schedule::Cron; use strict; #!/usr/bin/perl use Schedule::Cron; use Data::Dumper; my $CALLED = {}; # Create new object with default dispatcher my $scheduler = Schedule::Cron->new( sub { warn "unknown action"; }); my $other = sub { $CALLED->{OTHER}++ }; my $sec = (localtime)[0]; my $e = entry(2,3,4); my $tasknum = 0; my $do = sub { $CALLED->{DO}++; if ($tasknum < 2) { # print "adding something\n"; my $string = "task" . $tasknum ."\n"; $scheduler->add_entry($e, { subroutine => &task($tasknum + 1)}); $tasknum++; } }; sub task { my $num = shift; return sub { $CALLED->{"T" . $num}++; }; } #print $e,"\n";; $scheduler->add_entry($e, { subroutine => $do }); $scheduler->add_entry($e, { subroutine => $other }); $scheduler->add_entry(entry(5), { subroutine => sub { die "E1\n" }}); eval { $scheduler->run({ nofork => 1 }); }; is($@,"E1\n","Finished by last action"); ok($CALLED->{DO} > 0,'$do called ' . $CALLED->{DO}); ok($CALLED->{OTHER} > 0,'$other called ' . $CALLED->{OTHER}); ok($CALLED->{T1} > 0,"T1 called"); ok($CALLED->{T2} > 0,"T2 called"); is($CALLED->{DO},$CALLED->{OTHER}, '$do and $other are the same'); #print Dumper($CALLED); sub entry { return "* * * * * " . join (",",map { ($sec + $_) % 60 } @_); } Schedule-Cron-1.07/t/after_job.t0000644€@cR€@cR0000000122315233005403016664 0ustar nhubbardnhubbard#!/usr/bin/perl # Test for after_job callbak use Test::More tests => 3; use Schedule::Cron; use strict; my $count = 0; my $cron =new Schedule::Cron(\&dispatch,{nofork => 1,after_job => \&after_callback}); $cron->add_entry("* * * * * 0-59/1",{args => [ "eins", "zwei"]}); eval { $cron->run(); }; is($@,"e1\n","Second call must finish test"); sub dispatch { my @args; if ($count == 0) { $count = 1; return "t1"; } elsif ($count == 1) { die "e1\n"; } } sub after_callback { my ($ret,@args) = @_; is($ret,"t1","Return value must match"); is_deeply(\@args,["eins","zwei" ],"Arguments must match"); } Schedule-Cron-1.07/t/test.crontab0000644€@cR€@cR0000000620015233005403017075 0ustar nhubbardnhubbard# Minutes: # ======== * * * * * qw(20:15 27/12/1999 Monday) 20 * * * * qw(20:20 27/12/1999 Monday) 10-50 * * * * qw(20:15 27/12/1999 Monday) 13-30/4 * * * * qw(20:17 27/12/1999 Monday) 10 * * * * qw(21:10 27/12/1999 Monday) 18,20 * * * * qw(20:18 27/12/1999 Monday) # Hours: # ====== * 21 * * * qw(21:00 27/12/1999 Monday) * 19 * * * qw(19:00 28/12/1999 Tuesday) * 10-23/5 * * * qw(20:15 27/12/1999 Monday) * 10-23/7 * * * qw(10:00 28/12/1999 Tuesday) # Days-of-Month: # ============== * * 29 2 * qw(00:00 29/02/2000 Tuesday) 23 4 23-30/3 * * qw(04:23 29/12/1999 Wednesday) 12 21 27 * * qw(21:12 27/12/1999 Monday) 12 19 27 * * qw(19:12 27/01/2000 Thursday) * 18 21,15,8 * * qw(18:00 08/01/2000 Saturday) # Months: # ======= * * * 11 * qw(00:00 01/11/2000 Wednesday) * * * 12 * qw(20:15 27/12/1999 Monday) * * * 0 * qw(00:00 01/01/2000 Saturday) 42 0 4 Jan-Dec * qw(00:42 04/01/2000 Tuesday) 42 21 4 Jan-Dec/2 * qw(21:42 04/01/2000 Tuesday) 42 21 * Feb-Dec/2 * qw(21:42 27/12/1999 Monday) 42 19 * Feb-Dec/2 * qw(19:42 28/12/1999 Tuesday) 42 19 27 Feb-Dec/2 * qw(19:42 27/02/2000 Sunday) # Days-of-Week: # ============= 14 15 * Dec,Jan 0 qw(15:14 02/01/2000 Sunday) 14 15 * Dec,Jan 7 qw(15:14 02/01/2000 Sunday) 0 12 * * Mon-Fri qw(12:00 28/12/1999 Tuesday) * * * * Mon qw(20:15 27/12/1999 Monday) 0 21 * * Mon qw(21:00 27/12/1999 Monday) 0 19 * * Mon qw(19:00 03/01/2000 Monday) 13 14 * * Sun-Sat/2 qw(14:13 28/12/1999 Tuesday) # Horrible combinations ;-): # ========================== 0 21 27 * Wed qw(21:00 27/12/1999 Monday) 0 19 27 * Wed qw(19:00 29/12/1999 Wednesday) 0 19,21 27 * Wed qw(21:00 27/12/1999 Monday) 20-30/5,17 19,21 27 * Wed qw(21:17 27/12/1999 Monday) # With seconds (6th column) # ========================= * * * * * * qw(seconds_test) * * * * * 0-59/2 qw(seconds_test) * * * * * 2,4,6 (5 + 4)."seconds_test" Schedule-Cron-1.07/t/startup.t0000644€@cR€@cR0000000106015233005403016432 0ustar nhubbardnhubbard#!perl -w # Startup Test: # $Id: startup.t,v 1.7 2006/11/27 13:42:52 roland Exp $ use Schedule::Cron; use Test::More tests => 1; our %SKIP; $| = 1; #print STDERR " (may take a minute) "; SKIP: { eval { alarm 0 }; skip "alarm() not available", 1 if $@; $SIG{QUIT} = sub { alarm(0); pass; exit; }; $SIG{ALRM} = sub { fail; exit; }; $cron = new Schedule::Cron(sub { kill QUIT, shift; alarm 1; }); $cron->add_entry("* * * * * */2",$$); alarm(6); $cron->run; } Schedule-Cron-1.07/t/load_crontab.t0000644€@cR€@cR0000000217215233005403017364 0ustar nhubbardnhubbard#!perl -w use Schedule::Cron; use File::Basename; use strict; my $crontab = dirname($0)."/test.crontab"; my $cron; my @tests = ( qq( \$cron = new Schedule::Cron( sub {}, file => "$crontab", eval => 1) ), qq( \$cron = new Schedule::Cron(sub {}); \$cron->load_crontab("$crontab"); ), qq( \$cron = new Schedule::Cron(sub {}); \$cron->load_crontab(file=>"$crontab",eval=>1); ), qq( \$cron = new Schedule::Cron(sub {}); \$cron->load_crontab({file=>"$crontab",eval=>1}); ) ); print "1..",scalar(@tests),"\n"; my $i = 1; foreach (@tests) { eval $_; if ($@) { print "Error during loading of crontab file: $@\n"; print "not ok $i\n"; } else { print "ok $i\n"; } # print "Cron:\n",Dumper($cron); $i++; } # Check for time parsing $cron = new Schedule::Cron(sub {}); $cron->load_crontab($crontab); Schedule-Cron-1.07/t/pod_coverage.t0000644€@cR€@cR0000000044615233005403017374 0ustar nhubbardnhubbard#!/usr/bin/perl use Test::More; eval "use Test::Pod::Coverage"; plan skip_all => "Test::Pod::Coverage required for testing pod coverage" if $@; plan tests => 1; pod_coverage_ok( "Schedule::Cron",{trustme => [qr/^REAPER$/, qr/^bug$/, qr/^report_exectime_bug/]}, "Schedule::Cron is covered" ); Schedule-Cron-1.07/t/delete_entry.t0000644€@cR€@cR0000000173415233005403017423 0ustar nhubbardnhubbard#!/usr/bin/perl # # ============================================= # Adapted from patch provided with RT #54692 use Test::More tests => 3; use Schedule::Cron; use Data::Dumper; use strict; use warnings; $| = 1; #System::Proc::Simple->debug(0); my $cron = new Schedule::Cron( \&dispatcher, nofork => 1, catch => 0, ); $cron->add_entry("* * * * * *", 'Test1'); $cron->add_entry("* * * * * *", 'Test2'); my $e_idx = $cron->check_entry('Test2'); $cron->delete_entry($e_idx); $cron->add_entry("* * * * * *", 'Test3'); foreach my $e_name (qw/Test1 Test2 Test3/) { my $e_idx = $cron->check_entry($e_name); if (defined($e_idx)) { my $entry = $cron->get_entry($e_idx); is($entry->{args}->[0],$e_name,"$e_name defined"); } else { is($e_name,"Test2","Test2 not found"); } } sub dispatcher { my $name = shift; printf "Running %s.\n", $name; } Schedule-Cron-1.07/t/dst_back.t0000644€@cR€@cR0000000175615233005403016516 0ustar nhubbardnhubbard#!perl -w use strict; use warnings; use Test::More; use Schedule::Cron; plan tests => 3; my %available = (); my @refs = ( [ "MET", 1256432100, 1256436000], [ "Europe/Berlin", 1256432100, 1256436000], [ "America/Los_Angeles", 1257065700, 1257062400] ); # First check for timezones available: no warnings; $ENV{TZ} = undef; my $tt = time; my $local = scalar(localtime($tt)); for my $r (@refs) { my $tz = $r->[0]; $ENV{TZ} = $tz; my $calc = scalar(localtime($tt)); #print "C: $calc L: $local\n"; $available{$tz} = 1 if $calc ne $local; } my $cron = new Schedule::Cron(sub { }); for my $r (@refs) { my $tz = $r->[0]; if (!$available{$tz}) { ok(1,"Timezone $tz not available"); next; } $ENV{TZ} = $tz; my $next = $cron->get_next_execution_time("0-59/5 * * * *",$r->[1]); is($next,$r->[2],"Expected time for $tz ( Ref: " . scalar(localtime($r->[1])) . ", Calc: " . scalar(localtime($next))); } Schedule-Cron-1.07/t/execution_time.t0000644€@cR€@cR0000002026115233005403017755 0ustar nhubbardnhubbard#!perl -w use Test::More; use Schedule::Cron; use Time::ParseDate; use Data::Dumper; eval "use DateTime::TimeZone::Local"; my $local_tz; if (!$@) { eval { my $t = DateTime::TimeZone::Local->TimeZone(); if ($t) { $local_tz = $t->name(); } }; # Needs to eval because a time zone might not be set } my $time; my $skip = 0; while (defined($_=) && $_ !~ /^end/i) { chomp; if (/^Reftime:\s*(.*)$/) { $time = $1; $time =~ s/\#.*$//; $time = parsedate($time,UK=>1); next; } elsif (/^TZBEGIN:\s*(.*)$/) { if (!$local_tz || $1 ne $local_tz) { $skip = 1; } next; } elsif (/^TZEND:/) { $skip = 0; next; } next if $skip; s/^\s*(.*)\s*/$1/; next if /^\#/ || /^$/; my @args = split(/\s+/,$_,6); my $date; my $rest = pop @args; my ($col6,$more_args) = split(/\s+/,$rest,2); if ($col6 =~ /^[\d\-\*\,\/]+$/) { push @args,$col6; $date = $more_args; } else { $date = $rest; } push @entries,[$time, \@args]; my $res_date = parsedate($date,UK=>1); die "Internal error" unless $res_date; push @results,$res_date; } my $cron = new Schedule::Cron(sub {}); plan tests => scalar(@entries); my $i; for ($i=0;$i<=$#entries;$i++) { my $t = $cron->get_next_execution_time($entries[$i]->[1],$entries[$i]->[0]); print "# Cron-Entry: ",join(" ",@{$entries[$i]->[1]}),"\n"; print "# Ref-Time: ",scalar(localtime($entries[$i]->[0])),"\n"; print "# Calculated: ",scalar(localtime($t)),"\n"; print "# Expected: ",scalar(localtime($results[$i])),"\n"; ok($t == $results[$i]); } __DATA__ Reftime: Mon Dec 27 20:14:14 1999 # Minutes: # ======== * * * * * 0 20:15 27/12/1999 Monday 20 * * * * 20:20 27/12/1999 Monday 10-50 * * * * 20:15 27/12/1999 Monday 13-30/4 * * * * 20:17 27/12/1999 Monday 10 * * * * 21:10 27/12/1999 Monday 18,20 * * * * 20:18 27/12/1999 Monday # Hours: # ====== * 21 * * * 21:00 27/12/1999 Monday * 19 * * * 19:00 28/12/1999 Tuesday * 10-23/5 * * * 20:15 27/12/1999 Monday * 10-23/7 * * * 10:00 28/12/1999 Tuesday # Days-of-Month: # ============== * * 29 2 * 00:00 29/02/2000 Tuesday 23 4 23-30/3 * * 04:23 29/12/1999 Wednesday 12 21 27 * * 21:12 27/12/1999 Monday 12 19 27 * * 19:12 27/01/2000 Thursday * 18 21,15,8 * * 18:00 08/01/2000 Saturday # Months: # ======= * * * 11 * 00:00 01/11/2000 Wednesday * * * 12 * 20:15 27/12/1999 Monday * * * 0 * 00:00 01/01/2000 Saturday 42 0 4 Jan-Dec * 00:42 04/01/2000 Tuesday 42 21 4 Jan-Dec/2 * 21:42 04/01/2000 Tuesday 42 21 * Feb-Dec/2 * 21:42 27/12/1999 Monday 42 19 * Feb-Dec/2 * 19:42 28/12/1999 Tuesday 42 19 27 Feb-Dec/2 * 19:42 27/02/2000 Sunday # Days-of-Week: # ============= 14 15 * Dec,Jan 0 15:14 02/01/2000 Sunday 14 15 * Dec,Jan 7 15:14 02/01/2000 Sunday 0 12 * * Mon-Fri 12:00 28/12/1999 Tuesday * * * * Mon 20:15 27/12/1999 Monday 0 21 * * Mon 21:00 27/12/1999 Monday 0 19 * * Mon 19:00 03/01/2000 Monday 13 14 * * Sun-Sat/2 14:13 28/12/1999 Tuesday # Seconds * * * * * * 20:14:15 27/12/1999 Monday * * * * * 5-10 20:15:05 27/12/1999 Monday * * * * * 13-30/4 20:14:17 27/12/1999 Monday * * * * * 18 20:14:18 27/12/1999 Monday # Horrible combinations ;-): # ========================== 0 21 27 * Wed 21:00 27/12/1999 Monday 0 19 27 * Wed 19:00 29/12/1999 Wednesday 0 19,21 27 * Wed 21:00 27/12/1999 Monday 20-30/5,17 19,21 27 * Wed 21:17 27/12/1999 Monday # Check for parsedate-normalization # (thanx to Lars Holokowo) # ================================= 1 3 30 6 * 03:01 30/06/2000 Monday 0 03 30 6 * 03:00 30/06/2000 Monday 00 3 30 6 * 03:00 30/06/2000 Monday 0 3 30 6 * 03:00 30/06/2000 Monday # Bug reported by Loic Paillotin # ============================== 5,10,25,30,35,40,45,50,55 * * * * 20:25 27/12/1999 Monday 5,10,25,30,35,40,45,50,55 * * * * 20:25 27/12/1999 Monday */5 * * * * 20:15 27/12/1999 Monday # Runs only if running if in Germany (since the DST is TZ specific) TZBEGIN: Europe/Berlin # DST Checks (for MEZ) # ==================== # Normal behaviour (non-DST related) Reftime: Sun Mar 29 03:10:00 2009 10 * * * * Sun Mar 29 04:10:00 2009 10 2 * * * Mon Mar 30 02:10:00 2009 10 2 * * 0 Sun Apr 05 02:10:00 2009 10 2 29 * * Wed Apr 29 02:10:00 2009 # Cron triggers within the DST switch. It should fire right after the hours has # changed Reftime: Sun Mar 29 01:10:00 2009 10 * * * * Sun Mar 29 03:10:00 2009 Reftime: Sat Mar 28 02:10:00 2009 10 2 * * * Sun Mar 29 03:10:00 2009 Reftime: Sun Mar 22 02:10:00 2009 10 2 * * 0 Sun Mar 29 03:10:00 2009 Reftime: Sun Feb 29 02:10:00 2009 10 2 29 * * Sun Mar 29 03:10:00 2009 # Checks for reverse DST switch. It should skip the extra hour. This works for # MET only, though. Actually for other TZs (like PST8PDT), where parsedate() # delivers the 'first' UTC time instead of the 'second' (as it is for MET). # This is not Time::ParseDate's fault but ours because of the way, how we # calculate the next execution time. It's unlikely that this will get fixed # very soon. Reftime: Sun Oct 25 02:10:00 2009 10 * * * * Sun Oct 25 03:10:00 2009 Reftime: Sun Oct 25 02:10:00 2009 5 * * * * Sun Oct 25 03:05:00 2009 Reftime: Sun Oct 25 02:55:00 2009 25 * * * * Sun Oct 25 03:25:00 2009 TZEND: Europe/Berlin # ---------------------------------------------------------------------------- # Leave out invalid dates Reftime: Fri Feb 27 12:00:00 2009 0 12 30 * * Sun Mar 30 12:00:00 2009 # Check '*' at minute level Reftime: Fri Jan 27 12:01:00 2009 * 12 30 * * Sun Jan 30 12:00:00 2009 * 12 27 * * Sun Jan 27 12:02:00 2009 * 12 * * * Sun Jan 27 12:02:00 2009 * 13 * * * Sun Jan 27 13:00:00 2009 # ----------------------------------------------------------------------------- # Reported by : tenbrink Reftime: 23:00 2007/09/01 0 23 * * 1 23:00 03/09/2007 Monday # ----------------------------------------------------------------------------- # Reported by : tenbrink Reftime: 23:00:55 2007/09/01 * * * * * */10 23:01:00 01/09/2007 Saturday end Schedule-Cron-1.07/t/callbackreschedule.t0000644€@cR€@cR0000000175415233005403020542 0ustar nhubbardnhubbard#!perl -w # Check that rescheduling entries within an entry callback works properly # in nofork mode. # # by Andrew Danforth based on existing testcases use Test::More tests => 1; use Schedule::Cron; $| = 1; my $cron = new Schedule::Cron(\&dispatch_1,{nofork => 1}); my $job1count = 0; my $job2count = 0; sub dispatch_1 { print "# Job 1.1, job1count: $job1count, job2count: $job2count\n"; if ($job1count++ == 0) { $cron->clean_timetable; $cron->add_entry("* * * * * 0-59/4", \&dispatch_2); $cron->add_entry("* * * * * 2-59/4"); } else { die "ok\n" if $job2count; die "job2 never ran"; } } sub dispatch_2 { print "# Job 1.2, job1count: $job1count, job2count: $job2count\n"; if ($job2count++) { die "job1 got lost -- job2 ran again before job1 a second time"; } } $cron->add_entry("* * * * * 2-59/4"); eval { $cron->run(); }; my $error = $@; chomp $error; ok($error eq "ok","rescheduled jobs work properly ($error)"); Schedule-Cron-1.07/t/process_name.t0000644€@cR€@cR0000000611215233010102017401 0ustar nhubbardnhubbard#!/usr/bin/perl # Test the process naming options: processname, processprefix, and nostatus. use Test::More tests => 6; use Schedule::Cron; use strict; use warnings; my $orig_proc_name = $0; my $dispatch_1 = sub { my $test_msg = 'process name suffixed with debug status by default'; my $process_name_rx = '^Schedule::Cron MainLoop - next: .+$'; if ($0 =~ /$process_name_rx/) { die "1-$test_msg\n"; } else { die "0-$test_msg\n"; } }; my $cron = Schedule::Cron->new( $dispatch_1, nofork => 1, ); $cron->add_entry('* * * * * 0-59'); eval { $cron->run(); }; my $error = $@; chomp $error; my ($ok, $msg) = split '-', $error, 2; ok $ok, $msg; $0 = $orig_proc_name; my $dispatch_2 = sub { my $test_msg = q(process name doesn't change with nostatus); if ($0 eq $orig_proc_name) { die "1-$test_msg\n"; } else { die "0-$test_msg\n"; } }; $cron = Schedule::Cron->new( $dispatch_2, nofork => 1, nostatus => 1 ); $cron->add_entry('* * * * * 0-59'); eval { $cron->run(); }; $error = $@; chomp $error; ($ok, $msg) = split '-', $error, 2; ok $ok, $msg; $0 = $orig_proc_name; my $dispatch_3 = sub { my $test_msg = 'nostatus overrides processprefix'; if ($0 eq $orig_proc_name) { die "1-$test_msg\n"; } else { print "\$0 = $0\n"; die "0-$test_msg\n"; } }; $cron = Schedule::Cron->new( $dispatch_3, nofork => 1, nostatus => 1, processprefix => 'foo' ); $cron->add_entry('* * * * * 0-59'); eval { $cron->run(); }; $error = $@; chomp $error; ($ok, $msg) = split '-', $error, 2; ok $ok, $msg; $0 = $orig_proc_name; my $dispatch_4 = sub { my $test_msg = 'process name prefixed with string when using processprefix'; my $rx = '^foo MainLoop - next: .+$'; if ($0 =~ /$rx/) { die "1-$test_msg\n"; } else { die "0-$test_msg\n"; } }; $cron = Schedule::Cron->new( $dispatch_4, nofork => 1, processprefix => 'foo' ); $cron->add_entry('* * * * * 0-59'); eval { $cron->run(); }; $error = $@; chomp $error; ($ok, $msg) = split '-', $error, 2; ok $ok, $msg; $0 = $orig_proc_name; my $dispatch_5 = sub { my $test_msg = 'process name set to constant string when using processname'; if ($0 eq 'foo') { die "1-$test_msg\n"; } else { die "0-$test_msg\n"; } }; $cron = Schedule::Cron->new( $dispatch_5, nofork => 1, processname => 'foo' ); $cron->add_entry('* * * * * 0-59'); eval { $cron->run(); }; $error = $@; chomp $error; ($ok, $msg) = split '-', $error, 2; ok $ok, $msg; $0 = $orig_proc_name; my $dispatch_6 = sub { my $test_msg = 'processname overrides nostatus and processprefix'; if ($0 eq 'foo') { die "1-$test_msg\n"; } else { die "0-$test_msg\n"; } }; $cron = Schedule::Cron->new( $dispatch_6, nofork => 1, processname => 'foo', nostatus => 1, processprefix => 'bar' ); $cron->add_entry('* * * * * 0-59'); eval { $cron->run(); }; $error = $@; chomp $error; ($ok, $msg) = split '-', $error, 2; ok $ok, $msg; $0 = $orig_proc_name; Schedule-Cron-1.07/t/sighandler.t0000644€@cR€@cR0000000126215233005403017054 0ustar nhubbardnhubbard#!perl -w # Startup Test: # $Id: sighandler.t,v 1.2 2006/11/27 13:42:52 roland Exp $ use Schedule::Cron; use Test::More; if ($^O =~ /Win32/i) { plan skip_all => "Test doesn't work on Win32"; } else { plan tests => 1; } $| = 1; SKIP: { eval { alarm 0 }; skip "alarm() not available", 1 if $@; # Check, whether an already installed signalhandler is called $SIG{CHLD} = sub { pass "SIGCHLD received"; exit 0; }; $SIG{ALRM} = sub { fail "SIGALRM received"; exit 0; }; my $cron = new Schedule::Cron(sub { sleep(1); }); $cron->add_entry("* * * * * *"); alarm(5); $cron->run; } Schedule-Cron-1.07/examples/0000755€@cR€@cR0000000000015233011176016125 5ustar nhubbardnhubbardSchedule-Cron-1.07/examples/simple.pl0000644€@cR€@cR0000000153515233005403017753 0ustar nhubbardnhubbard#!/usr/bin/perl # Very simple examples which print the current # time every 10 Minutes. # # The purpose is to show a common usage pattern # using a single dispatcher subroutine provided # at construction time use lib "../lib"; use Schedule::Cron; # Create new object with default dispatcher my $cron = new Schedule::Cron(\&dispatcher); # The cron entry which fires every 10 minutes my $entry = "0-59/5 * * * *"; # Dispatcher subroutine called from cron sub dispatcher { open(T,">>timestamps.txt"); print T "Current: ",scalar(localtime),"\n"; print T "Next: ",scalar(localtime($cron->get_next_execution_time($entry))),"\n"; close T; sleep(30); } # Call &dispatcher() every ten minutes $cron->add_entry($entry); # Run scheduler and block. 'nofork' forces the subroutine to # be called in the main process $cron->run(nofork=>1); Schedule-Cron-1.07/examples/custom_sleep.pl0000644€@cR€@cR0000002656115233005403021172 0ustar nhubbardnhubbard#!/usr/bin/perl # Copyright (c) 2011 Timothe Litt # # May be used on the same terms as Perl. # Sleep hook demo, showing how it enables a background thread # to provide a simple command interface to a daemon. =head1 custom_sleep - Demo for a custom 'sleep' function This example demonstrates the usage of the 'sleep' option for L with a custom sleep method which can dynamically modify the crontab even inbetween to cron events. It provides a cron daemon which listens on a TCP port for commands. Please note that this is an example only and should obviously not used for production ! When started, this script will listen on port 65331 and will first ask for a password. Use 'Purfect' here. Then the following commands are available: status -- Print internal job queue add id "cron spec" name -- Add a sample jon which will bring "id: name" each time "cron spec" fires load /path/to/crontab -- Load a crontab as with Schedule::Cron->load_crontab delete id -- Delete job entry quit -- Disconect A sample session looks like: First start the server: ./custom_sleep.pl Please wait while initialization is scheduled Schedule::Cron - Starting job 0 Ready, my port is localhost::65331 Schedule::Cron - Finished job 0 Schedule::Cron - Starting job 5 Now: Periodic Schedule::Cron - Finished job 5 And then a client: $ telnet localhost 65331 Trying 127.0.0.1... Connected to localhost.localdomain (127.0.0.1). Escape character is '^]'. Password: Purfect Password accepted status Job 0 0 0 1 1 * Next: Sun Jan 1 00:00:00 2012 - NewYear( ) End of job queue load cron.tab Loaded cron.tab status Job 1 34 2 * * Mon Next: Mon Jun 6 02:34:00 2011 - "make_stats"( ) Job 2 43 8 * * Wed Next: Wed Jun 8 08:43:00 2011 - "Make Peace"( ) Job 0 0 0 1 1 * Next: Sun Jan 1 00:00:00 2012 - NewYear( ) End of job queue add Halloween "30 18 31 10 *" Pumpkin time Added 30 18 31 10 * add Today "11 15 * * *" Something to do Added 11 15 * * * add Now "*/2 * * * * 30" Periodic Added */2 * * * * 30 status Job 5 */2 * * * * 30 Next: Thu Jun 2 13:40:30 2011 - Now( Periodic ) Job 4 11 15 * * * Next: Thu Jun 2 15:11:00 2011 - Today( Something to do ) Job 1 34 2 * * Mon Next: Mon Jun 6 02:34:00 2011 - "make_stats"( ) Job 2 43 8 * * Wed Next: Wed Jun 8 08:43:00 2011 - "Make Peace"( ) Job 3 30 18 31 10 * Next: Mon Oct 31 18:30:00 2011 - Halloween( Pumpkin time ) Job 0 0 0 1 1 * Next: Sun Jan 1 00:00:00 2012 - NewYear( ) End of job queue delete Today Deleted Today status Job 4 */2 * * * * 30 Next: Thu Jun 2 13:42:30 2011 - Now( Periodic ) Job 1 34 2 * * Mon Next: Mon Jun 6 02:34:00 2011 - "make_stats"( ) Job 2 43 8 * * Wed Next: Wed Jun 8 08:43:00 2011 - "Make Peace"( ) Job 3 30 18 31 10 * Next: Mon Oct 31 18:30:00 2011 - Halloween( Pumpkin time ) Job 0 0 0 1 1 * Next: Sun Jan 1 00:00:00 2012 - NewYear( ) End of job queue q Connection closed by foreign host. =cut use strict; use warnings; use Schedule::Cron; use Socket ':crlf'; use IO::Socket::INET; my $port = 65331; our $password = 'Purfect'; our( $lsock, $rin, $win, $maxfd, %servers ); my $cron = new Schedule::Cron( sub { print 'Loaded entry: ', join('', @_ ), "\n"; }, { nofork => 1, loglevel => 0, log => sub { print $_[1], "\n"; }, sleep => \&idler } ); $cron->add_entry( "* * * * * *", \&init, 'Init', $cron ); $cron->add_entry( "0 0 1 1 *", sub { print "Happy New Year\n"; }, "NewYear" ); print "Please wait while initialization is scheduled\n"; print help(); $cron->run( { detach => 0 } ); exit; sub idler { my( $time ) = @_; my( $rout, $wout ); my( $nfound, $ttg ) = select( $rout=$rin, $wout=$win, undef, $time ); if( $nfound ) { if( $nfound == -1 ) { die "select() error: $!\n"; # This will be an internal error, such as a stale fd. } for( my $n = 0; $n <= $maxfd; $n++ ) { if( vec( $rout, $n, 1 ) ) { my $s = $servers{$n}; $s->{rsub}->( ); } } for( my $n = 0; $n <= $maxfd; $n++ ) { if( vec( $wout, $n, 1 ) ) { my $s = $servers{$n}; $s->{wsub}->( ); } } } } # First task run initializes (usually in daemon, after forking closed open files) # I suppose this could be a postfork callback, but there isn't one... sub init { my( $name, $cron ) = @_; $cron->delete_entry( 'Init' ); $rin = ''; $win = ''; $lsock = IO::Socket::INET->new( LocalAddr => "localhost:$port", Proto => 'tcp', Type => SOCK_STREAM, Listen => 5, ReuseAddr => 1, Blocking => 0, ), or die "Unable to open status port $port $!\n"; vec( $rin, ($maxfd = $lsock->fileno()), 1 ) = 1; $servers{$maxfd} = { rsub=>sub { newConn( $lsock, $cron ); } }; print "Ready, my port is localhost:$port\nTo connect:\n telnet localhost $port\n"; return; } sub newConn { my( $lsock, $cron ) = @_; my $sock = $lsock->accept(); $sock->blocking(0); my $cx = { rbuf => '', wbuf => 'Password: ', }; my $fd = $sock->fileno(); $maxfd = $fd if( $maxfd < $fd ); vec( $rin, $fd, 1 ) = 1; vec( $win, $fd, 1 ) = 1; $servers{$fd} = { rsub=>sub { serverRd( $sock, $cx, $fd ); }, wsub=>sub { serverWr( $sock, $cx, $fd ); }, cron=>$cron, }; } sub serverRd { my( $sock, $cx, $fd ) = @_; # Read whatever is available. 1000 is arbitrary, 1 will work (with lots of overhead). # Huge will prevent any other thread from running. my $rn= $sock->sysread( $cx ->{rbuf}, 1000, length $cx->{rbuf} ); unless( defined $rn ) { print "Read error: $!\n"; } unless( $rn ) { # Connection closed by client vec( $rin, $fd, 1 ) = 0; vec( $win, $fd, 1 ) = 0; $sock->close(); undef $cx; return; } # Assemble reads to form whole lines # Decode each line as a command. while( $cx->{rbuf} =~ /$LF/sm ) { $cx->{rbuf} =~ s/$CR//g; my( $line, $rest ); ($line, $rest) = split( /$LF/, $cx->{rbuf}, 2 ); $rest = '' unless( defined $rest ); $cx->{rbuf} = $rest; # This is not secure, but one has to do something. # Demos always get used for more than they should.. # Please do better...like user/account validation # using the system services. unless( $cx->{authenticated} ){ if( $line eq $password ) { $cx->{authenticated} = 1; $cx->{wbuf} .= "Password accepted$CR$LF"; } else { $cx->{wbuf} .= "Password refused.$CR${LF}Password: "; } next; } if( $line =~ /^STAT(?:US)?(?: (\w+))?$/i ) { $cx->{wbuf} .= status( $cron, ($1 || 'normal') ); } elsif( $line =~ /^ADD\s+(\w+)\s+"(.*?)"\s+(.*)$/i ) { my( $name, $sched ) = ($1, $2); $cron->add_entry( $sched, \&announce, $1, $3 ); $cx->{wbuf} .= "Added $name '$sched'$CR$LF"; } elsif( $line =~ /^DEL(?:ETE)?\s+(["\w]+)$/i ) { my $name = $1; my $idx = $cron->check_entry( $name ); if( defined $idx ) { $cron->delete_entry( $idx ); $cx->{wbuf} .= "Deleted $name$CR$LF"; } else { $cx->{wbuf} .= "$name not found$CR$LF"; } } elsif( $line =~ /^HELP$/i ) { $cx->{wbuf} .= help(); } elsif( $line =~ /^LOAD\s([\w\._-]+)$/i ) { my $cfg = $1; # Danger: File permissions of server are used here. eval { $cron->load_crontab( $cfg ); }; my $emsg = $@; $emsg =~ s/\n/$CR$LF/gms; $cx->{wbuf} .= $emsg || "Loaded $cfg$CR$LF"; } elsif( $line =~ /^Q(?:uit)?$/i ) { $cx->{wbuf} .= "Bye$CR$LF"; $cx->{wend} = 1; } else { $cx->{wbuf} .= "Unrecognized command: $line$CR$LF"; } } serverWr( $sock, $cx, $fd ); } # Server write process # # Output as much as possible from our buffer. # If more remains, keep select mask active # If done, clear select mask. If last write, close socket. sub serverWr { my( $sock, $cx, $fd ) = @_; if( length $cx->{wbuf} ) { my $written = $sock->syswrite( $cx->{wbuf} ); $cx->{wbuf} = substr( $cx->{wbuf}, $written ); } if( length $cx->{wbuf} ) { vec( $win, $fd, 1 ) = 1; return; } else { vec( $win, $fd, 1 ) = 0; if( $cx->{wend} ) { vec( $rin, $fd, 1 ) = 0; $sock->close(); return; } } } sub announce { my( $id, $msg ) = @_; print "$id: $msg\n"; return; } sub status { my $cron = shift; my $level = shift; my $maxtwid = 0; my @entries = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { my $time = $_->{time}; $maxtwid = length $time if( $maxtwid < length $time ); [ $_, $cron->get_next_execution_time( $time ), ] } $cron->list_entries(); my $msg = "Job queue\n"; foreach my $qe ( @entries ) { my $job = $cron->check_entry( $qe->{args}->[0] ); next unless( defined $job ); #?? $msg .= sprintf( "Job %-4s %-*s Next: %s - %s", $job, $maxtwid, $qe->{time}, (scalar localtime( $cron->get_next_execution_time( $qe->{time}, 0 ) )), $qe->{args}->[0] || '', # Task name ); if( $level =~ /^debug$/i ) { $msg .= '( '; my @uargs = @{$qe->{args}}; $msg .= join( ', ', @uargs[1..$#uargs] ) . ' )'; } $msg .= "\n"; } $msg .= "End of job queue\n"; $msg =~ s/\n/$CR$LF/mgs; return $msg; } use Cwd 'getcwd'; sub help { my $wd = getcwd(); my $msg = <<"HELP"; CAUTION: Not production code. NOT secure. Do NOT run from privileged account. Commands: status Shows queue status debug With argument lists add name "schedule" A string to be printed when executed Adds a new task on specified schedule delete name Deletes a task (by name) help This message. load file Loads a crontab file from $wd CAUTION, this is with server permissions. If the server can read /etc/passwd (or anything else), it will display it in the error messages. As I said, NOT production... quit Exits. HELP $msg =~ s/\n/$CRLF/gms; return $msg; } Schedule-Cron-1.07/examples/cron.tab0000644€@cR€@cR0000000013715233005403017553 0ustar nhubbardnhubbard# Sample cron tab used for custom_sleep.pl 34 2 * * Mon "make_stats" 43 8 * * Wed "Make Peace" Schedule-Cron-1.07/Makefile.PL0000644€@cR€@cR0000000130715233005403016256 0ustar nhubbardnhubbarduse ExtUtils::MakeMaker; WriteMakefile ( NAME => "Schedule::Cron", VERSION_FROM => "lib/Schedule/Cron.pm", ($] >= 5.005 ? (ABSTRACT => 'Cron-like scheduler for Perl subroutines', AUTHOR => 'Roland Huss (roland@cpan.org)', META_MERGE => { resources => { repository => 'https://github.com/rhuss/schedule-cron', }, }, PL_FILES => {}) : ()), ($ExtUtils::MakeMaker::VERSION >= 6.3002 ? ('LICENSE' => 'perl', ) : ()), PREREQ_PM => { "Time::ParseDate" => '2011.0505',"Data::Dumper" => 0}, 'dist' => {COMPRESS=>'gzip',SUFFIX=>'gz'} ); Schedule-Cron-1.07/lib/0000755€@cR€@cR0000000000015233011176015055 5ustar nhubbardnhubbardSchedule-Cron-1.07/lib/Schedule/0000755€@cR€@cR0000000000015233011176016611 5ustar nhubbardnhubbardSchedule-Cron-1.07/lib/Schedule/Cron.pm0000644€@cR€@cR0000016371115233010221020047 0ustar nhubbardnhubbard#!/usr/bin/perl -w =encoding utf8 =head1 NAME Cron - cron-like scheduler for Perl subroutines =head1 SYNOPSIS use Schedule::Cron; # Subroutines to be called sub dispatcher { print "ID: ",shift,"\n"; print "Args: ","@_","\n"; } sub check_links { # do something... } # Create new object with default dispatcher my $cron = new Schedule::Cron(\&dispatcher); # Load a crontab file $cron->load_crontab("/var/spool/cron/perl"); # Add dynamically crontab entries $cron->add_entry("3 4 * * *",ROTATE => "apache","sendmail"); $cron->add_entry("0 11 * * Mon-Fri",\&check_links); # Run scheduler $cron->run(detach=>1); =head1 DESCRIPTION This module provides a simple but complete cron like scheduler. I.e this module can be used for periodically executing Perl subroutines. The dates and parameters for the subroutines to be called are specified with a format known as crontab entry (see L<"METHODS">, C and L) The philosophy behind C is to call subroutines periodically from within one single Perl program instead of letting C trigger several (possibly different) Perl scripts. Everything under one roof. Furthermore, C provides mechanism to create crontab entries dynamically, which isn't that easy with C. C knows about all extensions (well, at least all extensions I'm aware of, i.e those of the so called "Vixie" cron) for crontab entries like ranges including 'steps', specification of month and days of the week by name, or coexistence of lists and ranges in the same field. It even supports a bit more (like lists and ranges with symbolic names). =head1 METHODS =over 4 =cut #' package Schedule::Cron; use Time::ParseDate; use Data::Dumper; use strict; use vars qw($VERSION $DEBUG); use subs qw(dbg); my $HAS_POSIX; BEGIN { eval { require POSIX; import POSIX ":sys_wait_h"; }; $HAS_POSIX = $@ ? 0 : 1; } $VERSION = "1.07"; our $DEBUG = 0; my %STARTEDCHILD = (); my @WDAYS = qw( Sunday Monday Tuesday Wednesday Thursday Friday Saturday Sunday ); my @ALPHACONV = ( { }, { }, { }, { qw(jan 1 feb 2 mar 3 apr 4 may 5 jun 6 jul 7 aug 8 sep 9 oct 10 nov 11 dec 12) }, { qw(sun 0 mon 1 tue 2 wed 3 thu 4 fri 5 sat 6)}, { } ); my @RANGES = ( [ 0,59 ], [ 0,23 ], [ 0,31 ], [ 0,12 ], [ 0,7 ], [ 0,59 ] ); my @LOWMAP = ( {}, {}, { 0 => 1}, { 0 => 1}, { 7 => 0}, {}, ); # Currently, there are two ways for reaping. One, which only waits explicitly # on PIDs it forked on its own, and one which waits on all PIDs (even on those # it doesn't forked itself). The later has been proved to work on Win32 with # the 64 threads limit (RT #56926), but not when one creates forks on ones # own. The specific reaper works for RT #55741. # It tend to use the specific one, if it also resolves RT #56926. Both are left # here for reference until a decision has been done for 1.01 sub REAPER { &_reaper_all(); } # Specific reaper sub _reaper_specific { local ($!,%!,$?); if ($HAS_POSIX) { foreach my $pid (keys %STARTEDCHILD) { if ($STARTEDCHILD{$pid}) { my $res = $HAS_POSIX ? waitpid($pid, WNOHANG) : waitpid($pid,0); if ($res > 0) { # We reaped a truly running process $STARTEDCHILD{$pid} = 0; dbg "Reaped child $res" if $DEBUG; } } } } else { my $waitedpid = 0; while($waitedpid != -1) { $waitedpid = wait; } } } # Catch all reaper sub _reaper_all { #local ($!,%!,$?,${^CHILD_ERROR_NATIVE}); # Localizing ${^CHILD_ERROR_NATIVE} breaks signalhander.t which checks that # chained SIGCHLD handlers are called. I don't know why, though, hence I # leave it out for now. See #69916 for some discussion why this handler # might be needed. local ($!,%!,$?); my $kid; do { # Only on POSIX systems the wait will return immediately # if there are no finished child processes. Simple 'wait' # waits blocking on childs. $kid = $HAS_POSIX ? waitpid(-1, WNOHANG) : wait; dbg "Kid: $kid" if $DEBUG; if ($kid != 0 && $kid != -1 && defined $STARTEDCHILD{$kid}) { # We don't delete the hash entry here to avoid an issue # when modifying global hash from multiple threads $STARTEDCHILD{$kid} = 0; dbg "Reaped child $kid" if $DEBUG; } } while ($kid != 0 && $kid != -1); # Note to myself: Is the %STARTEDCHILD hash really necessary if we use -1 # for waiting (i.e. for waiting on any child ?). In the current # implementation, %STARTEDCHILD is not used at all. It would be only # needed if we iterate over it to wait on pids specifically. } # Cleaning is done in extra method called from the main # process in order to avoid event handlers modifying this # global hash which can lead to memory errors. # See RT #55741 for more details on this. # This method is called in strategic places. sub _cleanup_process_list { my ($self, $cfg) = @_; # Cleanup processes even on those systems, where the SIGCHLD is not # propagated. Only do this for POSIX, otherwise this call would block # until all child processes would have been finished. # See RT #56926 for more details. # Do not cleanup if nofork because jobs that fork will do their own reaping. &REAPER() if $HAS_POSIX && !$cfg->{nofork}; # Delete entries from this global hash only from within the main # thread/process. Hence, this method must not be called from within # a signalhandler for my $k (keys %STARTEDCHILD) { delete $STARTEDCHILD{$k} unless $STARTEDCHILD{$k}; } } =item $cron = new Schedule::Cron($dispatcher,[extra args]) Creates a new C object. C<$dispatcher> is a reference to a subroutine, which will be called by default. C<$dispatcher> will be invoked with the arguments parameter provided in the crontab entry if no other subroutine is specified. This can be either a single argument containing the argument parameter literally has string (default behavior) or a list of arguments when using the C option described below. The date specifications must be either provided via a crontab like file or added explicitly with C (L<"add_entry">). I can be a hash or hash reference for additional arguments. The following parameters are recognized: =over =item file => Load the crontab entries from =item eval => 1 Eval the argument parameter in a crontab entry before calling the subroutine (instead of literally calling the dispatcher with the argument parameter as string) =item nofork => 1 Don't fork when starting the scheduler. Instead, the jobs are executed within current process. In your executed jobs, you have full access to the global variables of your script and hence might influence other jobs running at a different time. This behavior is fundamentally different to the 'fork' mode, where each jobs gets its own process and hence a B of the process space, independent of each other job and the main process. This is due to the nature of the C system call. =item nostatus => 1 Do not update status in $0. Set this if you don't want ps to reveal the internals of your application, including job argument lists. Default is 0 (update status). =item skip => 1 Skip any pending jobs whose time has passed. This option is only useful in combination with C where a job might block the execution of the following jobs for quite some time. By default, any pending job is executed even if its scheduled execution time has already passed. With this option set to true all pending which would have been started in the meantime are skipped. =item catch => 1 Catch any exception raised by a job. This is especially useful in combination with the C option to avoid stopping the main process when a job raises an exception (dies). =item after_job => \&after_sub Call a subroutine after a job has been run. The first argument is the return value of the dispatched job, the reminding arguments are the arguments with which the dispatched job has been called. Example: my $cron = new Schedule::Cron(..., after_job => sub { my ($ret,@args) = @_; print "Return value: ",$ret," - job arguments: (",join ":",@args,")\n"; }); =item log => \&log_sub Install a logging subroutine. The given subroutine is called for several events during the lifetime of a job. This method is called with two arguments: A log level of 0 (info),1 (warning) or 2 (error) depending on the importance of the message and the message itself. For example, you could use I (L) for logging purposes for example like in the following code snippet: use Log::Log4perl; use Log::Log4perl::Level; my $log_method = sub { my ($level,$msg) = @_; my $DBG_MAP = { 0 => $INFO, 1 => $WARN, 2 => $ERROR }; my $logger = Log::Log4perl->get_logger("My::Package"); $logger->log($DBG_MAP->{$level},$msg); } my $cron = new Schedule::Cron(.... , log => $log_method); =item loglevel => <-1,0,1,2> Restricts logging to the specified severity level or below. Use 0 to have all messages generated, 1 for only warnings and errors and 2 for errors only. Default is 0 (all messages). A loglevel of -1 (debug) will include job argument lists (also in $0) in the job start message logged with a level of 0 or above. You may have security concerns with this. Unless you are debugging, use 0 or higher. A value larger than 2 will disable logging completely. Although you can filter in your log routine, generating the messages can be expensive, for example if you pass arguments pointing to large hashes. Specifying a loglevel avoids formatting data that your routine would discard. =item processprefix => Cron::Schedule sets the process' name (i.e. C<$0>) to contain some informative messages like when the next job executes or with which arguments a job is called. By default, the prefix for this labels is C. With this option you can set it to something different. You can e.g. use C<$0> to include the original process name. You can inhibit this with the C option, and prevent the argument display by setting C to zero or higher. =item processname => Set the process name (i.e. C<$0>) to a literal string. Using this setting overrides C and C. =item sleep => \&hook If specified, &hook will be called instead of sleep(), with the time to sleep in seconds as first argument and the Schedule::Cron object as second. This hook allows you to use select() instead of sleep, so that you can handle IO, for example job requests from a network connection. e.g. $cron->run( { sleep => \&sleep_hook, nofork => 1 } ); sub sleep_hook { my ($time, $cron) = @_; my ($rin, $win, $ein) = ('','',''); my ($rout, $wout, $eout); vec($rin, fileno(STDIN), 1) = 1; my ($nfound, $ttg) = select($rout=$rin, $wout=$win, $eout=$ein, $time); if ($nfound) { handle_io($rout, $wout, $eout); } return; } =back =cut sub new { my $class = shift; my $dispatcher = shift || die "No dispatching sub provided"; die "Dispatcher not a ref to a subroutine" unless ref($dispatcher) eq "CODE"; my $cfg = ref($_[0]) eq "HASH" ? $_[0] : { @_ }; $cfg->{processprefix} = "Schedule::Cron" unless $cfg->{processprefix}; my $timeshift = $cfg->{timeshift} || 0; my $self = { cfg => $cfg, dispatcher => $dispatcher, timeshift => $timeshift, queue => [ ], map => { } }; bless $self,(ref($class) || $class); $self->load_crontab if $cfg->{file}; $self; } =item $cron->load_crontab($file) =item $cron->load_crontab(file=>$file,[eval=>1]) Loads and parses the crontab file C<$file>. The entries found in this file will be B to the current time table with C<$cron-Eadd_entry>. The format of the file consists of cron commands containing of lines with at least 5 columns, whereas the first 5 columns specify the date. The rest of the line (i.e columns 6 and greater) contains the argument with which the dispatcher subroutine will be called. By default, the dispatcher will be called with one single string argument containing the rest of the line literally. Alternatively, if you call this method with the optional argument C1> (you must then use the second format shown above), the rest of the line will be evaled before used as argument for the dispatcher. For the format of the first 5 columns, please see L<"add_entry">. Blank lines and lines starting with a C<#> will be ignored. There's no way to specify another subroutine within the crontab file. All calls will be made to the dispatcher provided at construction time. If you want to start up fresh, you should call C<$cron-Eclean_timetable()> before. Example of a crontab fiqw(le:) # The following line runs on every Monday at 2:34 am 34 2 * * Mon "make_stats" # The next line should be best read in with an eval=>1 argument * * 1 1 * { NEW_YEAR => '1',HEADACHE => 'on' } =cut #' sub load_crontab { my $self = shift; my $cfg = shift; if ($cfg) { if (@_) { $cfg = ref($cfg) eq "HASH" ? $cfg : { $cfg,@_ }; } elsif (!ref($cfg)) { my $new_cfg = { }; $new_cfg->{file} = $cfg; $cfg = $new_cfg; } } my $file = $cfg->{file} || $self->{cfg}->{file} || die "No filename provided"; my $eval = $cfg->{eval} || $self->{cfg}->{eval}; open(F,$file) || die "Cannot open schedule $file : $!"; my $line = 0; while () { $line++; # Strip off trailing comments and ignore empty # or pure comments lines: s/#.*$//; next if /^\s*$/; next if /^\s*#/; chomp; s/\s*(.*)\s*$/$1/; my ($min,$hour,$dmon,$month,$dweek,$rest) = split (/\s+/,$_,6); my $time = [ $min,$hour,$dmon,$month,$dweek ]; # Try to check, whether an optional 6th column specifying seconds # exists: my $args; if ($rest) { my ($col6,$more_args) = split(/\s+/,$rest,2); if ($col6 =~ /^[\d\-\*\,\/]+$/) { push @$time,$col6; dbg "M: $more_args"; $args = $more_args; } else { $args = $rest; } } $self->add_entry($time,{ 'args' => $args, 'eval' => $eval}); } close F; } =item $cron->add_entry($timespec,[arguments]) Adds a new entry to the list of scheduled cron jobs. B