lib/Catalyst/Base.pm

   1 package Catalyst::Base;
   2
   3 use strict;
   4 use base qw/Catalyst::Component Catalyst::AttrContainer Class::Accessor::Fast/;
   5
   6 use Catalyst::Exception;
   7 use Catalyst::Utils;
   8 use Class::Inspector;
   9 use NEXT;
  10
  11 __PACKAGE__->mk_classdata($_) for qw/_dispatch_steps/;
  12
  13 __PACKAGE__->_dispatch_steps( [qw/_BEGIN _AUTO _ACTION/] );
  14
  15 sub _DISPATCH : Private {
  16     my ( $self, $c ) = @_;
  17
  18     foreach my $disp ( @{ $self->_dispatch_steps } ) {
  19         last unless $c->forward($disp);
  20     }
  21
  22     $c->forward('_END');
  23 }
  24
  25 sub _BEGIN : Private {
  26     my ( $self, $c ) = @_;
  27     my $begin = ($c->get_actions( 'begin', $c->namespace))[-1];
  28     return 1 unless $begin;
  29     $begin->execute($c);
  30     return !@{ $c->error };
  31 }
  32
  33 sub _AUTO : Private {
  34     my ( $self, $c ) = @_;
  35     my @auto = $c->get_actions('auto', $c->namespace);
  36     foreach my $auto (@auto) {
  37         $auto->execute($c);
  38         return 0 unless $c->state;
  39     }
  40     return 1;
  41 }
  42
  43 sub _ACTION : Private {
  44     my ( $self, $c ) = @_;
  45     $c->action->execute($c);
  46     return !@{ $c->error };
  47 }
  48
  49 sub _END : Private {
  50     my ( $self, $c ) = @_;
  51     my $end = ($c->get_actions( 'end', $c->namespace))[-1];
  52     return 1 unless $end;
  53     $end->execute($c);
  54     return !@{ $c->error };
  55 }
  56
  57 sub action_namespace {
  58     my ( $self, $c ) = @_;
  59     return
  60         Catalyst::Utils::class2prefix(
  61             ref $self, $c->config->{case_sensitive} ) || '';
  62 }
  63
  64 sub register_actions {
  65     my ( $self, $c ) = @_;
  66     my $class = ref $self || $self;
  67     my $namespace = $self->action_namespace( $c );
  68     my %methods;
  69     $methods{$self->can($_)} = $_ for @{Class::Inspector->methods($class)||[]};
  70     foreach my $cache (@{$self->_action_cache}) {
  71         my $code = $cache->[0];
  72         my $method = $methods{$code};
  73         next unless $method;
  74         my $attrs = $self->_parse_attrs(@{$cache->[1]});
  75         if ($attrs->{Private} && ( keys %$attrs > 1 ) ) {
  76             $c->log->debug( 'Bad action definition "'
  77                   . join( ' ', @{$cache->[1]} )
  78                   . qq/" for "$class->$method"/ )
  79               if $c->debug;
  80             next;
  81         }
  82         my $reverse = $namespace ? "$namespace/$method" : $method;
  83         my $action = Catalyst::Action->new(
  84             {
  85                 name       => $method,
  86                 code       => $code,
  87                 reverse    => $reverse,
  88                 namespace  => $namespace,
  89                 class      => $class,
  90                 attributes => $attrs,
  91             }
  92         );
  93         $c->dispatcher->register($c, $action);
  94     }
  95 }
  96
  97 sub _parse_attrs {
  98     my ( $self, @attrs ) = @_;
  99     my %attributes;
 100     foreach my $attr (@attrs) {
 101
 102         # Parse out :Foo(bar) into Foo => bar etc (and arrayify)
 103
 104         if ( my ( $key, $value ) = ( $attr =~ /^(.*?)(?:\(\s*(.+)\s*\))?$/ ) ) {
 105
 106             if ( defined $value ) {
 107                 ( $value =~ s/^'(.*)'$/$1/ ) || ( $value =~ s/^"(.*)"/$1/ );
 108             }
 109             push( @{ $attributes{$key} }, $value );
 110         }
 111     }
 112     return \%attributes;
 113 }
 114
 115
 116 =head1 NAME
 117
 118 Catalyst::Base - Catalyst Controller Base Class
 119
 120 =head1 SYNOPSIS
 121
 122
 123 =head1 DESCRIPTION
 124
 125
 126 =head1 METHODS
 127
 128 =over 4
 129
 130 =back
 131
 132 =head1 SEE ALSO
 133
 134 L<Catalyst>.
 135
 136 =head1 AUTHOR
 137
 138 Sebastian Riedel, C<sri@cpan.org>
 139 Marcus Ramberg, C<mramberg@cpan.org>
 140 Matt S Trout, C<mst@shadowcatsystems.co.uk>
 141
 142 =head1 COPYRIGHT
 143
 144 This program is free software, you can redistribute it and/or modify it under
 145 the same terms as Perl itself.
 146
 147 =cut
 148
 149 1;