[catagits/Catalyst-Runtime.git] / lib / Catalyst / Controller.pm

package Catalyst::Controller;

use strict;
use base qw/Catalyst::Component Catalyst::AttrContainer Class::Accessor::Fast/;

use Catalyst::Exception;
use Catalyst::Utils;
use Class::Inspector;
use NEXT;

=head1 NAME

Catalyst::Controller - Catalyst Controller base class

=head1 SYNOPSIS

  package MyApp::Controller::Search
  use base qw/Catalyst::Controller/;

  sub foo : Local { 
    my ($self,$c,@args) = @_;
    ... 
  } # Dispatches to /search/foo

=head1 DESCRIPTION

Controllers are where the actions in the Catalyst framework
reside. Each action is represented by a function with an attribute to
identify what kind of action it is. See the L<Catalyst::Dispatcher>
for more info about how Catalyst dispatches to actions.

=cut

__PACKAGE__->mk_classdata($_) for qw/_dispatch_steps _action_class/;

__PACKAGE__->_dispatch_steps( [qw/_BEGIN _AUTO _ACTION/] );
__PACKAGE__->_action_class('Catalyst::Action');

__PACKAGE__->mk_accessors( qw/_application/ );

### _app as alias
*_app = *_application;

sub _DISPATCH : Private {
    my ( $self, $c ) = @_;

    foreach my $disp ( @{ $self->_dispatch_steps } ) {
        last unless $c->forward($disp);
    }

    $c->forward('_END');
}

sub _BEGIN : Private {
    my ( $self, $c ) = @_;
    my $begin = ( $c->get_actions( 'begin', $c->namespace ) )[-1];
    return 1 unless $begin;
    $begin->dispatch( $c );
    return !@{ $c->error };
}

sub _AUTO : Private {
    my ( $self, $c ) = @_;
    my @auto = $c->get_actions( 'auto', $c->namespace );
    foreach my $auto (@auto) {
        $auto->dispatch( $c );
        return 0 unless $c->state;
    }
    return 1;
}

sub _ACTION : Private {
    my ( $self, $c ) = @_;
    if (   ref $c->action
        && $c->action->can('execute')
        && defined $c->req->action )
    {
        $c->action->dispatch( $c );
    }
    return !@{ $c->error };
}

sub _END : Private {
    my ( $self, $c ) = @_;
    my $end = ( $c->get_actions( 'end', $c->namespace ) )[-1];
    return 1 unless $end;
    $end->dispatch( $c );
    return !@{ $c->error };
}

sub new {
    my $self = shift;
    my $app = $_[0];
    my $new = $self->NEXT::new(@_);
    $new->_application( $app );
    return $new;
}


sub action_for {
    my ( $self, $name ) = @_;
    my $app = ($self->isa('Catalyst') ? $self : $self->_application);
    return $app->dispatcher->get_action($name, $self->action_namespace);
}

sub action_namespace {
    my ( $self, $c ) = @_;
    unless ( $c ) {
        $c = ($self->isa('Catalyst') ? $self : $self->_application);
    }
    my $hash = (ref $self ? $self : $self->config); # hate app-is-class
    return $hash->{namespace} if exists $hash->{namespace};
    return Catalyst::Utils::class2prefix( ref($self) || $self,
        $c->config->{case_sensitive} )
      || '';
}

sub path_prefix {
    my ( $self, $c ) = @_;
    unless ( $c ) {
        $c = ($self->isa('Catalyst') ? $self : $self->_application);
    }
    my $hash = (ref $self ? $self : $self->config); # hate app-is-class
    return $hash->{path} if exists $hash->{path};
    return shift->action_namespace(@_);
}


