Changes:

[catagits/Catalyst-Plugin-Scheduler.git] / lib / Catalyst / Plugin / Scheduler / Event.pm

package Catalyst::Plugin::Scheduler::Event;

use strict;
use warnings;
use DateTime;
use Storable    qw/lock_store lock_retrieve/;
use base        qw[Class::Accessor::Fast Class::Data::Inheritable];

=head1 NAME

Catalyst::Plugin::Scheduler::Event - Event objects for the scheduler

=head1 SYNOPSIS

    ### retrieve all events    
    @events = MyApp->scheduler->events;

    ### access event information    
    print $event->at;
    print $event->output;
    print $event->error;
    
    ### run an event explicitly
    $event->run or die $event->error;
    
    MyApp->scheduler->last_check_time;
    MyApp->scheduler->last_check_time_as_string;

=cut

=head1 ACCESSORS 

These are accessors on the event objects that give you information on or
let you change the behaviour of the scheduled event objects.

All these accessors can be provided as arguments to the C<new> function
directly, or via the C<< MyApp->schedule >> method indirectly.

=head2 $event->at

Time the event should be triggered, in C<crontab> notation.

If empty, $event->trigger should be filled.

=head2 $event->trigger 

C<GET> parameter that will trigger this event. 

If empty, $event->at should be filled.

=head2 $event->auto_run

Boolean indicating if the event should be automatically run at the end
of a dispatch cycle when the event is due, or not.

See C<Catalyst::Plugin::Scheduler> documentation on method C<schedule>
for an example of C<auto_run> use.
    
=head2 $event->event

The event that will be triggered by this event object. This would be
either a C<CODE> ref, or an absolute path in your application.
    
=head2 $event->label

A pretty print name for your event. Defaults to the C<trigger> or
C<event> accessors if not explicitly defined.

=head2 $event->priority

Pending events are executed in order of priority, where the highest
priority comes first. The priority defaults to C<0> but can be set 
explicitly when scheduling an event to make it run earlier or later
in the dispatch cycle.

=head2 $event->active

Marks whether the event is active or not. Defaults to C<1> but you can
(temporarily) disable an event by setting active to C<0>. Inactive 
events are never present in the C<< MyApp->scheduler->list_pending_events >>
call.

=head2 $event->scheduled_by

A text string containing details on the code that scheduled this event.
Useful for debugging purposes or for accountability.

=cut

my $Base        = 'Catalyst::Plugin::Scheduler::Base';
my @EventAcc    = qw[output error last_run running];
my @ExtraAcc    = qw[
    next_run 
    next_run_as_dt 
    next_run_as_string 
    last_run_as_string
];
my @Acc         = qw[
    auto_run 
    at  
    event 
    trigger 
    set
    priority
    label
    active
    scheduled_by
];



__PACKAGE__->mk_accessors( @Acc );
__PACKAGE__->mk_classdata( _event_state => {} );

sub ls_accessors { return ( @Acc, @EventAcc, @ExtraAcc ) };

=head1 METHODS

=head2 $event = Catalyst::Plugin::Scheduler::Event->new( ... );

Creates a new C<Event> object from it's arguments. All possible arguments
and their meaning are listed in the C<ACCESSORS> section above.

C<new> should usually not be called directly, but via the interface
provided via the scheduler object:

    MyApp->scheduler->schedule(
        at      => ...
        event   => ...
        ...
    );        

=cut

sub new {
    my $self = shift;
    my %args = @_;
    
    my $obj  = $self->SUPER::new({
                    active          => 1,
                    prioirity       => 0,
                    scheduled_by    => $Base->_caller_string,
                    %args 
                });

    ### make sure it has a name
    $obj->label( $obj->trigger || $obj->event ) unless $obj->label;

    return $obj;
}

=head2 $str = $event->output

Output of the event the B<last time> it was run. This is the return
value of the executed event.

=head2 $str = $event->error

Fatal errors encountered the B<last time> this event was run.

If $event->error returns a string, you can be sure that the event
did not complete succesfully.

=head2 $pid = $event->running

Returns the pid of the process that is running the event currently.

If a pid is returned, the event is running B<right now>. If the
pid is different from your pid, another process is running the event.

=head2 $time = $event->last_run

The output of C<time()> the last time the event was run.

=cut

### we want these items available via the event objects,
### however, they need to be stored in the state file.. so we
### are basically passing thru from here to the state file..
### this provides a nicer api, but also means our state is guaranteed
### to be correct, even if the YAML file is being reloaded or 
### schedules are being altered
for my $acc ( @EventAcc ) {
    no strict 'refs';

    my $priv_method = "_$acc";    
    *$acc           = sub { shift->$priv_method };
    *$priv_method   = sub {
        my $self    = shift;
        
        ### make sure the event state is initialized
        $self->_get_event_state;
        
        ### access like this, so we're sure we're using the right hashref
        ### to write into, even if it's not defined yet
        if( @_ ) {
            $self->_event_state->{'events'}->{ $self->event }->{$acc} = $_[0];
            $self->_save_event_state;
        }            

        return $self->_event_state->{'events'}->{ $self->event }->{$acc};
    }
}    

=head2 $str = $event->last_run_as_string

A pretty-printable version of the C<last_run>
    
=cut

sub last_run_as_string {
    my $self = shift;

    if( my $last_run = $self->last_run ) {        

        my $dt = DateTime->from_epoch(
                    epoch     => $last_run,
                    time_zone => $Base->_config('time_zone'),
                 );
        return join ' ', $dt->ymd, $dt->hms, $dt->time_zone_short_name;
    }
    
    return;
}

