Catalyst-Plugin-Scheduler-0.10/0000755000175000017500000000000011367557076015677 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/Changes0000644000175000017500000000256211367556734017177 0ustar bricasbricasRevision history for Perl extension Catalyst::Plugin::Scheduler 0.10 2010-05-03 11:29:00 - Fix warnings in test suite (BRICAS) - Switch to Module::Install (BRICAS) - Fix pod typo (RT #47434) 0.09 2009-05-07 09:15:00 - Change from NEXT to MRO::Compat. (agladdish) 0.08 2008-01-12 11:00:00 - Clear existing state file during startup. (hovenko) 0.07 2006-07-17 12:15:00 - Fix for loading the config with YAML 0.60+ - Prefer YAML::Syck, with fallback to YAML.pm 0.06 2006-03-10 10:10:00 - Added $c->scheduler_state public method to allow users to build admin screens detailing the current status of every event, the last time it ran, and the last output or error. - Store the last runtime and last output from each event for display in scheduler_state/dump_these. - Added additional YAML tests. 0.05 2005-12-29 15:50:00 - Fixed bug when using @monthly. 0.04 2005-12-28 15:15:00 - Added dump_these support to display all event info on the debug screen. 0.03 2005-12-15 16:00:00 - Fixed yaml_file option. 0.02 2005-12-15 15:40:00 - Fixed pod coverage. - Hide timezone warning unless logging is enabled. - Hide expected errors during test 4. 0.01 2005-12-15 15:30:00 - initial release Catalyst-Plugin-Scheduler-0.10/META.yml0000644000175000017500000000123511367557041017141 0ustar bricasbricas--- abstract: 'Schedule events to run in a cron-like fashion' author: - 'Andy Grundman, ' build_requires: ExtUtils::MakeMaker: 6.42 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 0.95' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Catalyst-Plugin-Scheduler no_index: directory: - inc - t requires: Catalyst::Runtime: 5.61 DateTime::Event::Cron: 0 MRO::Compat: 0 Set::Scalar: 0 Storable: 0 YAML: 0 perl: 5.8.0 resources: license: http://dev.perl.org/licenses/ version: 0.10 Catalyst-Plugin-Scheduler-0.10/Makefile.PL0000644000175000017500000000066111367545343017646 0ustar bricasbricasuse inc::Module::Install 0.91; if( -e 'MANIFEST.SKIP' ) { system( 'pod2text lib/Catalyst/Plugin/Scheduler.pm > README' ); } perl_version '5.008'; name 'Catalyst-Plugin-Scheduler'; all_from 'lib/Catalyst/Plugin/Scheduler.pm'; requires 'Catalyst::Runtime' => '5.61'; requires 'DateTime::Event::Cron'; requires 'Set::Scalar'; requires 'Storable'; requires 'YAML'; requires 'MRO::Compat'; test_requires 'Test::More'; WriteAll; Catalyst-Plugin-Scheduler-0.10/README0000644000175000017500000002503411367557041016553 0ustar bricasbricasNAME Catalyst::Plugin::Scheduler - Schedule events to run in a cron-like fashion SYNOPSIS use Catalyst qw/Scheduler/; # run remove_sessions in the Cron controller every hour __PACKAGE__->schedule( at => '0 * * * *', event => '/cron/remove_sessions' ); # Run a subroutine at 4:05am every Sunday __PACKAGE__->schedule( at => '5 4 * * sun', event => \&do_stuff, ); # A long-running scheduled event that must be triggered # manually by an authorized user __PACKAGE__->schedule( trigger => 'rebuild_search_index', event => '/cron/rebuild_search_index', ); $ wget -q http://www.myapp.com/?schedule_trigger=rebuild_search_index DESCRIPTION This plugin allows you to schedule events to run at recurring intervals. Events will run during the first request which meets or exceeds the specified time. Depending on the level of traffic to the application, events may or may not run at exactly the correct time, but it should be enough to satisfy many basic scheduling needs. CONFIGURATION Configuration is optional and is specified in MyApp->config->{scheduler}. logging Set to 1 to enable logging of events as they are executed. This option is enabled by default when running under -Debug mode. Errors are always logged regardless of the value of this option. time_zone The time zone of your system. This will be autodetected where possible, or will default to UTC (GMT). You can override the detection by providing a valid DateTime time zone string, such as 'America/New_York'. state_file The current state of every event is stored in a file. By default this is $APP_HOME/scheduler.state. This file is created on the first request if it does not already exist. yaml_file The location of the optional YAML event configuration file. By default this is $APP_HOME/scheduler.yml. hosts_allow This option specifies IP addresses for trusted users. This option defaults to 127.0.0.1. Multiple addresses can be specified by using an array reference. This option is used for both events where auto_run is set to 0 and for manually-triggered events. __PACKAGE__->config->{scheduler}->{hosts_allow} = '192.168.1.1'; __PACKAGE__->config->{scheduler}->{hosts_allow} = [ '127.0.0.1', '192.168.1.1' ]; SCHEDULING AUTOMATED EVENTS Events are scheduled by calling the class method "schedule". MyApp->schedule( at => '0 * * * *', event => '/cron/remove_sessions', ); package MyApp::Controller::Cron; sub remove_sessions : Private { my ( $self, $c ) = @_; $c->delete_expired_sessions; } at The time to run an event is specified using crontab(5)-style syntax. 5 0 * * * # 5 minutes after midnight, every day 15 14 1 * * # run at 2:15pm on the first of every month 0 22 * * 1-5 # run at 10 pm on weekdays 5 4 * * sun # run at 4:05am every Sunday From crontab(5): field allowed values ----- -------------- minute 0-59 hour 0-23 day of month 1-31 month 0-12 (or names, see below) day of week 0-7 (0 or 7 is Sun, or use names) Instead of the first five fields, one of seven special strings may appear: string meaning ------ ------- @yearly Run once a year, "0 0 1 1 *". @annually (same as @yearly) @monthly Run once a month, "0 0 1 * *". @weekly Run once a week, "0 0 * * 0". @daily Run once a day, "0 0 * * *". @midnight (same as @daily) @hourly Run once an hour, "0 * * * *". event The event to run at the specified time can be either a Catalyst private action path or a coderef. Both types of event methods will receive the $c object from the current request, but you must not rely on any request-specific information present in $c as it will be from a random user request at or near the event's specified run time. Important: Methods used for events should be marked "Private" so that they can not be executed via the browser. auto_run The auto_run parameter specifies when the event is allowed to be executed. By default this option is set to 1, so the event will be executed during the first request that matches the specified time in "at". If set to 0, the event will only run when a request is made by a user from an authorized address. The purpose of this option is to allow long-running tasks to execute only for certain users. MyApp->schedule( at => '0 0 * * *', event => '/cron/rebuild_search_index', auto_run => 0, ); package MyApp::Controller::Cron; sub rebuild_search_index : Private { my ( $self, $c ) = @_; # rebuild the search index, this may take a long time } Now, the search index will only be rebuilt when a request is made from a user whose IP address matches the list in the "hosts_allow" config option. To run this event, you probably want to ping the app from a cron job. 0 0 * * * wget -q http://www.myapp.com/ MANUAL EVENTS To create an event that does not run on a set schedule and must be manually triggered, you can specify the "trigger" option instead of "at". __PACKAGE__->schedule( trigger => 'send_email', event => '/events/send_email', ); The event may then be triggered by a standard web request from an authorized user. The trigger to run is specified by using a special GET parameter, 'schedule_trigger'; the path requested does not matter. http://www.myapp.com/?schedule_trigger=send_email By default, manual events may only be triggered by requests made from localhost (127.0.0.1). To allow other addresses to run events, use the configuration option "hosts_allow". SCHEDULING USING A YAML FILE As an alternative to using the schedule() method, you may define scheduled events in an external YAML file. By default, the plugin looks for the existence of a file called "scheduler.yml" in your application's home directory. You can change the filename using the configuration option "yaml_file". Modifications to this file will be re-read once per minute during the normal event checking process. Here's an example YAML configuration file with 4 events. Each event is denoted with a '-' character, followed by the same parameters used by the "schedule" method. Note that coderef events are not supported by the YAML file. --- - at: '* * * * *' event: /cron/delete_sessions - event: /cron/send_email trigger: send_email - at: '@hourly' event: /cron/hourly - at: 0 0 * * * auto_run: 0 event: /cron/rebuild_search_index SECURITY All events are run inside of an eval container. This protects the user from receiving any error messages or page crashes if an event fails to run properly. All event errors are logged, even if logging is disabled. PLUGIN SUPPORT Other plugins may register scheduled events if they need to perform periodic maintenance. Plugin authors, be sure to inform your users if you do this! Events should be registered from a plugin's "setup" method. sub setup { my $c = shift; $c->maybe::next::method(@_); if ( $c->can('schedule') ) { $c->schedule( at => '0 * * * *', event => \&cleanup, ); } } CAVEATS The time at which an event will run is determined completely by the requests made to the application. Apps with heavy traffic may have events run at very close to the correct time, whereas apps with low levels of traffic may see events running much later than scheduled. If this is a problem, you can use a real cron entry that simply hits your application at the desired time. 0 * * * * wget -q http://www.myapp.com/ Events which consume a lot of time will slow the request processing for the user who triggers the event. For these types of events, you should use auto_run => 0 or manual event triggering. PERFORMANCE The plugin only checks once per minute if any events need to be run, so the overhead on each request is minimal. On my test server, the difference between running with Scheduler and without was only around 0.02% (0.004 seconds). Of course, when a scheduled event runs, performance will depend on what's being run in the event. METHODS schedule Schedule is a class method for adding scheduled events. See the "SCHEDULING"" in " section for more information. scheduler_state The current state of all scheduled events is available in an easy-to-use format by calling $c->scheduler_state. You can use this data to build an admin view into the scheduling engine, for example. This same data is also displayed on the Catalyst debug screen. This method returns an array reference containing a hash reference for each event. [ { 'last_run' => '2005-12-29 16:29:33 EST', 'auto_run' => 1, 'last_output' => 1, 'at' => '0 0 * * *', 'next_run' => '2005-12-30 00:00:00 EST', 'event' => '/cron/session_cleanup' }, { 'auto_run' => 1, 'at' => '0 0 * * *', 'next_run' => '2005-12-30 00:00:00 EST', 'event' => '/cron/build_rss' }, ] INTERNAL METHODS The following methods are extended by this plugin. dispatch The main scheduling logic takes place during the dispatch phase. dump_these On the Catalyst debug screen, all scheduled events are displayed along with the next time they will be executed. setup SEE ALSO crontab(5) AUTHOR Andy Grundman, COPYRIGHT This program is free software, you can redistribute it and/or modify it under the same terms as Perl itself. Catalyst-Plugin-Scheduler-0.10/lib/0000755000175000017500000000000011367557076016445 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/lib/Catalyst/0000755000175000017500000000000011367557076020231 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/lib/Catalyst/Plugin/0000755000175000017500000000000011367557076021467 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/lib/Catalyst/Plugin/Scheduler.pm0000644000175000017500000005513011367547115023740 0ustar bricasbricaspackage Catalyst::Plugin::Scheduler; use strict; use warnings; use base qw/Class::Accessor::Fast Class::Data::Inheritable/; use DateTime; use DateTime::Event::Cron; use DateTime::TimeZone; use File::stat; use Set::Scalar; use Storable qw/lock_store lock_retrieve/; use MRO::Compat; our $VERSION = '0.10'; __PACKAGE__->mk_classdata( '_events' => [] ); __PACKAGE__->mk_accessors('_event_state'); sub schedule { my ( $class, %args ) = @_; unless ( $args{event} ) { Catalyst::Exception->throw( message => 'The schedule method requires an event parameter' ); } my $conf = $class->config->{scheduler}; my $event = { trigger => $args{trigger}, event => $args{event}, auto_run => ( defined $args{auto_run} ) ? $args{auto_run} : 1, }; if ( $args{at} ) { # replace keywords that Set::Crontab doesn't support $args{at} = _prepare_cron( $args{at} ); # parse the cron entry into a DateTime::Set my $set; eval { $set = DateTime::Event::Cron->from_cron( $args{at} ) }; if ($@) { Catalyst::Exception->throw( "Scheduler: Unable to parse 'at' value " . $args{at} . ': ' . $@ ); } else { $event->{at} = $args{at}; $event->{set} = $set; } } push @{ $class->_events }, $event; } sub dispatch { my $c = shift; $c->maybe::next::method(); $c->_get_event_state(); $c->_check_yaml(); # check if a minute has passed since our last check # This check is not run if the user is manually triggering an event if ( time - $c->_event_state->{last_check} < 60 ) { return unless $c->req->params->{schedule_trigger}; } my $last_check = $c->_event_state->{last_check}; $c->_event_state->{last_check} = time; $c->_save_event_state(); my $conf = $c->config->{scheduler}; my $last_check_dt = DateTime->from_epoch( epoch => $last_check, time_zone => $conf->{time_zone} ); my $now = DateTime->now( time_zone => $conf->{time_zone} ); EVENT: for my $event ( @{ $c->_events } ) { my $next_run; if ( $event->{trigger} && $c->req->params->{schedule_trigger} && $event->{trigger} eq $c->req->params->{schedule_trigger} ) { # manual trigger, run it now next EVENT unless $c->_event_authorized; $next_run = $now; } else { next EVENT unless $event->{set}; $next_run = $event->{set}->next($last_check_dt); } if ( $next_run <= $now ) { # do some security checking for non-auto-run events if ( !$event->{auto_run} ) { next EVENT unless $c->_event_authorized; } # make sure we're the only process running this event next EVENT unless $c->_mark_running($event); my $event_name = $event->{trigger} || $event->{event}; $c->log->debug("Scheduler: Executing $event_name") if $c->config->{scheduler}->{logging}; # trap errors local $c->{error} = []; # return value/output from the event, if any my $output; # run event eval { # do not allow the event to modify the response local $c->res->{body}; local $c->res->{cookies}; local $c->res->{headers}; local $c->res->{location}; local $c->res->{status}; if ( ref $event->{event} eq 'CODE' ) { $output = $event->{event}->($c); } else { $output = $c->forward( $event->{event} ); } }; my @errors = @{ $c->{error} }; push @errors, $@ if $@; if (@errors) { $c->log->error( 'Scheduler: Error executing ' . "$event_name: $_" ) for @errors; $output = join '; ', @errors; } $c->_mark_finished( $event, $output ); } } } sub setup { my $c = shift; # initial configuration $c->config->{scheduler}->{logging} ||= ( $c->debug ) ? 1 : 0; $c->config->{scheduler}->{time_zone} ||= $c->_detect_timezone(); $c->config->{scheduler}->{state_file} ||= $c->path_to('scheduler.state'); $c->config->{scheduler}->{hosts_allow} ||= '127.0.0.1'; $c->config->{scheduler}->{yaml_file} ||= $c->path_to('scheduler.yml'); # Always start with a clean state if ( -e $c->config->{scheduler}->{state_file} ) { $c->log->debug( 'Scheduler: Removing old state file ' . $c->config->{scheduler}->{state_file} ) if $c->config->{scheduler}->{logging}; unlink $c->config->{scheduler}->{state_file} or Catalyst::Exception->throw( message => 'Scheduler: Unable to remove old state file ' . $c->config->{scheduler}->{state_file} . " ($!)" ); } $c->maybe::next::method(@_); } sub dump_these { my $c = shift; return ( $c->maybe::next::method(@_) ) unless @{ $c->_events }; # for debugging, we dump out a list of all events with their next # scheduled run time return ( $c->maybe::next::method(@_), [ 'Scheduled Events', $c->scheduler_state ], ); } sub scheduler_state { my $c = shift; $c->_get_event_state(); my $conf = $c->config->{scheduler}; my $now = DateTime->now( time_zone => $conf->{time_zone} ); my $last_check = $c->_event_state->{last_check}; my $last_check_dt = DateTime->from_epoch( epoch => $last_check, time_zone => $conf->{time_zone}, ); my $event_dump = []; for my $event ( @{ $c->_events } ) { my $dump = {}; for my $key ( qw/at trigger event auto_run/ ) { $dump->{$key} = $event->{$key} if $event->{$key}; } # display the next run time if ( $event->{set} ) { my $next_run = $event->{set}->next($last_check_dt); $dump->{next_run} = $next_run->ymd . q{ } . $next_run->hms . q{ } . $next_run->time_zone_short_name; } # display the last run time my $last_run = $c->_event_state->{events}->{ $event->{event} }->{last_run}; if ( $last_run ) { $last_run = DateTime->from_epoch( epoch => $last_run, time_zone => $conf->{time_zone}, ); $dump->{last_run} = $last_run->ymd . q{ } . $last_run->hms . q{ } . $last_run->time_zone_short_name; } # display the result of the last run my $output = $c->_event_state->{events}->{ $event->{event} }->{last_output}; if ( $output ) { $dump->{last_output} = $output; } push @{$event_dump}, $dump; } return $event_dump; } # check and reload the YAML file with schedule data sub _check_yaml { my ($c) = @_; # each process needs to load the YAML file independently if ( $c->_event_state->{yaml_mtime}->{$$} ||= 0 ) { return if ( time - $c->_event_state->{last_check} < 60 ); } return unless -e $c->config->{scheduler}->{yaml_file}; eval { my $mtime = ( stat $c->config->{scheduler}->{yaml_file} )->mtime; if ( $mtime > $c->_event_state->{yaml_mtime}->{$$} ) { $c->_event_state->{yaml_mtime}->{$$} = $mtime; # clean up old PIDs listed in yaml_mtime foreach my $pid ( keys %{ $c->_event_state->{yaml_mtime} } ) { if ( $c->_event_state->{yaml_mtime}->{$pid} < $mtime ) { delete $c->_event_state->{yaml_mtime}->{$pid}; } } $c->_save_event_state(); # wipe out all current events and reload from YAML $c->_events( [] ); my $file = $c->config->{scheduler}->{yaml_file}; my $yaml; eval { require YAML::Syck; }; if( $@ ) { require YAML; $yaml = YAML::LoadFile( "$file" ); } else { open( my $fh, $file ) or die $!; my $content = do { local $/; <$fh> }; close $fh; $yaml = YAML::Syck::Load( $content ); } foreach my $event ( @{$yaml} ) { $c->schedule( %{$event} ); } $c->log->info( "Scheduler: PID $$ loaded " . scalar @{$yaml} . ' events from YAML file' ) if $c->config->{scheduler}->{logging}; } }; if ($@) { $c->log->error("Scheduler: Error reading YAML file: $@"); } } # Detect the current time zone sub _detect_timezone { my $c = shift; my $tz; eval { $tz = DateTime::TimeZone->new( name => 'local' ) }; if ($@) { $c->log->warn( 'Scheduler: Unable to autodetect local time zone, using UTC') if $c->config->{scheduler}->{logging}; return 'UTC'; } else { $c->log->debug( 'Scheduler: Using autodetected time zone: ' . $tz->name ) if $c->config->{scheduler}->{logging}; return $tz->name; } } # Check for authorized users on non-auto events sub _event_authorized { my $c = shift; # this should never happen, but just in case... return unless $c->req->address; my $hosts_allow = $c->config->{scheduler}->{hosts_allow}; $hosts_allow = [$hosts_allow] unless ref($hosts_allow) eq 'ARRAY'; my $allowed = Set::Scalar->new( @{$hosts_allow} ); return $allowed->contains( $c->req->address ); } # get the state from the state file sub _get_event_state { my $c = shift; if ( -e $c->config->{scheduler}->{state_file} ) { $c->_event_state( lock_retrieve $c->config->{scheduler}->{state_file} ); } else { # initialize the state file $c->_event_state( { last_check => time, events => {}, yaml_mtime => {}, } ); $c->_save_event_state(); } } # Check the state file to ensure we are the only process running an event sub _mark_running { my ( $c, $event ) = @_; $c->_get_event_state(); return if $c->_event_state->{events}->{ $event->{event} }->{running}; # this is a 2-step process to prevent race conditions # 1. write the state file with our PID $c->_event_state->{events}->{ $event->{event} }->{running} = $$; $c->_save_event_state(); # 2. re-read the state file and make sure it's got the same PID $c->_get_event_state(); if ( $c->_event_state->{events}->{ $event->{event} }->{running} == $$ ) { return 1; } return; } # Mark an event as finished sub _mark_finished { my ( $c, $event, $output ) = @_; $c->_event_state->{events}->{ $event->{event} }->{running} = 0; $c->_event_state->{events}->{ $event->{event} }->{last_run} = time; $c->_event_state->{events}->{ $event->{event} }->{last_output} = $output; $c->_save_event_state(); } # update the state file on disk sub _save_event_state { my $c = shift; lock_store $c->_event_state, $c->config->{scheduler}->{state_file}; } # Set::Crontab does not support day names, or '@' shortcuts sub _prepare_cron { my $cron = shift; return $cron unless $cron =~ /\w/; my %replace = ( jan => 1, feb => 2, mar => 3, apr => 4, may => 5, jun => 6, jul => 7, aug => 8, sep => 9, 'oct' => 10, nov => 11, dec => 12, sun => 0, mon => 1, tue => 2, wed => 3, thu => 4, fri => 5, sat => 6, ); my %replace_at = ( 'yearly' => '0 0 1 1 *', 'annually' => '0 0 1 1 *', 'monthly' => '0 0 1 * *', 'weekly' => '0 0 * * 0', 'daily' => '0 0 * * *', 'midnight' => '0 0 * * *', 'hourly' => '0 * * * *', ); if ( $cron =~ /^\@/ ) { $cron =~ s/^\@//; return $replace_at{ $cron }; } for my $name ( keys %replace ) { my $value = $replace{$name}; $cron =~ s/$name/$value/i; last unless $cron =~ /\w/; } return $cron; } 1; __END__ =pod =head1 NAME Catalyst::Plugin::Scheduler - Schedule events to run in a cron-like fashion =head1 SYNOPSIS use Catalyst qw/Scheduler/; # run remove_sessions in the Cron controller every hour __PACKAGE__->schedule( at => '0 * * * *', event => '/cron/remove_sessions' ); # Run a subroutine at 4:05am every Sunday __PACKAGE__->schedule( at => '5 4 * * sun', event => \&do_stuff, ); # A long-running scheduled event that must be triggered # manually by an authorized user __PACKAGE__->schedule( trigger => 'rebuild_search_index', event => '/cron/rebuild_search_index', ); $ wget -q http://www.myapp.com/?schedule_trigger=rebuild_search_index =head1 DESCRIPTION This plugin allows you to schedule events to run at recurring intervals. Events will run during the first request which meets or exceeds the specified time. Depending on the level of traffic to the application, events may or may not run at exactly the correct time, but it should be enough to satisfy many basic scheduling needs. =head1 CONFIGURATION Configuration is optional and is specified in MyApp->config->{scheduler}. =head2 logging Set to 1 to enable logging of events as they are executed. This option is enabled by default when running under -Debug mode. Errors are always logged regardless of the value of this option. =head2 time_zone The time zone of your system. This will be autodetected where possible, or will default to UTC (GMT). You can override the detection by providing a valid L time zone string, such as 'America/New_York'. =head2 state_file The current state of every event is stored in a file. By default this is $APP_HOME/scheduler.state. This file is created on the first request if it does not already exist. =head2 yaml_file The location of the optional YAML event configuration file. By default this is $APP_HOME/scheduler.yml. =head2 hosts_allow This option specifies IP addresses for trusted users. This option defaults to 127.0.0.1. Multiple addresses can be specified by using an array reference. This option is used for both events where auto_run is set to 0 and for manually-triggered events. __PACKAGE__->config->{scheduler}->{hosts_allow} = '192.168.1.1'; __PACKAGE__->config->{scheduler}->{hosts_allow} = [ '127.0.0.1', '192.168.1.1' ]; =head1 SCHEDULING =head2 AUTOMATED EVENTS Events are scheduled by calling the class method C. MyApp->schedule( at => '0 * * * *', event => '/cron/remove_sessions', ); package MyApp::Controller::Cron; sub remove_sessions : Private { my ( $self, $c ) = @_; $c->delete_expired_sessions; } =head3 at The time to run an event is specified using L-style syntax. 5 0 * * * # 5 minutes after midnight, every day 15 14 1 * * # run at 2:15pm on the first of every month 0 22 * * 1-5 # run at 10 pm on weekdays 5 4 * * sun # run at 4:05am every Sunday From crontab(5): field allowed values ----- -------------- minute 0-59 hour 0-23 day of month 1-31 month 0-12 (or names, see below) day of week 0-7 (0 or 7 is Sun, or use names) Instead of the first five fields, one of seven special strings may appear: string meaning ------ ------- @yearly Run once a year, "0 0 1 1 *". @annually (same as @yearly) @monthly Run once a month, "0 0 1 * *". @weekly Run once a week, "0 0 * * 0". @daily Run once a day, "0 0 * * *". @midnight (same as @daily) @hourly Run once an hour, "0 * * * *". =head3 event The event to run at the specified time can be either a Catalyst private action path or a coderef. Both types of event methods will receive the $c object from the current request, but you must not rely on any request-specific information present in $c as it will be from a random user request at or near the event's specified run time. Important: Methods used for events should be marked C so that they can not be executed via the browser. =head3 auto_run The auto_run parameter specifies when the event is allowed to be executed. By default this option is set to 1, so the event will be executed during the first request that matches the specified time in C. If set to 0, the event will only run when a request is made by a user from an authorized address. The purpose of this option is to allow long-running tasks to execute only for certain users. MyApp->schedule( at => '0 0 * * *', event => '/cron/rebuild_search_index', auto_run => 0, ); package MyApp::Controller::Cron; sub rebuild_search_index : Private { my ( $self, $c ) = @_; # rebuild the search index, this may take a long time } Now, the search index will only be rebuilt when a request is made from a user whose IP address matches the list in the C config option. To run this event, you probably want to ping the app from a cron job. 0 0 * * * wget -q http://www.myapp.com/ =head2 MANUAL EVENTS To create an event that does not run on a set schedule and must be manually triggered, you can specify the C option instead of C. __PACKAGE__->schedule( trigger => 'send_email', event => '/events/send_email', ); The event may then be triggered by a standard web request from an authorized user. The trigger to run is specified by using a special GET parameter, 'schedule_trigger'; the path requested does not matter. http://www.myapp.com/?schedule_trigger=send_email By default, manual events may only be triggered by requests made from localhost (127.0.0.1). To allow other addresses to run events, use the configuration option L. =head1 SCHEDULING USING A YAML FILE As an alternative to using the schedule() method, you may define scheduled events in an external YAML file. By default, the plugin looks for the existence of a file called C in your application's home directory. You can change the filename using the configuration option L. Modifications to this file will be re-read once per minute during the normal event checking process. Here's an example YAML configuration file with 4 events. Each event is denoted with a '-' character, followed by the same parameters used by the C method. Note that coderef events are not supported by the YAML file. --- - at: '* * * * *' event: /cron/delete_sessions - event: /cron/send_email trigger: send_email - at: '@hourly' event: /cron/hourly - at: 0 0 * * * auto_run: 0 event: /cron/rebuild_search_index =head1 SECURITY All events are run inside of an eval container. This protects the user from receiving any error messages or page crashes if an event fails to run properly. All event errors are logged, even if logging is disabled. =head1 PLUGIN SUPPORT Other plugins may register scheduled events if they need to perform periodic maintenance. Plugin authors, B if you do this! Events should be registered from a plugin's C method. sub setup { my $c = shift; $c->maybe::next::method(@_); if ( $c->can('schedule') ) { $c->schedule( at => '0 * * * *', event => \&cleanup, ); } } =head1 CAVEATS The time at which an event will run is determined completely by the requests made to the application. Apps with heavy traffic may have events run at very close to the correct time, whereas apps with low levels of traffic may see events running much later than scheduled. If this is a problem, you can use a real cron entry that simply hits your application at the desired time. 0 * * * * wget -q http://www.myapp.com/ Events which consume a lot of time will slow the request processing for the user who triggers the event. For these types of events, you should use auto_run => 0 or manual event triggering. =head1 PERFORMANCE The plugin only checks once per minute if any events need to be run, so the overhead on each request is minimal. On my test server, the difference between running with Scheduler and without was only around 0.02% (0.004 seconds). Of course, when a scheduled event runs, performance will depend on what's being run in the event. =head1 METHODS =head2 schedule Schedule is a class method for adding scheduled events. See the L<"/SCHEDULING"> section for more information. =head2 scheduler_state The current state of all scheduled events is available in an easy-to-use format by calling $c->scheduler_state. You can use this data to build an admin view into the scheduling engine, for example. This same data is also displayed on the Catalyst debug screen. This method returns an array reference containing a hash reference for each event. [ { 'last_run' => '2005-12-29 16:29:33 EST', 'auto_run' => 1, 'last_output' => 1, 'at' => '0 0 * * *', 'next_run' => '2005-12-30 00:00:00 EST', 'event' => '/cron/session_cleanup' }, { 'auto_run' => 1, 'at' => '0 0 * * *', 'next_run' => '2005-12-30 00:00:00 EST', 'event' => '/cron/build_rss' }, ] =head1 INTERNAL METHODS The following methods are extended by this plugin. =over 4 =item dispatch The main scheduling logic takes place during the dispatch phase. =item dump_these On the Catalyst debug screen, all scheduled events are displayed along with the next time they will be executed. =item setup =back =head1 SEE ALSO L =head1 AUTHOR Andy Grundman, =head1 COPYRIGHT This program is free software, you can redistribute it and/or modify it under the same terms as Perl itself. =cut Catalyst-Plugin-Scheduler-0.10/t/0000755000175000017500000000000011367557076016142 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/t/04critic.t0000644000175000017500000000075111364322205017730 0ustar bricasbricasuse strict; use warnings; use File::Spec; use FindBin (); use Test::More; if ( !-e "$FindBin::Bin/../MANIFEST.SKIP" ) { plan skip_all => 'Critic test only for developers.'; } else { eval { require Test::Perl::Critic }; if ( $@ ) { plan tests => 1; fail( 'You must install Test::Perl::Critic to run 04critic.t' ); exit; } } my $rcfile = File::Spec->catfile( 't', '04critic.rc' ); Test::Perl::Critic->import( -profile => $rcfile ); all_critic_ok();Catalyst-Plugin-Scheduler-0.10/t/07plugin.t0000644000175000017500000000125111364322205017750 0ustar bricasbricas#!perl use strict; use warnings; use FindBin; use lib "$FindBin::Bin/lib"; use Test::More; use Storable qw/lock_store lock_retrieve/; plan tests => 3; use Catalyst::Test 'PluginTestApp'; our $STATE = "$FindBin::Bin/lib/TestApp/scheduler.state"; # hack the last event check to make all events execute immediately my $state = { last_check => 0 }; lock_store $state, $STATE; # test that the plugin event executes { ok( my $res = request('http://localhost/'), 'request ok' ); is( $res->content, 'default', 'response ok' ); is( -e "$FindBin::Bin/lib/TestApp/plugin_test.log", 1, 'every_minute executed ok' ); unlink "$FindBin::Bin/lib/TestApp/plugin_test.log"; } Catalyst-Plugin-Scheduler-0.10/t/03podcoverage.t0000644000175000017500000000032511364322205020745 0ustar bricasbricasuse Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@; plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; all_pod_coverage_ok(); Catalyst-Plugin-Scheduler-0.10/t/04critic.rc0000644000175000017500000000015311364322205020065 0ustar bricasbricasinclude = CodeLayout::ProhibitHardTabs only = 1 [CodeLayout::ProhibitHardTabs] allow_leading_tabs = 0Catalyst-Plugin-Scheduler-0.10/t/09long.t0000644000175000017500000000200111364322205017405 0ustar bricasbricas#!perl use strict; use warnings; use FindBin; use lib "$FindBin::Bin/lib"; use Test::More; plan skip_all => 'set TEST_LONG to enable this test. It takes about 1 minute to run.' unless $ENV{TEST_LONG}; plan tests => 6; use Catalyst::Test 'TestApp'; TestApp->schedule( at => '* * * * *', event => '/cron/every_minute', ); # test that the event does not execute when we first start up { ok( my $res = request('http://localhost/'), 'request ok' ); is( $res->content, 'default', 'response ok' ); is( -e "$FindBin::Bin/lib/TestApp/every_minute.log", undef, 'every_minute did not execute, ok' ); unlink "$FindBin::Bin/lib/TestApp/every_minute.log"; } # wait for a minute sleep 61; # test that the event does execute { ok( my $res = request('http://localhost/'), 'request ok' ); is( $res->content, 'default', 'response ok' ); is( -e "$FindBin::Bin/lib/TestApp/every_minute.log", 1, 'every_minute executed ok' ); unlink "$FindBin::Bin/lib/TestApp/every_minute.log"; } Catalyst-Plugin-Scheduler-0.10/t/04schedule.t0000644000175000017500000000471311364322205020251 0ustar bricasbricas#!perl use strict; use warnings; use FindBin; use lib "$FindBin::Bin/lib"; use Test::More; use Storable qw/lock_store lock_retrieve/; plan tests => 10; use Catalyst::Test 'TestApp'; our $STATE = "$FindBin::Bin/lib/TestApp/scheduler.state"; TestApp->schedule( at => '* * * * *', event => '/cron/every_minute', ); TestApp->schedule( at => '@hourly', event => \&every_hour, ); # events with errors to test the error handling TestApp->schedule( at => '*/2 * * * *', event => '/cron/test_errors', ); TestApp->schedule( at => '0 * * * *', event => \&broken_event, ); # hack the last event check to make all events execute immediately my $state = { last_check => 0 }; lock_store $state, $STATE; # test that all events execute, and that the error test doesn't break the app { open STDERR, '>/dev/null'; ok( my $res = request('http://localhost/'), 'request ok' ); is( $res->content, 'default', 'response ok' ); is( -e "$FindBin::Bin/lib/TestApp/every_minute.log", 1, 'every_minute executed ok' ); unlink "$FindBin::Bin/lib/TestApp/every_minute.log"; is( -e "$FindBin::Bin/lib/TestApp/every_hour.log", 1, 'every_hour executed ok' ); unlink "$FindBin::Bin/lib/TestApp/every_hour.log"; } # run again, the events should not execute { ok( my $res = request('http://localhost/'), 'request ok' ); is( -e "$FindBin::Bin/lib/TestApp/every_minute.log", undef, 'every_minute did not execute, ok' ); unlink "$FindBin::Bin/lib/TestApp/every_minute.log"; is( -e "$FindBin::Bin/lib/TestApp/every_hour.log", undef, 'every_hour did not execute, ok' ); unlink "$FindBin::Bin/lib/TestApp/every_hour.log"; } # jump back in time by 2 hours, make sure both events run { my $state = lock_retrieve $STATE; $state->{last_check} -= 60 * 120; lock_store $state, $STATE; ok( my $res = request('http://localhost/'), 'request ok' ); is( -e "$FindBin::Bin/lib/TestApp/every_minute.log", 1, 'every_minute executed ok' ); unlink "$FindBin::Bin/lib/TestApp/every_minute.log"; is( -e "$FindBin::Bin/lib/TestApp/every_hour.log", 1, 'every_hour executed ok' ); unlink "$FindBin::Bin/lib/TestApp/every_hour.log"; } ### sub every_hour { my $c = shift; # write out a file so the test knows we did something my $fh = IO::File->new( $c->path_to( 'every_hour.log' ), 'w' ) or die "Unable to write log file: $!"; close $fh; } sub broken_event { my $c = shift; die 'oops'; } Catalyst-Plugin-Scheduler-0.10/t/08yaml.t0000644000175000017500000000215111364322205017415 0ustar bricasbricas#!perl use strict; use warnings; use FindBin; use lib "$FindBin::Bin/lib"; use Test::More; use Storable qw/lock_store lock_retrieve/; plan tests => 6; use Catalyst::Test 'TestApp'; our $STATE = "$FindBin::Bin/lib/TestApp/scheduler.state"; # hack the last event check to make all events execute immediately my $state = { last_check => 0 }; lock_store $state, $STATE; # configure a yaml file TestApp->config->{scheduler}->{yaml_file} = "$FindBin::Bin/lib/TestApp/test.yml"; # test that the plugin event executes { ok( my $res = request('http://localhost/'), 'request ok' ); is( $res->content, 'default', 'response ok' ); is( -e "$FindBin::Bin/lib/TestApp/every_minute.log", 1, 'every_minute executed ok' ); unlink "$FindBin::Bin/lib/TestApp/every_minute.log"; } # test that a YAML trigger works { ok( my $res = request('http://localhost/?schedule_trigger=some_long_trigger_name'), 'request ok' ); is( $res->content, 'default', 'response ok' ); is( -e "$FindBin::Bin/lib/TestApp/every_minute.log", 1, 'every_minute executed ok' ); unlink "$FindBin::Bin/lib/TestApp/every_minute.log"; } Catalyst-Plugin-Scheduler-0.10/t/01use.t0000644000175000017500000000010311364322205017233 0ustar bricasbricasuse Test::More tests => 1; use_ok('Catalyst::Plugin::Scheduler'); Catalyst-Plugin-Scheduler-0.10/t/lib/0000755000175000017500000000000011367557076016710 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/t/lib/PluginTestApp/0000755000175000017500000000000011367557076021447 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/t/lib/PluginTestApp/Controller/0000755000175000017500000000000011367557076023572 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/t/lib/PluginTestApp/Controller/Root.pm0000644000175000017500000000036111364323046025034 0ustar bricasbricaspackage PluginTestApp::Controller::Root; use strict; use warnings; use base 'Catalyst::Controller'; __PACKAGE__->config->{ namespace } = ''; sub default : Private { my ( $self, $c ) = @_; $c->res->output( 'default' ); } 1; Catalyst-Plugin-Scheduler-0.10/t/lib/PluginTestApp.pm0000644000175000017500000000052211364323055021765 0ustar bricasbricaspackage PluginTestApp; use strict; use warnings; use Catalyst; our $VERSION = '0.01'; # reuse the other TestApp's home directory, so we have a place to write # the scheduler.state file PluginTestApp->config( name => 'PluginTestApp', home => "$FindBin::Bin/lib/TestApp" ); PluginTestApp->setup( qw/Scheduler PluginTest/ ); 1; Catalyst-Plugin-Scheduler-0.10/t/lib/TestApp/0000755000175000017500000000000011367557076020270 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/t/lib/TestApp/Controller/0000755000175000017500000000000011367557076022413 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/t/lib/TestApp/Controller/Root.pm0000644000175000017500000000035311364323064023656 0ustar bricasbricaspackage TestApp::Controller::Root; use strict; use warnings; use base 'Catalyst::Controller'; __PACKAGE__->config->{ namespace } = ''; sub default : Private { my ( $self, $c ) = @_; $c->res->output( 'default' ); } 1; Catalyst-Plugin-Scheduler-0.10/t/lib/TestApp/Controller/Cron.pm0000644000175000017500000000103711364322205023630 0ustar bricasbricaspackage TestApp::Controller::Cron; use strict; use warnings; use base 'Catalyst::Controller'; use IO::File; sub every_minute : Private { my ( $self, $c ) = @_; # write out a file so the test knows we did something my $fh = IO::File->new( $c->path_to( 'every_minute.log' ), 'w' ) or die "Unable to write log file: $!"; close $fh; # this tests that events cannot change the output $c->res->output( 'every_minute' ); } sub test_errors : Private { my ( $self, $c ) = @_; die 'oops'; } 1; Catalyst-Plugin-Scheduler-0.10/t/lib/TestApp/test.yml0000644000175000017500000000012411364322205021744 0ustar bricasbricas--- - at: '* * * * *' event: /cron/every_minute trigger: some_long_trigger_name Catalyst-Plugin-Scheduler-0.10/t/lib/TestApp.pm0000644000175000017500000000024411364322455020612 0ustar bricasbricaspackage TestApp; use strict; use warnings; use Catalyst; our $VERSION = '0.01'; TestApp->config( name => 'TestApp', ); TestApp->setup( qw/Scheduler/ ); 1; Catalyst-Plugin-Scheduler-0.10/t/lib/Catalyst/0000755000175000017500000000000011367557076020474 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/t/lib/Catalyst/Plugin/0000755000175000017500000000000011367557076021732 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/t/lib/Catalyst/Plugin/PluginTest.pm0000644000175000017500000000106011364322205024340 0ustar bricasbricaspackage Catalyst::Plugin::PluginTest; use strict; use warnings; use MRO::Compat; Class::C3::initialize(); sub setup { my $c = shift; $c->maybe::next::method(@_); if ( $c->can('schedule') ) { $c->schedule( at => '* * * * *', event => \&plugin_test, ); } } sub plugin_test { my $c = shift; # write out a file so the test knows we did something my $fh = IO::File->new( $c->path_to( 'plugin_test.log' ), 'w' ) or die "Unable to write log file: $!"; close $fh; } 1; Catalyst-Plugin-Scheduler-0.10/t/02pod.t0000644000175000017500000000027611364322205017235 0ustar bricasbricasuse Test::More; eval "use Test::Pod 1.14"; plan skip_all => 'Test::Pod 1.14 required' if $@; plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; all_pod_files_ok(); Catalyst-Plugin-Scheduler-0.10/t/06trigger.t0000644000175000017500000000224411364322205020117 0ustar bricasbricas#!perl use strict; use warnings; use FindBin; use lib "$FindBin::Bin/lib"; use Test::More; use Storable qw/lock_store lock_retrieve/; plan tests => 6; use Catalyst::Test 'TestApp'; our $STATE = "$FindBin::Bin/lib/TestApp/scheduler.state"; TestApp->schedule( trigger => 'every_minute', event => '/cron/every_minute', ); # disallow localhost TestApp->config->{scheduler}->{hosts_allow} = '1.2.3.4'; # test that the event does not execute { ok( my $res = request('http://localhost/?schedule_trigger=every_minute'), 'request ok' ); is( $res->content, 'default', 'response ok' ); is( -e "$FindBin::Bin/lib/TestApp/every_minute.log", undef, 'every_minute did not execute, ok' ); unlink "$FindBin::Bin/lib/TestApp/every_minute.log"; } # allow localhost TestApp->config->{scheduler}->{hosts_allow} = [ '1.2.3.4', '127.0.0.1' ]; # test that the event does execute { ok( my $res = request('http://localhost/?schedule_trigger=every_minute'), 'request ok' ); is( $res->content, 'default', 'response ok' ); is( -e "$FindBin::Bin/lib/TestApp/every_minute.log", 1, 'every_minute executed ok' ); unlink "$FindBin::Bin/lib/TestApp/every_minute.log"; } Catalyst-Plugin-Scheduler-0.10/t/05auto_run.t0000644000175000017500000000262011364322205020305 0ustar bricasbricas#!perl use strict; use warnings; use FindBin; use lib "$FindBin::Bin/lib"; use Test::More; use Storable qw/lock_store lock_retrieve/; plan tests => 6; use Catalyst::Test 'TestApp'; our $STATE = "$FindBin::Bin/lib/TestApp/scheduler.state"; TestApp->schedule( at => '* * * * *', event => '/cron/every_minute', auto_run => 0, ); # hack the last event check to make all events execute immediately my $state = { last_check => 0 }; lock_store $state, $STATE; # disallow localhost TestApp->config->{scheduler}->{hosts_allow} = '1.2.3.4'; # test that the event does not execute { ok( my $res = request('http://localhost/'), 'request ok' ); is( $res->content, 'default', 'response ok' ); is( -e "$FindBin::Bin/lib/TestApp/every_minute.log", undef, 'every_minute did not execute, ok' ); unlink "$FindBin::Bin/lib/TestApp/every_minute.log"; } # hack the last event check to make all events execute immediately $state = lock_retrieve $STATE; $state->{last_check} = 0; lock_store $state, $STATE; # allow localhost TestApp->config->{scheduler}->{hosts_allow} = [ '1.2.3.4', '127.0.0.1' ]; # test that the event does execute { ok( my $res = request('http://localhost/'), 'request ok' ); is( $res->content, 'default', 'response ok' ); is( -e "$FindBin::Bin/lib/TestApp/every_minute.log", 1, 'every_minute executed ok' ); unlink "$FindBin::Bin/lib/TestApp/every_minute.log"; } Catalyst-Plugin-Scheduler-0.10/inc/0000755000175000017500000000000011367557076016450 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/inc/Module/0000755000175000017500000000000011367557076017675 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/inc/Module/Install/0000755000175000017500000000000011367557076021303 5ustar bricasbricasCatalyst-Plugin-Scheduler-0.10/inc/Module/Install/Base.pm0000644000175000017500000000176611367557041022515 0ustar bricasbricas#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.95'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 154 Catalyst-Plugin-Scheduler-0.10/inc/Module/Install/Metadata.pm0000644000175000017500000004100011367557041023344 0ustar bricasbricas#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:licen[cs]e|licensing)\b.*?) (=head \d.*|=cut.*|)\z /ixms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:copyrights?|legal)\b.*?) (=head \d.*|=cut.*|)\z /ixms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( 'under the same (?:terms|license) as (?:perl|the perl programming language)' => 'perl', 1, 'under the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( \Qhttp://rt.cpan.org/\E[^>]+| \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Catalyst-Plugin-Scheduler-0.10/inc/Module/Install/Win32.pm0000644000175000017500000000340311367557041022533 0ustar bricasbricas#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Catalyst-Plugin-Scheduler-0.10/inc/Module/Install/Makefile.pm0000644000175000017500000002622011367557041023350 0ustar bricasbricas#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); if ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { File::Find::find( \&_wanted_t, 'xt' ); } $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $build_prereq->{$file}; #Delete from build prereqs only } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 531 Catalyst-Plugin-Scheduler-0.10/inc/Module/Install/WriteAll.pm0000644000175000017500000000237711367557041023365 0ustar bricasbricas#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.95';; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Catalyst-Plugin-Scheduler-0.10/inc/Module/Install/Can.pm0000644000175000017500000000333311367557041022334 0ustar bricasbricas#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 Catalyst-Plugin-Scheduler-0.10/inc/Module/Install/Fetch.pm0000644000175000017500000000462711367557041022673 0ustar bricasbricas#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.95'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Catalyst-Plugin-Scheduler-0.10/inc/Module/Install.pm0000644000175000017500000002637111367557041021642 0ustar bricasbricas#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use FindBin; use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '0.95'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2010 Adam Kennedy. Catalyst-Plugin-Scheduler-0.10/MANIFEST0000644000175000017500000000123711367545617017031 0ustar bricasbricasChanges inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Catalyst/Plugin/Scheduler.pm Makefile.PL MANIFEST This list of files META.yml README t/01use.t t/02pod.t t/03podcoverage.t t/04critic.rc t/04critic.t t/04schedule.t t/05auto_run.t t/06trigger.t t/07plugin.t t/08yaml.t t/09long.t t/lib/Catalyst/Plugin/PluginTest.pm t/lib/PluginTestApp.pm t/lib/PluginTestApp/Controller/Root.pm t/lib/TestApp.pm t/lib/TestApp/Controller/Cron.pm t/lib/TestApp/Controller/Root.pm t/lib/TestApp/test.yml