This file is indexed.

/usr/share/perl5/Magpie/Event.pm is in libmagpie-perl 1.140280-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
package Magpie::Event;
{
  $Magpie::Event::VERSION = '1.140280';
}
# ABSTRACT: Core Event Role Shared By All Magpie Classes
use Moose::Role;

with qw( Magpie::Event::Symbol Magpie::Types );

use Magpie::Constants;
use Magpie::SymbolTable;
use Magpie::Util;
use Class::Load;
use Plack::Request;
use Plack::Response;
use Try::Tiny;

BEGIN { $SIG{__DIE__} = sub { Carp::confess(@_) } }


has plack_request => (
    is          => 'rw',
    isa         => 'Plack::Request',
    default     => sub { Plack::Request->new({}); },
    reader      => 'request',
);

has plack_response => (
    is          => 'rw',
    isa         => 'Plack::Response',
    default     => sub { Plack::Response->new(200); },
    reader      => 'response',
    predicate   => 'has_response',
    trigger     => sub { shift->response_changed(1) },
);

has response_changed => (
    is          => 'rw',
    isa         => 'Bool',
    default     => 0,
);

has parent_handler => (
    is          => 'rw',
    predicate   => 'has_parent_handler',
    weak_ref    => 1,
);

has error => (
    is          => 'rw',
    isa         => 'SmartHTTPError',
    coerce      => 1,
    predicate   => 'has_error',
    writer      => 'set_error',
    clearer     => 'clear_error',
);

has handlers => (
    traits      => ['Array'],
    is          => 'rw',
    isa         => 'ArrayRef[ArrayRef]',
    default     => sub { [] },
    handles     => {
        push_handlers      => 'push',
        pop_handlers       => 'pop',
        shift_handlers     => 'shift',
        unshift_handlers   => 'unshift',
        clear_handlers     => 'clear',
    },

);

has event_queue => (
    traits  => ['Array'],
    is      => 'rw',
    isa     => 'ArrayRef[Str]',
    default => sub { [] },
    handles => {
        push_queue      => 'push',
        pop_queue       => 'pop',
        shift_queue     => 'shift',
        unshift_queue   => 'unshift',
        free_queue      => 'clear',
    },
);

has registered_handlers => (
    traits    => ['Hash'],
    is        => 'rw',
    isa       => 'HashRef[Object]',
    default   => sub { {} },
    handles   => {
        register_handler    => 'set',
        fetch_handler       => 'get',
        unregister_handler  => 'delete',
    },
);

has current_handler => (
    is        => 'rw',
    predicate => 'has_current_handler',
);

has current_handler_args => (
    is        => 'rw',
    predicate => 'has_current_handler_args',
);

sub BUILD{
    my $self = shift;
    $self->init_common_symbols();
    $self->init_symbols() if $self->can('init_symbols');
};

# Class methods
our %registered_events = ();

__PACKAGE__->register_events(qw( next_in_pipe load_handler run_handler ) );

sub register_events {
    my $pkg = shift;
    if ( scalar @_ ) {
        $registered_events{$pkg} ||= [];
        push @{ $registered_events{$pkg} }, @_;
    }
    return $pkg->registered_events;
}

sub registered_events {
    my $thing = shift;
    my $pkg = blessed( $thing ) ? $thing->meta->name : $thing;
    my $ref = $registered_events{$pkg} || [];
    return @{ $ref };
}

#-------------------------------------------------------------------------------
# stop_application() stops everything dead in its tracks, potentially
# calling itself for all parent handlers as well.
# DO NOT confuse this with the harmless end_application() which only adds
# a hook for doing clean-up, etc.
#-------------------------------------------------------------------------------
sub stop_application  {
    my $self = shift;
    my $ctxt = shift;

    $self->free_queue();
    $self->clear_handlers();
    if ($self->has_parent_handler) {
        if ($self->isa('Magpie::Resource')) {
            $self->parent_handler->resource($self) if $self->parent_handler->can('resource');
        }
        else {
            $self->parent_handler->resource($self->resource) if $self->can('resource') && $self->parent_handler->can('resource');
        }
        $self->parent_handler->stop_application;
    }
}