sub register_actions {
    my ( $self, $c ) = @_;
    my $class = ref $self || $self;
    my $namespace = $self->action_namespace($c);
    my %methods;
    $methods{ $self->can($_) } = $_
      for @{ Class::Inspector->methods($class) || [] };

    # Advanced inheritance support for plugins and the like
    my @action_cache;
    {
        no strict 'refs';
        for my $isa ( @{"$class\::ISA"}, $class ) {
            push @action_cache, @{ $isa->_action_cache }
              if $isa->can('_action_cache');
        }
    }

    foreach my $cache (@action_cache) {
        my $code   = $cache->[0];
        my $method = delete $methods{$code}; # avoid dupe registers
        next unless $method;
        my $attrs = $self->_parse_attrs( $c, $method, @{ $cache->[1] } );
        if ( $attrs->{Private} && ( keys %$attrs > 1 ) ) {
            $c->log->debug( 'Bad action definition "'
                  . join( ' ', @{ $cache->[1] } )
                  . qq/" for "$class->$method"/ )
              if $c->debug;
            next;
        }
        my $reverse = $namespace ? "$namespace/$method" : $method;
        my $action = $self->create_action(
            name       => $method,
            code       => $code,
            reverse    => $reverse,
            namespace  => $namespace,
            class      => $class,
            attributes => $attrs,
        );

        $c->dispatcher->register( $c, $action );
    }
}

sub create_action {
    my $self = shift;
    my %args = @_;

    my $class = (exists $args{attributes}{ActionClass}
                    ? $args{attributes}{ActionClass}[0]
                    : $self->_action_class);

    unless ( Class::Inspector->loaded($class) ) {
        require Class::Inspector->filename($class);
    }
    
    return $class->new( \%args );
}

sub _parse_attrs {
    my ( $self, $c, $name, @attrs ) = @_;

    my %raw_attributes;

    foreach my $attr (@attrs) {

        # Parse out :Foo(bar) into Foo => bar etc (and arrayify)

        if ( my ( $key, $value ) = ( $attr =~ /^(.*?)(?:\(\s*(.+?)\s*\))?$/ ) )
        {

            if ( defined $value ) {
                ( $value =~ s/^'(.*)'$/$1/ ) || ( $value =~ s/^"(.*)"/$1/ );
            }
            push( @{ $raw_attributes{$key} }, $value );
        }
    }

    my $hash = (ref $self ? $self : $self->config); # hate app-is-class

    if (exists $hash->{actions} || exists $hash->{action}) {
      my $a = $hash->{actions} || $hash->{action};
      %raw_attributes = ((exists $a->{'*'} ? %{$a->{'*'}} : ()),
                         %raw_attributes,
                         (exists $a->{$name} ? %{$a->{$name}} : ()));
    }

    my %final_attributes;

    foreach my $key (keys %raw_attributes) {

        my $raw = $raw_attributes{$key};

        foreach my $value (ref($raw) eq 'ARRAY' ? @$raw : $raw) {

            my $meth = "_parse_${key}_attr";
            if ( $self->can($meth) ) {
                ( $key, $value ) = $self->$meth( $c, $name, $value );
            }
            push( @{ $final_attributes{$key} }, $value );
        }
    }

    return \%final_attributes;
}

sub _parse_Global_attr {
    my ( $self, $c, $name, $value ) = @_;
    return $self->_parse_Path_attr( $c, $name, "/$name" );
}

sub _parse_Absolute_attr { shift->_parse_Global_attr(@_); }

sub _parse_Local_attr {
    my ( $self, $c, $name, $value ) = @_;
    return $self->_parse_Path_attr( $c, $name, $name );
}

sub _parse_Relative_attr { shift->_parse_Local_attr(@_); }

sub _parse_Path_attr {
    my ( $self, $c, $name, $value ) = @_;
    $value = '' if !defined $value;
    if ( $value =~ m!^/! ) {
        return ( 'Path', $value );
    }
    elsif ( length $value ) {
        return ( 'Path', join( '/', $self->path_prefix($c), $value ) );
    }
    else {
        return ( 'Path', $self->path_prefix($c) );
    }
}

sub _parse_Regex_attr {
    my ( $self, $c, $name, $value ) = @_;
    return ( 'Regex', $value );
}

sub _parse_Regexp_attr { shift->_parse_Regex_attr(@_); }

sub _parse_LocalRegex_attr {
    my ( $self, $c, $name, $value ) = @_;
    unless ( $value =~ s/^\^// ) { $value = "(?:.*?)$value"; }
    return ( 'Regex', '^' . $self->path_prefix($c) . "/${value}" );
}

sub _parse_LocalRegexp_attr { shift->_parse_LocalRegex_attr(@_); }

sub _parse_ActionClass_attr {
    my ( $self, $c, $name, $value ) = @_;
    unless ( $value =~ s/^\+// ) {
      $value = join('::', $self->_action_class, $value );
    }
    return ( 'ActionClass', $value );
}

sub _parse_MyAction_attr {
    my ( $self, $c, $name, $value ) = @_;

    my $appclass = Catalyst::Utils::class2appclass($self);
    $value = "${appclass}::Action::${value}";

    return ( 'ActionClass', $value );
}

1;

__END__

=head1 CONFIGURATION

Like any other L<Catalyst::Component>, controllers have a config hash,
accessible through $self->config from the controller actions.  Some
settings are in use by the Catalyst framework:

=head2 namespace

This specifies the internal namespace the controller should be bound
to. By default the controller is bound to the URI version of the
controller name. For instance controller 'MyApp::Controller::Foo::Bar'
will be bound to 'foo/bar'. The default Root controller is an example
of setting namespace to '' (the null string).

=head2 path 

Sets 'path_prefix', as described below.

=head1 METHODS

=head2 $class->new($app, @args)

Proxies through to NEXT::new and stashes the application instance as
$self->_application.

=head2 $self->action_for('name')

Returns the Catalyst::Action object (if any) for a given method name
in this component.

=head2 $self->register_actions($c)

Finds all applicable actions for this component, creates
Catalyst::Action objects (using $self->create_action) for them and
registers them with $c->dispatcher.

=head2 $self->action_namespace($c)

Returns the private namespace for actions in this component. Defaults
to a value from the controller name (for
e.g. MyApp::Controller::Foo::Bar becomes "foo/bar") or can be
overridden from the "namespace" config key.


=head2 $self->path_prefix($c)

Returns the default path prefix for :Local, :LocalRegex and relative
:Path actions in this component. Defaults to the action_namespace or
can be overridden from the "path" config key.

=head2 $self->create_action(%args)

Called with a hash of data to be use for construction of a new
Catalyst::Action (or appropriate sub/alternative class) object.

Primarily designed for the use of register_actions.

=head2 $self->_application

=head2 $self->_app

Returns the application instance stored by C<new()>

=head1 AUTHOR

Sebastian Riedel, C<sri@oook.de>
Marcus Ramberg C<mramberg@cpan.org>

=head1 COPYRIGHT

This program is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
Commit	Line	Data
5ee249f2	1	package Catalyst::Controller;
	2
	3	use strict;
234763d4	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;
5ee249f2	10
	11	=head1 NAME
	12
	13	Catalyst::Controller - Catalyst Controller base class
	14
	15	=head1 SYNOPSIS
	16
234763d4	17	package MyApp::Controller::Search
a269e0c2	18	use base qw/Catalyst::Controller/;
234763d4	19
234763d4	20	sub foo : Local {
85d9fce6	21	my ($self,$c,@args) = @_;
85d9fce6	22	...
234763d4	23	} # Dispatches to /search/foo
5ee249f2	24
	25	=head1 DESCRIPTION
	26
a269e0c2	27	Controllers are where the actions in the Catalyst framework
	28	reside. Each action is represented by a function with an attribute to
	29	identify what kind of action it is. See the L<Catalyst::Dispatcher>
	30	for more info about how Catalyst dispatches to actions.
234763d4	31
	32	=cut
	33
	34	__PACKAGE__->mk_classdata($_) for qw/_dispatch_steps _action_class/;
	35
	36	__PACKAGE__->_dispatch_steps( [qw/_BEGIN _AUTO _ACTION/] );
	37	__PACKAGE__->_action_class('Catalyst::Action');
	38
	39	__PACKAGE__->mk_accessors( qw/_application/ );
	40
	41	### _app as alias
	42	_app = _application;
	43
	44	sub _DISPATCH : Private {
	45	my ( $self, $c ) = @_;
	46
	47	foreach my $disp ( @{ $self->_dispatch_steps } ) {
	48	last unless $c->forward($disp);
	49	}
	50
	51	$c->forward('_END');
	52	}
	53
	54	sub _BEGIN : Private {
	55	my ( $self, $c ) = @_;
	56	my $begin = ( $c->get_actions( 'begin', $c->namespace ) )[-1];
	57	return 1 unless $begin;
	58	$begin->dispatch( $c );
	59	return !@{ $c->error };
	60	}
	61
	62	sub _AUTO : Private {
	63	my ( $self, $c ) = @_;
	64	my @auto = $c->get_actions( 'auto', $c->namespace );
	65	foreach my $auto (@auto) {
	66	$auto->dispatch( $c );
	67	return 0 unless $c->state;
	68	}
	69	return 1;
	70	}
	71
	72	sub _ACTION : Private {
	73	my ( $self, $c ) = @_;
	74	if ( ref $c->action
	75	&& $c->action->can('execute')
53119b78	76	&& defined $c->req->action )
234763d4	77	{
	78	$c->action->dispatch( $c );
	79	}
	80	return !@{ $c->error };
	81	}
	82
	83	sub _END : Private {
	84	my ( $self, $c ) = @_;
	85	my $end = ( $c->get_actions( 'end', $c->namespace ) )[-1];
	86	return 1 unless $end;
	87	$end->dispatch( $c );
	88	return !@{ $c->error };
	89	}
	90
	91	sub new {
	92	my $self = shift;
	93	my $app = $_[0];
	94	my $new = $self->NEXT::new(@_);
	95	$new->_application( $app );
	96	return $new;
	97	}
	98
	99
	100	sub action_for {
	101	my ( $self, $name ) = @_;
	102	my $app = ($self->isa('Catalyst') ? $self : $self->_application);
	103	return $app->dispatcher->get_action($name, $self->action_namespace);
	104	}
	105
	106	sub action_namespace {
	107	my ( $self, $c ) = @_;
	108	unless ( $c ) {
	109	$c = ($self->isa('Catalyst') ? $self : $self->_application);
	110	}
	111	my $hash = (ref $self ? $self : $self->config); # hate app-is-class
	112	return $hash->{namespace} if exists $hash->{namespace};
	113	return Catalyst::Utils::class2prefix( ref($self) \|\| $self,
	114	$c->config->{case_sensitive} )
	115	\|\| '';
	116	}
	117
	118	sub path_prefix {
	119	my ( $self, $c ) = @_;
	120	unless ( $c ) {
	121	$c = ($self->isa('Catalyst') ? $self : $self->_application);
	122	}
	123	my $hash = (ref $self ? $self : $self->config); # hate app-is-class
	124	return $hash->{path} if exists $hash->{path};
	125	return shift->action_namespace(@_);
	126	}
	127
	128
	129	sub register_actions {
	130	my ( $self, $c ) = @_;
	131	my $class = ref $self \|\| $self;
	132	my $namespace = $self->action_namespace($c);
	133	my %methods;
	134	$methods{ $self->can($_) } = $_
	135	for @{ Class::Inspector->methods($class) \|\| [] };
	136
	137	# Advanced inheritance support for plugins and the like
	138	my @action_cache;
	139	{
	140	no strict 'refs';
141	for my $isa ( @{"$class\::ISA"}, $class ) {
142	push @action_cache, @{ $isa->_action_cache }
143	if $isa->can('_action_cache');
144	}
145	}
146
147	foreach my $cache (@action_cache) {
148	my $code = $cache->[0];
149	my $method = delete $methods{$code}; # avoid dupe registers
150	next unless $method;
151	my $attrs = $self->_parse_attrs( $c, $method, @{ $cache->[1] } );
152	if ( $attrs->{Private} && ( keys %$attrs > 1 ) ) {
153	$c->log->debug( 'Bad action definition "'
154	. join( ' ', @{ $cache->[1] } )
155	. qq/" for "$class->$method"/ )
156	if $c->debug;
157	next;
158	}
159	my $reverse = $namespace ? "$namespace/$method" : $method;
160	my $action = $self->create_action(
161	name => $method,
162	code => $code,
163	reverse => $reverse,
164	namespace => $namespace,
165	class => $class,
166	attributes => $attrs,
167	);
168
169	$c->dispatcher->register( $c, $action );
170	}
171	}
172
173	sub create_action {
174	my $self = shift;
175	my %args = @_;
176
177	my $class = (exists $args{attributes}{ActionClass}
178	? $args{attributes}{ActionClass}[0]
179	: $self->_action_class);
180
181	unless ( Class::Inspector->loaded($class) ) {
182	require Class::Inspector->filename($class);
183	}
184
185	return $class->new( \%args );
186	}
187
188	sub _parse_attrs {
189	my ( $self, $c, $name, @attrs ) = @_;
190
191	my %raw_attributes;
192
193	foreach my $attr (@attrs) {
194
195	# Parse out :Foo(bar) into Foo => bar etc (and arrayify)
196
197	if ( my ( $key, $value ) = ( $attr =~ /^(.?)(?:\(\s(.+?)\s*\))?$/ ) )
198	{
199
200	if ( defined $value ) {
201	( $value =~ s/^'(.)'$/$1/ ) \|\| ( $value =~ s/^"(.)"/$1/ );
202	}
203	push( @{ $raw_attributes{$key} }, $value );
204	}
205	}
206
207	my $hash = (ref $self ? $self : $self->config); # hate app-is-class
208
209	if (exists $hash->{actions} \|\| exists $hash->{action}) {
210	my $a = $hash->{actions} \|\| $hash->{action};
211	%raw_attributes = ((exists $a->{''} ? %{$a->{''}} : ()),
212	%raw_attributes,
213	(exists $a->{$name} ? %{$a->{$name}} : ()));
214	}
215
216	my %final_attributes;
217
218	foreach my $key (keys %raw_attributes) {
219
220	my $raw = $raw_attributes{$key};
221
222	foreach my $value (ref($raw) eq 'ARRAY' ? @$raw : $raw) {
223
224	my $meth = "_parse_${key}_attr";
225	if ( $self->can($meth) ) {
226	( $key, $value ) = $self->$meth( $c, $name, $value );
227	}
228	push( @{ $final_attributes{$key} }, $value );
229	}
230	}
231
232	return \%final_attributes;
233	}
234
235	sub _parse_Global_attr {
236	my ( $self, $c, $name, $value ) = @_;
237	return $self->_parse_Path_attr( $c, $name, "/$name" );
238	}
239
240	sub _parse_Absolute_attr { shift->_parse_Global_attr(@_); }
241
242	sub _parse_Local_attr {
243	my ( $self, $c, $name, $value ) = @_;
244	return $self->_parse_Path_attr( $c, $name, $name );
245	}
246
247	sub _parse_Relative_attr { shift->_parse_Local_attr(@_); }
248
249	sub _parse_Path_attr {
250	my ( $self, $c, $name, $value ) = @_;
53119b78	251	$value = '' if !defined $value;
234763d4	252	if ( $value =~ m!^/! ) {
	253	return ( 'Path', $value );
	254	}
	255	elsif ( length $value ) {
	256	return ( 'Path', join( '/', $self->path_prefix($c), $value ) );
	257	}
	258	else {
	259	return ( 'Path', $self->path_prefix($c) );
	260	}
	261	}
	262
	263	sub _parse_Regex_attr {
	264	my ( $self, $c, $name, $value ) = @_;
	265	return ( 'Regex', $value );
	266	}
	267
	268	sub _parse_Regexp_attr { shift->_parse_Regex_attr(@_); }
	269
	270	sub _parse_LocalRegex_attr {
	271	my ( $self, $c, $name, $value ) = @_;
	272	unless ( $value =~ s/^\^// ) { $value = "(?:.*?)$value"; }
	273	return ( 'Regex', '^' . $self->path_prefix($c) . "/${value}" );
	274	}
	275
	276	sub _parse_LocalRegexp_attr { shift->_parse_LocalRegex_attr(@_); }
	277
	278	sub _parse_ActionClass_attr {
	279	my ( $self, $c, $name, $value ) = @_;
	280	unless ( $value =~ s/^\+// ) {
	281	$value = join('::', $self->_action_class, $value );
	282	}
	283	return ( 'ActionClass', $value );
	284	}
	285
9287719b	286	sub _parse_MyAction_attr {
	287	my ( $self, $c, $name, $value ) = @_;
	288
	289	my $appclass = Catalyst::Utils::class2appclass($self);
	290	$value = "${appclass}::Action::${value}";
234763d4	291
9287719b	292	return ( 'ActionClass', $value );
9287719b	293	}
234763d4	294
	295	1;
	296
	297	__END__
	298
	299	=head1 CONFIGURATION
	300
a269e0c2	301	Like any other L<Catalyst::Component>, controllers have a config hash,
	302	accessible through $self->config from the controller actions. Some
	303	settings are in use by the Catalyst framework:
234763d4	304
	305	=head2 namespace
	306
a269e0c2	307	This specifies the internal namespace the controller should be bound
	308	to. By default the controller is bound to the URI version of the
	309	controller name. For instance controller 'MyApp::Controller::Foo::Bar'
	310	will be bound to 'foo/bar'. The default Root controller is an example
	311	of setting namespace to '' (the null string).
234763d4	312
2cbd9d12	313	=head2 path
234763d4	314
	315	Sets 'path_prefix', as described below.
	316
	317	=head1 METHODS
	318
	319	=head2 $class->new($app, @args)
	320
	321	Proxies through to NEXT::new and stashes the application instance as
	322	$self->_application.
	323
	324	=head2 $self->action_for('name')
	325
a269e0c2	326	Returns the Catalyst::Action object (if any) for a given method name
a269e0c2	327	in this component.
234763d4	328
	329	=head2 $self->register_actions($c)
	330
a269e0c2	331	Finds all applicable actions for this component, creates
	332	Catalyst::Action objects (using $self->create_action) for them and
	333	registers them with $c->dispatcher.
234763d4	334
	335	=head2 $self->action_namespace($c)
	336
a269e0c2	337	Returns the private namespace for actions in this component. Defaults
	338	to a value from the controller name (for
	339	e.g. MyApp::Controller::Foo::Bar becomes "foo/bar") or can be
	340	overridden from the "namespace" config key.
234763d4	341
	342
	343	=head2 $self->path_prefix($c)
	344
a269e0c2	345	Returns the default path prefix for :Local, :LocalRegex and relative
	346	:Path actions in this component. Defaults to the action_namespace or
	347	can be overridden from the "path" config key.
234763d4	348
	349	=head2 $self->create_action(%args)
	350
a269e0c2	351	Called with a hash of data to be use for construction of a new
a269e0c2	352	Catalyst::Action (or appropriate sub/alternative class) object.
234763d4	353
	354	Primarily designed for the use of register_actions.
	355
a269e0c2	356	=head2 $self->_application
234763d4	357
	358	=head2 $self->_app
	359
	360	Returns the application instance stored by C<new()>
5ee249f2	361
	362	=head1 AUTHOR
	363
	364	Sebastian Riedel, C<sri@oook.de>
234763d4	365	Marcus Ramberg C<mramberg@cpan.org>
5ee249f2	366
	367	=head1 COPYRIGHT
	368
a269e0c2	369	This program is free software, you can redistribute it and/or modify
a269e0c2	370	it under the same terms as Perl itself.
5ee249f2	371
5ee249f2	372	=cut