=head2 $time = $event->next_run

The output of C<time()> the next time the event is due to be run.

=cut

sub next_run {
    my $self = shift;
    my $dt   = $self->next_run_as_dt or return;
    return $dt->epoch;
}

=head2 $str = $event->next_run_as_string

A pretty-printable version of the C<next_run>

=cut

sub next_run_as_string {
    my $self = shift;
 
    if( $self->set ) {
        my $next = $self->next_run_as_dt;                
        return join ' ', $next->ymd, $next->hms, $next->time_zone_short_name;
    }
    
    return;
}

=head2 $dt = $event->next_run_as_dt

Returns the time that this event is due to be run as a C<DateTime> object

=cut

sub next_run_as_dt {
    my $self = shift;

    if( $self->set ) {
        my $dt = DateTime->from_epoch(
                    epoch     => $self->_last_check_time,
                    time_zone => $Base->_config('time_zone'),
                 );
        return $self->set->next( $dt );                 
    }        
    return;
}

=head2 $bool = $event->run( ... )

Run the event. Any arguments passed to C<run> will be passed along to
the event that is being run. If C<run> returns true, running the event
completed without fatal errors. If C<run> returns false, a fatal error
was encountered while running the event.

You can inspect the following accessors after running the event for
output and diagnostics:

    $event->output;     # any output returned from the event
    $event->error;      # any fatal errors caught while running the event
    
B<NOTE> that you can only C<run> an event during a C<Catalyst> action,
as the events need access to the C<Catalyst> object. In short, this means
that your C<$c> needs to be an object rather than a class name. If C<$c>
is not an object, C<run> will throw an exception.

=cut

sub run {
    my $self = shift;
    my $c    = $Base->_app;
    
    Catalyst::Exception->throw(
        message => "Can not run scheduled events -- $c is not an object" 
    ) unless ref $c;
    
    ### XXX mark running
    # make sure we're the only process running this event
    ### XXX is 'return' the right thing to do? --kane
    ### mark_runnign will return true if we are the ones (exclusively)
    ### running this process.
    return unless $self->_mark_running;
    
    ### reset any output/errors
    $self->_output( undef );
    $self->_error(  undef );
    
    my $event_name = $self->label;
    $c->log->debug("Scheduler: Executing $event_name")
        if $Base->_config('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};

        ### XXX events can not set output without RETURNING
        ### their output... is this good? --kane
        $output = ref $self->event eq 'CODE'
            ? $self->event->($c, @_ )
            : $c->forward( $self->event, [@_] );
    };

    my @errors = @{ $c->{error} };
    push @errors, $@ if $@;

    if (@errors) {
        ### we check for this error in the tests -- if you alter
        ### it, tests will starting spewing errors
        $c->log->error(
            'Scheduler: Error executing ' . "$event_name: $_" 
        ) for @errors;
        
        my $error = join '; ', @errors;
        
        $self->_error( $error );
        $output .= $error; 
    }

    $self->_output( $output );

    $self->_mark_finished( );

    return if @errors;
    return 1;
}

sub _mark_running { 
    my $self = shift;

    $self->_get_event_state();

    return if $self->running;

    # this is a 2-step process to prevent race conditions
    # 1. write the state file with our PID
    $self->_running( $$ );
    $self->_save_event_state();

    # 2. re-read the state file and make sure it's got the same PID
    $self->_get_event_state();
    if ( $self->running == $$ ) {
        return 1;
    }

    return;
}

sub _mark_finished { 
    my $self = shift;

    $self->_running(   0       );
    $self->_last_run(  time    );
    
    $self->_save_event_state();

    return 1;
}

=head1 CLASS METHODS

=head2 $time = MyApp->scheduler->last_check_time

Returns the C<time()> the last check was made for pending events from
the dispatcher.

=cut

### dont pass arguments, so it becomes read only
sub last_check_time {
    my $self = shift;
    return $self->_last_check_time;
}    

=head2 $str = MyApp->scheduler->last_check_time_as_string

Returns a pretty-printable version of C<last_check_time>.

=cut

sub last_check_time_as_string {
    my $self = shift;

    if( my $last = $self->last_check_time ) {        

        my $dt = DateTime->from_epoch(
                    epoch     => $last,
                    time_zone => $Base->_config('time_zone'),
                 );
        return join ' ', $dt->ymd, $dt->hms, $dt->time_zone_short_name;
    }
    
    return;
}

sub _last_check_time {
    my $self = shift;

    $self->_get_event_state();

    if( @_ ) {
        $self->_event_state->{'last_check'} = $_[0];
        $self->_save_event_state;
    }
    
    return $self->_event_state->{'last_check'};
}    

{   my $key = 'state_file';

    # get the state from the state file
    sub _get_event_state {
        my $self    = shift;
        my $file    = $Base->_config($key);
        
        if ( -e $file ) {
            $self->_event_state( lock_retrieve $file );
        
        } else {
            # initialize the state file
            $self->_event_state(
                {   last_check  => time,
                    events      => {},
                    yaml_mtime  => {},
                }
            );
            $self->_save_event_state();
        }
    }
    
    # update the state file on disk
    sub _save_event_state {
        my $self    = shift;
        lock_store( $self->_event_state, $Base->_config($key) );
    }
}

1;

__END__

=head1 SEE ALSO

C<Catalyst::Plugin::Scheduler>, C<Catalyst::Plugin::Scheduler::Base>,

=cut