#-------------------------------------------------------------------------------
# next_in_pipe
# Event queue method for transitioning from one handler to the next.
#-------------------------------------------------------------------------------
sub next_in_pipe {
    my $self = shift;
    my $ctxt = shift;

    my $tuple = $self->shift_handlers;
    if ( defined $tuple ) {
        $self->current_handler( $tuple->[0] );
        $self->current_handler_args( $tuple->[1] );
        $self->add_to_queue( 'load_handler' );
    }

    return OK;
}

#-------------------------------------------------------------------------------
# load_handler($context)
# Event queue method that checks to see if the currently selected handler
# class has been instantiated and registered in the loaded_handler table. If
# not, it loads that class, calls its constructor, sets the current Machine
# as the parent handler, and registers the handler in loaded_handler.
# It then adds the 'run_handler' method to the event queue to keep the pipline
# "moving" forward.
#-------------------------------------------------------------------------------
sub load_handler {
    my $self = shift;
    my $ctxt = shift;

    my $handler = $self->current_handler;
    my $handler_args = $self->current_handler_args || {};
    #warn "load: current handler: $handler " . $self->has_error ." \n";

    unless ( defined $self->fetch_handler( $handler ) ) {
        # we only make it here if the app class was passed
        # to the pipeline as the *name* of a class, rather
        # than a blessed instance
        my $new_handler;
        my $handler_error = undef;

        try {
            Class::Load::load_class( $handler );
        }
        catch {
            $handler_error = "Fatal error loading handler class '$handler': $_ \n";
            #$self->set_error({ status_code => 500, reason => $error });

        };

        if ( $handler_error ) {
            $self->set_error({ status_code => 500, reason => $handler_error });
            return HANDLER_ERROR;
        }

		if ( $handler->isa('Plack::Middleware') ) {
            Class::Load::load_class( 'Magpie::Transformer::Middleware' );
			my $munged_args = {
				middleware_args => $handler_args,
				middleware_class => $handler,
			};
			$handler = 'Magpie::Transformer::Middleware';
			$handler_args = $munged_args;
			$self->current_handler($handler);
			$self->current_handler_args($handler_args);
		}

        my $constructor = defined($handler_args->{traits}) ? 'new_with_traits' : 'new';

        try {
            $new_handler = $handler->$constructor(
                %{ $handler_args },
                parent_handler => $self,
                plack_request  => $self->plack_request,
                plack_response => $self->plack_response,
                breadboard     => ($self->has_parent_handler  ? $self->parent_handler->breadboard : $self->breadboard),
                resource       => $self->resource,
            ) || die "Error loading handler $!";

        }
        catch {
            $handler_error = "Fatal error during build for class '$handler': $_\n";
            #$self->set_error({ status_code => 500, reason => $error });
        };

        if ( $handler_error ) {
            $self->set_error({ status_code => 500, reason => $handler_error });
            return HANDLER_ERROR;
        }
        #return HANDLER_ERROR if $self->has_error;

        #$new_handler->parent_handler( $self );
        $self->register_handler( $handler => $new_handler );
    }

    if ($self->fetch_handler( $handler )) {
        $self->add_to_queue( "run_handler" );
    }

    return OK;
}

#-------------------------------------------------------------------------------
# run_handler($context)
# Run the instance of the currently selected handler class, passing in the
# application's context member. This method is called by the parent classes'
# event queue (see init_queue() in this class)
#-------------------------------------------------------------------------------
sub run_handler {
    my $self = shift;
    my $ctxt = shift;
    my $handler = $self->current_handler;
    my $handler_args = $self->current_handler_args || {};
    #warn "run handler: $handler\n";

    if ( my $h = $self->fetch_handler( $handler ) ) {
        # class may be loaded but params may be different
        my @attributes = $h->meta->get_all_attributes;
        foreach my $param (keys( %{$handler_args})) {
            foreach my $attr (@attributes) {
                next unless $attr->has_writer || $attr->has_accessor;
                my $method = $attr->get_write_method || $attr->accessor;
                next unless $param eq $method;
                $h->$method( $handler_args->{$param} );
            }
        }
        # "Running handler $handler \n";
        try {
            $h->run( $ctxt );
        }
        catch {
            my $error = "Fatal error running handler '$handler': $_";
            $self->set_error({ status_code => 500, reason => $_ });
        };

        # propagate errors up the handler stack
        if ( $h->has_error ) {
            $self->set_error( $h->error );
        }

        # remember, nesting.
        $self->plack_response( $h->plack_response );
        $self->breadboard( $h->breadboard );
        $self->add_to_queue( "next_in_pipe" );

    }
    else {
        return QUEUE_ERROR;
    }
    return OK;
}

