lib/Catalyst/Base.pm

   1 package Catalyst::Base;
   2
   3 use strict;
   4 use base qw/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/_config _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 Universal Base Class
 119
 120 =head1 SYNOPSIS
 121
 122     # lib/MyApp/Model/Something.pm
 123     package MyApp::Model::Something;
 124
 125     use base 'Catalyst::Base';
 126
 127     __PACKAGE__->config( foo => 'bar' );
 128
 129     sub test {
 130         my $self = shift;
 131         return $self->{foo};
 132     }
 133
 134     sub forward_to_me {
 135         my ( $self, $c ) = @_;
 136         $c->response->output( $self->{foo} );
 137     }
 138
 139     1;
 140
 141     # Methods can be a request step
 142     $c->forward(qw/MyApp::Model::Something forward_to_me/);
 143
 144     # Or just methods
 145     print $c->comp('MyApp::Model::Something')->test;
 146
 147     print $c->comp('MyApp::Model::Something')->{foo};
 148
 149 =head1 DESCRIPTION
 150
 151 This is the universal base class for Catalyst components
 152 (Model/View/Controller).
 153
 154 It provides you with a generic new() for instantiation through Catalyst's
 155 component loader with config() support and a process() method placeholder.
 156
 157 =head1 METHODS
 158
 159 =over 4
 160
 161 =item new($c)
 162
 163 =cut
 164
 165 sub new {
 166     my ( $self, $c ) = @_;
 167
 168     # Temporary fix, some components does not pass context to constructor
 169     my $arguments = ( ref( $_[-1] ) eq 'HASH' ) ? $_[-1] : {};
 170
 171     return $self->NEXT::new( { %{ $self->config }, %{$arguments} } );
 172 }
 173
 174 # remember to leave blank lines between the consecutive =item's
 175 # otherwise the pod tools don't recognize the subsequent =items
 176
 177 =item $c->config
 178
 179 =item $c->config($hashref)
 180
 181 =item $c->config($key, $value, ...)
 182
 183 =cut
 184
 185 sub config {
 186     my $self = shift;
 187     $self->_config( {} ) unless $self->_config;
 188     if (@_) {
 189         my $config = @_ > 1 ? {@_} : $_[0];
 190         while ( my ( $key, $val ) = each %$config ) {
 191             $self->_config->{$key} = $val;
 192         }
 193     }
 194     return $self->_config;
 195 }
 196
 197 =item $c->process()
 198
 199 =cut
 200
 201 sub process {
 202
 203     Catalyst::Exception->throw( message => ( ref $_[0] || $_[0] )
 204           . " did not override Catalyst::Base::process" );
 205 }
 206
 207 =back
 208
 209 =head1 SEE ALSO
 210
 211 L<Catalyst>.
 212
 213 =head1 AUTHOR
 214
 215 Sebastian Riedel, C<sri@cpan.org>
 216 Marcus Ramberg, C<mramberg@cpan.org>
 217 Matt S Trout, C<mst@shadowcatsystems.co.uk>
 218
 219 =head1 COPYRIGHT
 220
 221 This program is free software, you can redistribute it and/or modify it under
 222 the same terms as Perl itself.
 223
 224 =cut
 225
 226 1;