#-------------------------------------------------------------------------------
# add_handler()
# Add a handler into the end of the event queue.
#-------------------------------------------------------------------------------
sub add_handler {
    my $self    = shift;
    my $handler = shift;
    my $args    = shift || {};
    if ( defined $handler && length $handler ) {
        $self->push_handlers([ $handler, $args ]);
    }
}

#-------------------------------------------------------------------------------
# add_next_handler()
# Add a handler into the front of the event queue.
#-------------------------------------------------------------------------------
sub add_next_handler {
    my $self    = shift;
    my $handler = shift;
    my $args    = shift || {};

    if ( defined $handler && length $handler ) {
        $self->unshift_handlers([$handler, $args]);
    }
}

#-------------------------------------------------------------------------------
# add_handlers( @list )
# Add a list of handlers to the event queue.
#-------------------------------------------------------------------------------
sub add_handlers {
    my $self = shift;
    my @handlers = @_;
    @handlers = Magpie::Util::make_tuples( @handlers );
    $self->push_handlers(@handlers);
}

#-------------------------------------------------------------------------------
# reset_handlers( @list )
# Replaces the current list of handlers with @list .
#-------------------------------------------------------------------------------
sub reset_handlers {
    my $self    = shift;
    my @handlers = @_;
    $self->clear_handlers;
    return $self->add_handlers( @handlers );
}

sub end_application {
    #warn "implement end_application already, will you?\n";
}

has server_status => (
    is          => 'rw',
    isa         => 'Int',
    default     => sub { 200 },
);

sub init_common_symbols {
    my $self = shift;
    $self->add_symbol_handler( next_in_pipe => \&next_in_pipe );
    $self->add_symbol_handler( load_handler => \&load_handler );
    $self->add_symbol_handler( run_handler  => \&run_handler );
}

#-------------------------------------------------------------------------------
# handle_symbol( $context, $symbol_name )
# Here's teh beef!
# Accepting the current context member and a symbol name as arguments, this
# method fetches the list of handler subs associated with $symbol_name and
# fires each of them in turn (passing in the $context). The return codes from
# each sub is examined (see Magpie::Constants, and the handle_* subs below)
# and the handler's program flow is controlled accordingly. If all subs
# return OK (200) this method does not intervene-- each sub is fired and
# we return OK to the main event loop (which will then move to the next symbol
# in the queue).
#-------------------------------------------------------------------------------
sub handle_symbol {
    my $self        = shift;
    my $ctxt        = shift;
    my $symbol      = shift;
    my $return_code = undef;

    # warn "Handling symbol: $symbol \n";
    # load each handler associated with $symbol, run them,
    # and manipulate program flow if need be based on their
    # return values
    foreach my $h ( $self->get_symbol_handler( $symbol ) ) {
        try {
            $return_code = $h->($self, $ctxt);
        }
        catch {
            $self->set_error({ status_code => 500, reason => $_ });
            #warn "Error running symbol '$symbol': $_";
        };

        if ( (!length $return_code) or ($return_code >= SERVER_ERROR) ) {
            unless ( $self->has_error ) {
                $self->set_error({
                    status_code => 500,
                    reason => "Internal error or unknown return code from symbol '$symbol'"
                });
            }
            $return_code = DONE;
        }

        return $self->control_done()     if $return_code == DONE;
        return $self->control_declined() if $return_code == DECLINED;
        return $self->control_output()   if $return_code == OUTPUT;
    }
    return OK;
}

sub init_queue {
    my $self = shift;
    my $ctxt = shift;

    # always first
    $self->add_to_queue( 'next_in_pipe' );
    my $pkg = $self->meta->name;
    my @event_names = ();

    if ( $self->can('load_queue') ) {
        @event_names = $self->load_queue($ctxt);
    }

    foreach my $event_name ( @event_names ) {
        $self->add_to_queue( $event_name );
    }

    return OK;
}

#-------------------------------------------------------------------------------
# add_to_queue( $symbol, $priority )
#-------------------------------------------------------------------------------
sub add_to_queue      {
    my $self     = shift;
    my $symbol   = shift;
    my $priority = shift;

    #warn "add to queue $symbol";
    $symbol = $self->_qualify_symbol_name( $symbol );

    unless ( $self->has_symbol($symbol) ) {
        warn "Warning: '$symbol' could not be added to the queue. Are you sure you registered it via register_events?";
        #XXX: should we die or set_error here instead?
        return;
    }

    # add events with high priority to the beginning of the stack.
    if ( defined $priority and $priority == 1 ) {
        $self->unshift_queue( $symbol );
    }
    else {
        $self->free_queue() if defined $priority and $priority == -1;
        $self->push_queue( $symbol );
    }
}

#-------------------------------------------------------------------------------
# remove_from_queue( $symbol, $priority )
#-------------------------------------------------------------------------------
sub remove_from_queue {
    my $self     = shift;
    my $symbol   = shift;
    my $priority = shift || 0;

    $symbol = $self->_qualify_symbol_name( $symbol );

    unless ( $self->has_symbol($symbol) ) {
        warn "Warning: Unregistered event '$symbol' could not be removed from the queue because it does not exist. Are you sure you registered it via register_events?";
        return;
    }

    my $f = 0;

    if ($priority == 0 ) {
        my @new = grep { $_ ne $symbol } @{$self->event_queue};
        $self->event_queue(\@new);
    }

    # remove the last occourence of $symbol
    elsif ( $priority == -1 ) {
        my @new = reverse grep { defined $_ } map {
            $_ ne $symbol ?
                $_ :
                $f == 1 ?
                    $_ : do{ $f=1; undef }
              } reverse( @{$self->event_queue} );
        $self->event_queue(\@new);
    }

    # otherwise, drop the first occourence of $symbol
    else {
        my @new = grep { defined $_ } map {
            $_ ne $symbol ?
                $_ :
                $f == 1 ?
                    $_ : do{ $f=1; undef }
            } @{$self->event_queue};
        $self->event_queue(\@new);
    }
}


################################################################################
# Control handlers.
################################################################################
# Event handlers that manage program flow in response to the control
# codes returned from the various handler subs.
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# control_done()
# Fires when user returns DONE (299) from their handler sub. Is expected to
# stop the application immediately.
#-------------------------------------------------------------------------------
sub control_done {
    my $self = shift;
    $self->stop_application;
    return DONE;
}

#-------------------------------------------------------------------------------
# control_declined()
# Fires when user returns DECLINED (199) from their handler sub. Is expected to
# nukes the rest of the events associated with the current handler and move
# to the next handler class in the queue.
#-------------------------------------------------------------------------------
sub control_declined {
    my $self = shift;
    $self->free_queue;
    return OK;
}

#-------------------------------------------------------------------------------
# control_output()
# Fires when user returns DECLINED (300) from their handler sub. Is expected to
# cause the queue to jump immediately to the Output handler and its queued subs.
#-------------------------------------------------------------------------------
sub control_output {
    my $self = shift;

    my $new_handlers = [];
    if ( defined $self->{parent_handler}{handlers} ) {

        # XXX: this is lame because it assumes that the last
        # parent handler is the Output class
        # I'll fix it if it really becomes an issue in Real Life(tm)
        # -ubu

        push @{$new_handlers}, $self->{parent_handler}{handlers}->[-1];
        $self->free_queue;
        $self->{parent_handler}{handlers} = $new_handlers;
    }
    return OK;
}

sub run {
    my $self  = shift;
    my $ctxt  = shift;
    my $state = OK;

    $ctxt ||= {};

    # reinit per each run required for pipelining
    $self->init_queue($ctxt);

    while ( my $symbol = $self->shift_queue() ) {
        $state = $self->handle_symbol( $ctxt, $symbol );
        # if an error occours here we must stop!
        # warn "state is $state from $symbol";
        last unless $state == OK;
    }
    $self->end_application( $ctxt );
    return $self->server_status;
}

# SEEALSO: Magpie

1;

__END__
=pod

=head1 NAME

Magpie::Event - Core Event Role Shared By All Magpie Classes

=head1 VERSION

version 1.140280

=head1 AUTHORS

=over 4

=item *

Kip Hampton <kip.hampton@tamarou.com>

=item *

Chris Prather <chris.prather@tamarou.com>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2011 by Tamarou, LLC.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut