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

package Catalyst::Engine;

use strict;
use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
use UNIVERSAL::require;
use Data::Dumper;
use HTML::Entities;
use HTTP::Headers;
use Memoize;
use Time::HiRes qw/gettimeofday tv_interval/;
use Tree::Simple;
use Tree::Simple::Visitor::FindByPath;
use Catalyst::Request;
use Catalyst::Response;

require Module::Pluggable::Fast;

$Data::Dumper::Terse = 1;

__PACKAGE__->mk_classdata($_) for qw/actions components tree/;
__PACKAGE__->mk_accessors(qw/request response state/);

__PACKAGE__->actions(
    { plain => {}, private => {}, regex => {}, compiled => {}, reverse => {} }
);
__PACKAGE__->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );

*comp = \&component;
*req  = \&request;
*res  = \&response;

our $COUNT = 1;
our $START = time;

memoize('_class2prefix');

=head1 NAME

Catalyst::Engine - The Catalyst Engine

=head1 SYNOPSIS

See L<Catalyst>.

=head1 DESCRIPTION

=head1 METHODS

=over 4

=item $c->action( $name => $coderef, ... )

Add one or more actions.

    $c->action( '!foo' => sub { $_[1]->res->output('Foo!') } );

It also automatically calls setup() if needed.

See L<Catalyst::Manual::Intro> for more informations about actions.

=cut

sub action {
    my $self = shift;
    $self->setup unless $self->components;
    $self->actions( {} ) unless $self->actions;
    my $action;
    $_[1] ? ( $action = {@_} ) : ( $action = shift );
    if ( ref $action eq 'HASH' ) {
        while ( my ( $name, $code ) = each %$action ) {
            $self->set_action( $name, $code, caller(0) );
        }
    }
    return 1;
}

=item $c->get_action( $action, $namespace )

Get an action in a given namespace.

=cut

sub get_action {
    my ( $c, $action, $namespace ) = @_;
    $namespace ||= '';
    if ( $action =~ /^\!(.*)/ ) {
        $action = $1;
        my $parent = $c->tree;
        my @results;
        my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
        push @results, [$result] if $result;
        my $visitor = Tree::Simple::Visitor::FindByPath->new;
        for my $part ( split '/', $namespace ) {
            $visitor->setSearchPath($part);
            $parent->accept($visitor);
            my $child = $visitor->getResult;
            my $uid   = $child->getUID if $child;
            my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
            push @results, [$match] if $match;
            $parent = $child if $child;
        }
        return \@results;
    }
    elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
    elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
    else {
        for my $regex ( keys %{ $c->actions->{compiled} } ) {
            my $name = $c->actions->{compiled}->{$regex};
            if ( $action =~ $regex ) {
                my @snippets;
                for my $i ( 1 .. 9 ) {
                    no strict 'refs';
                    last unless ${$i};
                    push @snippets, ${$i};
                }
                return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
            }
        }
    }
    return [];
}

=item $c->set_action( $action, $code, $namespace )

Set an action in a given namespace.

=cut

sub set_action {
    my ( $c, $action, $code, $namespace ) = @_;

    my $prefix = '';
    if ( $action =~ /^\?(.*)$/ ) {
        my $prefix = $1 || '';
        $action = $2;
        $action = $prefix . _prefix( $namespace, $action );
        $c->actions->{plain}->{$action} = [ $namespace, $code ];
    }
    if ( $action =~ /^\/(.*)\/$/ ) {
        my $regex = $1;
        $c->actions->{compiled}->{qr#$regex#} = $action;
        $c->actions->{regex}->{$action} = [ $namespace, $code ];
    }
    elsif ( $action =~ /^\!(.*)$/ ) {
        $action = $1;
        my $parent  = $c->tree;
        my $visitor = Tree::Simple::Visitor::FindByPath->new;
        $prefix = _class2prefix($namespace);
        for my $part ( split '/', $prefix ) {
            $visitor->setSearchPath($part);
            $parent->accept($visitor);
            my $child = $visitor->getResult;
            unless ($child) {
                $child = $parent->addChild( Tree::Simple->new($part) );
                $visitor->setSearchPath($part);
                $parent->accept($visitor);
                $child = $visitor->getResult;
            }
            $parent = $child;
        }
        my $uid = $parent->getUID;
        $c->actions->{private}->{$uid}->{$action} = [ $namespace, $code ];
        $action = "!$action";
    }
    else { 
       $c->actions->{plain}->{$action} = [ $namespace, $code ];
    }

    my $reverse = $prefix ? "$action ($prefix)" : $action;
    $c->actions->{reverse}->{"$code"} = $reverse;

    $c->log->debug(qq/"$namespace" defined "$action" as "$code"/)
      if $c->debug;
}

=item $c->benchmark($coderef)

Takes a coderef with arguments and returns elapsed time as float.

    my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
    $c->log->info( sprintf "Processing took %f seconds", $elapsed );

=cut

sub benchmark {
    my $c       = shift;
    my $code    = shift;
    my $time    = [gettimeofday];
    my @return  = &$code(@_);
    my $elapsed = tv_interval $time;
    return wantarray ? ( $elapsed, @return ) : $elapsed;
}

=item $c->comp($name)

=item $c->component($name)

Get a component object by name.

    $c->comp('MyApp::Model::MyModel')->do_stuff;

Regex search for a component.

    $c->comp('mymodel')->do_stuff;

=cut

sub component {
    my ( $c, $name ) = @_;
    if ( my $component = $c->components->{$name} ) {
        return $component;
    }
    else {
        for my $component ( keys %{ $c->components } ) {
            return $c->components->{$component} if $component =~ /$name/i;
        }
    }
}

=item $c->errors

=item $c->errors($error, ...)

=item $c->errors($arrayref)

Returns an arrayref containing errors messages.

    my @errors = @{ $c->errors };

Add a new error.

    $c->errors('Something bad happened');

=cut

sub errors {
    my $c = shift;
    my $errors = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
    push @{ $c->{errors} }, @$errors;
    return $c->{errors};
}

=item $c->finalize

Finalize request.

=cut

sub finalize {
    my $c = shift;

    if ( my $location = $c->res->redirect ) {
        $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
        $c->res->headers->header( Location => $location );
        $c->res->status(302);
    }

    if ( !$c->res->output || $#{ $c->errors } >= 0 ) {
        $c->res->headers->content_type('text/html');
        my $name = $c->config->{name} || 'Catalyst Application';
        my ( $title, $errors, $infos );
        if ( $c->debug ) {
            $errors = join '<br/>', @{ $c->errors };
            $errors ||= 'No output';
            $title = $name = "$name on Catalyst $Catalyst::VERSION";
            my $req   = encode_entities Dumper $c->req;
            my $res   = encode_entities Dumper $c->res;
            my $stash = encode_entities Dumper $c->stash;
            $infos = <<"";
<br/>
<b><u>Request</u></b><br/>
<pre>$req</pre>
<b><u>Response</u></b><br/>
<pre>$res</pre>
<b><u>Stash</u></b><br/>
<pre>$stash</pre>

        }
        else {
            $title  = $name;
            $errors = '';
            $infos  = <<"";
<pre>
(en) Please come back later
(de) Bitte versuchen sie es spaeter nocheinmal
(nl) Gelieve te komen later terug
(no) Vennligst prov igjen senere
(fr) Veuillez revenir plus tard
(es) Vuelto por favor mas adelante
(pt) Voltado por favor mais tarde
(it) Ritornato prego più successivamente
</pre>

            $name = '';
        }
        $c->res->{output} = <<"";
<html>
    <head>
        <title>$title</title>
        <style type="text/css">
            body {
                font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
                             Tahoma, Arial, helvetica, sans-serif;
                color: #ddd;
                background-color: #eee;
                margin: 0px;
                padding: 0px;
            }
            div.box {
                background-color: #ccc;
                border: 1px solid #aaa;
                padding: 4px;
                margin: 10px;
                -moz-border-radius: 10px;
            }
            div.errors {
                background-color: #977;
                border: 1px solid #755;
                padding: 8px;
                margin: 4px;
                margin-bottom: 10px;
                -moz-border-radius: 10px;
            }
            div.infos {
                background-color: #797;
                border: 1px solid #575;
                padding: 8px;
                margin: 4px;
                margin-bottom: 10px;
                -moz-border-radius: 10px;
            }
            div.name {
                background-color: #779;
                border: 1px solid #557;
                padding: 8px;
                margin: 4px;
                -moz-border-radius: 10px;
            }
        </style>
    </head>
    <body>
        <div class="box">
            <div class="errors">$errors</div>
            <div class="infos">$infos</div>
            <div class="name">$name</div>
        </div>
    </body>
</html>

    }
    $c->res->headers->content_length( length $c->res->output );
    my $status = $c->finalize_headers;
    $c->finalize_output;
    return $status;
}

=item $c->finalize_headers

Finalize headers.

=cut

sub finalize_headers { }

=item $c->finalize_output

Finalize output.

=cut

sub finalize_output { }

=item $c->forward($command)

Forward processing to a private/public action or a method from a class.
If you define a class without method it will default to process().

    $c->forward('!foo');
    $c->forward('index.html');
    $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
    $c->forward('MyApp::View::TT');

=cut

sub forward {
    my $c       = shift;
    my $command = shift;
    unless ($command) {
        $c->log->debug('Nothing to forward to') if $c->debug;
        return 0;
    }
    my $caller = caller(0);
    if ( $command =~ /^\?(.*)$/ ) {
        $command = $1;
        $command = _prefix( $caller, $command );
    }
    my $namespace = '';
    if ( $command =~ /^\!/ ) {
        $namespace = _class2prefix($caller);
    }
    if ( my $results = $c->get_action( $command, $namespace ) ) {
        if ( $command =~ /^\!/ ) {
            for my $result ( @{$results} ) {
                my ( $class, $code ) = @{ $result->[0] };
                $c->state( $c->process( $class, $code ) );
            }
        }
        else {
            return 0 unless my $result = $results->[0];
            if ( $result->[2] ) {
                $c->log->debug(qq/Couldn't forward "$command" to regex action/)
                  if $c->debug;
                return 0;
            }
            my ( $class, $code ) = @{ $result->[0] };
            $class = $c->components->{$class} || $class;
            $c->state( $c->process( $class, $code ) );
        }
    }
    else {
        my $class = $command;
        if ( $class =~ /[^\w\:]/ ) {
            $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
            return 0;
        }
        my $method = shift || 'process';
        if ( my $code = $class->can($method) ) {
            $c->actions->{reverse}->{"$code"} = "$class->$method";
            $c->state( $c->process( $class, $code ) );
        }
        else {
            $c->log->debug(qq/Couldn't forward to "$class->$method"/)
              if $c->debug;
            return 0;
        }
    }
    return $c->state;
}

=item $c->handler($r)

Handles the request.

=cut

sub handler {
    my ( $class, $r ) = @_;

    # Always expect worst case!
    my $status = -1;
    eval {
        my $handler = sub {
            my $c         = $class->prepare($r);
            my $action    = $c->req->action;
            my $namespace = '';
            $namespace = join '/', @{ $c->req->args } if $action eq '!default';
            unless ($namespace) {
                if ( my $result = $c->get_action($action) ) {
                    $namespace = _class2prefix( $result->[0]->[0]->[0] );
                }
            }
            my $results = $c->get_action( $action, $namespace );
            if ( @{$results} ) {
                for my $begin ( @{ $c->get_action( '!begin', $namespace ) } ) {
                    $c->state( $c->process( @{ $begin->[0] } ) );
                }
                for my $result ( @{ $c->get_action( $action, $namespace ) } ) {
                    $c->state( $c->process( @{ $result->[0] } ) );
                }
                for my $end ( @{ $c->get_action( '!end', $namespace ) } ) {
                    $c->state( $c->process( @{ $end->[0] } ) );
                }
            }
            else {
                my $path  = $c->req->path;
                my $error = $path
                  ? qq/Unknown resource "$path"/
                  : "No default action defined";
                $c->log->error($error) if $c->debug;
                $c->errors($error);
            }
            return $c->finalize;
        };
        if ( $class->debug ) {
            my $elapsed;
            ( $elapsed, $status ) = $class->benchmark($handler);
            $elapsed = sprintf '%f', $elapsed;
            my $av = sprintf '%.3f', 1 / $elapsed;
            $class->log->info( "Request took $elapsed" . "s ($av/s)" );
        }
        else { $status = &$handler }
    };
    if ( my $error = $@ ) {
        chomp $error;
        $class->log->error(qq/Caught exception in engine "$error"/);
    }
    $COUNT++;
    return $status;
}

=item $c->prepare($r)

Turns the engine-specific request (Apache, CGI...) into a Catalyst context.

=cut

sub prepare {
    my ( $class, $r ) = @_;
    my $c = bless {
        request => Catalyst::Request->new(
            {
                arguments  => [],
                cookies    => {},
                headers    => HTTP::Headers->new,
                parameters => {},
                snippets   => [],
                uploads    => {}
            }
        ),
        response => Catalyst::Response->new(
            { cookies => {}, headers => HTTP::Headers->new, status => 200 }
        ),
        stash => {},
        state => 0
    }, $class;
    if ( $c->debug ) {
        my $secs = time - $START || 1;
        my $av = sprintf '%.3f', $COUNT / $secs;
        $c->log->debug('********************************');
        $c->log->debug("* Request $COUNT ($av/s) [$$]");
        $c->log->debug('********************************');
        $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
    }
    $c->prepare_request($r);
    $c->prepare_path;
    $c->prepare_cookies;
    $c->prepare_headers;
    $c->prepare_connection;
    my $method   = $c->req->method   || '';
    my $path     = $c->req->path     || '';
    my $hostname = $c->req->hostname || '';
    my $address  = $c->req->address  || '';
    $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
      if $c->debug;
    $c->prepare_action;
    $c->prepare_parameters;

    if ( $c->debug && keys %{ $c->req->params } ) {
        my @params;
        for my $key ( keys %{ $c->req->params } ) {
            my $value = $c->req->params->{$key} || '';
            push @params, "$key=$value";
        }
        $c->log->debug( 'Parameters are "' . join( ' ', @params ) . '"' );
    }
    $c->prepare_uploads;
    return $c;
}

=item $c->prepare_action

Prepare action.

=cut

sub prepare_action {
    my $c    = shift;
    my $path = $c->req->path;
    my @path = split /\//, $c->req->path;
    $c->req->args( \my @args );
    while (@path) {
        $path = join '/', @path;
        if ( my $result = ${ $c->get_action($path) }[0] ) {

            # It's a regex
            if ($#$result) {
                my $match    = $result->[1];
                my @snippets = @{ $result->[2] };
                $c->log->debug(qq/Requested action "$path" matched "$match"/)
                  if $c->debug;
                $c->log->debug(
                    'Snippets are "' . join( ' ', @snippets ) . '"' )
                  if ( $c->debug && @snippets );
                $c->req->action($match);
                $c->req->snippets( \@snippets );
            }
            else {
                $c->req->action($path);
                $c->log->debug(qq/Requested action "$path"/) if $c->debug;
            }
            $c->req->match($path);
            last;
        }
        unshift @args, pop @path;
    }
    unless ( $c->req->action ) {
        $c->req->action('!default');
        $c->req->match('');
    }
    $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
      if ( $c->debug && @args );
}

=item $c->prepare_connection

Prepare connection.

=cut

sub prepare_connection { }

=item $c->prepare_cookies

Prepare cookies.

=cut

sub prepare_cookies { }

=item $c->prepare_headers

Prepare headers.

=cut

sub prepare_headers { }

=item $c->prepare_parameters

Prepare parameters.

=cut

sub prepare_parameters { }

=item $c->prepare_path

Prepare path and base.

=cut

sub prepare_path { }

=item $c->prepare_request

Prepare the engine request.

=cut

sub prepare_request { }

=item $c->prepare_uploads

Prepare uploads.

=cut

sub prepare_uploads { }

=item $c->process($class, $coderef)

Process a coderef in given class and catch exceptions.
Errors are available via $c->errors.

=cut

sub process {
    my ( $c, $class, $code ) = @_;
    my $status;
    eval {
        if ( $c->debug )
        {
            my $action = $c->actions->{reverse}->{"$code"} || "$code";
            my $elapsed;
            ( $elapsed, $status ) =
              $c->benchmark( $code, $class, $c, @{ $c->req->args } );
            $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
              if $c->debug;
        }
        else { $status = &$code( $class, $c, @{ $c->req->args } ) }
    };
    if ( my $error = $@ ) {
        chomp $error;
        $error = qq/Caught exception "$error"/;
        $c->log->error($error);
        $c->errors($error) if $c->debug;
        return 0;
    }
    return $status;
}

=item $c->run

Starts the engine.

=cut

sub run { }

=item $c->request

=item $c->req

Returns a C<Catalyst::Request> object.

    my $req = $c->req;

=item $c->response

=item $c->res

Returns a C<Catalyst::Response> object.

    my $res = $c->res;

=item $class->setup

Setup.

    MyApp->setup;

=cut

sub setup {
    my $self = shift;
    $self->setup_components;
    if ( $self->debug ) {
        my $name = $self->config->{name} || 'Application';
        $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
    }
}

=item $class->setup_components

Setup components.

=cut

sub setup_components {
    my $self = shift;

    # Components
    my $class = ref $self || $self;
    eval <<"";
        package $class;
        import Module::Pluggable::Fast
          name   => '_components',
          search => [
            '$class\::Controller', '$class\::C',
            '$class\::Model',      '$class\::M',
            '$class\::View',       '$class\::V'
          ];

    if ( my $error = $@ ) {
        chomp $error;
        $self->log->error(
            qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
    }
    $self->components( {} );
    for my $component ( $self->_components($self) ) {
        $self->components->{ ref $component } = $component;
    }
    $self->log->debug( 'Initialized components "'
          . join( ' ', keys %{ $self->components } )
          . '"' )
      if $self->debug;
}

=item $c->stash

Returns a hashref containing all your data.

    $c->stash->{foo} ||= 'yada';
    print $c->stash->{foo};

=cut

sub stash {
    my $self = shift;
    if ( $_[0] ) {
        my $stash = $_[1] ? {@_} : $_[0];
        while ( my ( $key, $val ) = each %$stash ) {
            $self->{stash}->{$key} = $val;
        }
    }
    return $self->{stash};
}

sub _prefix {
    my ( $class, $name ) = @_;
    my $prefix = _class2prefix($class);
    $name = "$prefix/$name" if $prefix;
    return $name;
}

sub _class2prefix {
    my $class = shift || '';
    $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/;
    my $prefix = lc $2 || '';
    $prefix =~ s/\:\:/\//g;
    return $prefix;
}

=back

=head1 AUTHOR

Sebastian Riedel, C<sri@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

1;
Commit	Line	Data
fc7ec1d9	1	package Catalyst::Engine;
	2
	3	use strict;
	4	use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
	5	use UNIVERSAL::require;
fc7ec1d9	6	use Data::Dumper;
	7	use HTML::Entities;
	8	use HTTP::Headers;
87e67021	9	use Memoize;
fc7ec1d9	10	use Time::HiRes qw/gettimeofday tv_interval/;
87e67021	11	use Tree::Simple;
87e67021	12	use Tree::Simple::Visitor::FindByPath;
fc7ec1d9	13	use Catalyst::Request;
	14	use Catalyst::Response;
	15
	16	require Module::Pluggable::Fast;
	17
	18	$Data::Dumper::Terse = 1;
	19
87e67021	20	__PACKAGE__->mk_classdata($_) for qw/actions components tree/;
b768faa3	21	__PACKAGE__->mk_accessors(qw/request response state/);
fc7ec1d9	22
fc7ec1d9	23	__PACKAGE__->actions(
87e67021	24	{ plain => {}, private => {}, regex => {}, compiled => {}, reverse => {} }
	25	);
	26	__PACKAGE__->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
fc7ec1d9	27
	28	*comp = \&component;
	29	*req = \&request;
	30	*res = \&response;
	31
	32	our $COUNT = 1;
	33	our $START = time;
	34
87e67021	35	memoize('_class2prefix');
87e67021	36
fc7ec1d9	37	=head1 NAME
	38
	39	Catalyst::Engine - The Catalyst Engine
	40
	41	=head1 SYNOPSIS
	42
	43	See L<Catalyst>.
	44
	45	=head1 DESCRIPTION
	46
23f9d934	47	=head1 METHODS
fc7ec1d9	48
23f9d934	49	=over 4
	50
	51	=item $c->action( $name => $coderef, ... )
	52
fc7ec1d9	53	Add one or more actions.
	54
	55	$c->action( '!foo' => sub { $_[1]->res->output('Foo!') } );
	56
fc7ec1d9	57	It also automatically calls setup() if needed.
	58
	59	See L<Catalyst::Manual::Intro> for more informations about actions.
	60
	61	=cut
	62
	63	sub action {
	64	my $self = shift;
	65	$self->setup unless $self->components;
	66	$self->actions( {} ) unless $self->actions;
	67	my $action;
	68	$_[1] ? ( $action = {@_} ) : ( $action = shift );
	69	if ( ref $action eq 'HASH' ) {
	70	while ( my ( $name, $code ) = each %$action ) {
0169d3a8	71	$self->set_action( $name, $code, caller(0) );
fc7ec1d9	72	}
fc7ec1d9	73	}
87e67021	74	return 1;
	75	}
	76
0169d3a8	77	=item $c->get_action( $action, $namespace )
87e67021	78
0169d3a8	79	Get an action in a given namespace.
87e67021	80
	81	=cut
	82
0169d3a8	83	sub get_action {
87e67021	84	my ( $c, $action, $namespace ) = @_;
	85	$namespace \|\|= '';
	86	if ( $action =~ /^\!(.*)/ ) {
	87	$action = $1;
b768faa3	88	my $parent = $c->tree;
	89	my @results;
	90	my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
	91	push @results, [$result] if $result;
87e67021	92	my $visitor = Tree::Simple::Visitor::FindByPath->new;
	93	for my $part ( split '/', $namespace ) {
	94	$visitor->setSearchPath($part);
	95	$parent->accept($visitor);
	96	my $child = $visitor->getResult;
	97	my $uid = $child->getUID if $child;
	98	my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
b768faa3	99	push @results, [$match] if $match;
87e67021	100	$parent = $child if $child;
fc7ec1d9	101	}
b768faa3	102	return \@results;
fc7ec1d9	103	}
b768faa3	104	elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
b768faa3	105	elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
fc7ec1d9	106	else {
87e67021	107	for my $regex ( keys %{ $c->actions->{compiled} } ) {
	108	my $name = $c->actions->{compiled}->{$regex};
	109	if ( $action =~ $regex ) {
	110	my @snippets;
	111	for my $i ( 1 .. 9 ) {
	112	no strict 'refs';
	113	last unless ${$i};
	114	push @snippets, ${$i};
	115	}
b768faa3	116	return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
87e67021	117	}
87e67021	118	}
fc7ec1d9	119	}
b768faa3	120	return [];
fc7ec1d9	121	}
fc7ec1d9	122
0169d3a8	123	=item $c->set_action( $action, $code, $namespace )
	124
	125	Set an action in a given namespace.
	126
	127	=cut
	128
	129	sub set_action {
	130	my ( $c, $action, $code, $namespace ) = @_;
	131
	132	my $prefix = '';
	133	if ( $action =~ /^\?(.*)$/ ) {
	134	my $prefix = $1 \|\| '';
	135	$action = $2;
	136	$action = $prefix . _prefix( $namespace, $action );
	137	$c->actions->{plain}->{$action} = [ $namespace, $code ];
	138	}
	139	if ( $action =~ /^\/(.*)\/$/ ) {
	140	my $regex = $1;
	141	$c->actions->{compiled}->{qr#$regex#} = $action;
	142	$c->actions->{regex}->{$action} = [ $namespace, $code ];
	143	}
	144	elsif ( $action =~ /^\!(.*)$/ ) {
	145	$action = $1;
	146	my $parent = $c->tree;
	147	my $visitor = Tree::Simple::Visitor::FindByPath->new;
	148	$prefix = _class2prefix($namespace);
	149	for my $part ( split '/', $prefix ) {
	150	$visitor->setSearchPath($part);
	151	$parent->accept($visitor);
	152	my $child = $visitor->getResult;
	153	unless ($child) {
	154	$child = $parent->addChild( Tree::Simple->new($part) );
	155	$visitor->setSearchPath($part);
	156	$parent->accept($visitor);
	157	$child = $visitor->getResult;
	158	}
	159	$parent = $child;
	160	}
	161	my $uid = $parent->getUID;
	162	$c->actions->{private}->{$uid}->{$action} = [ $namespace, $code ];
	163	$action = "!$action";
	164	}
	165	else {
c9afa5fc	166	$c->actions->{plain}->{$action} = [ $namespace, $code ];
0169d3a8	167	}
	168
	169	my $reverse = $prefix ? "$action ($prefix)" : $action;
	170	$c->actions->{reverse}->{"$code"} = $reverse;
	171
	172	$c->log->debug(qq/"$namespace" defined "$action" as "$code"/)
	173	if $c->debug;
	174	}
	175
23f9d934	176	=item $c->benchmark($coderef)
fc7ec1d9	177
	178	Takes a coderef with arguments and returns elapsed time as float.
	179
	180	my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
	181	$c->log->info( sprintf "Processing took %f seconds", $elapsed );
	182
	183	=cut
	184
	185	sub benchmark {
	186	my $c = shift;
	187	my $code = shift;
	188	my $time = [gettimeofday];
	189	my @return = &$code(@_);
	190	my $elapsed = tv_interval $time;
	191	return wantarray ? ( $elapsed, @return ) : $elapsed;
	192	}
	193
23f9d934	194	=item $c->comp($name)
	195
	196	=item $c->component($name)
fc7ec1d9	197
	198	Get a component object by name.
	199
	200	$c->comp('MyApp::Model::MyModel')->do_stuff;
	201
	202	Regex search for a component.
	203
	204	$c->comp('mymodel')->do_stuff;
	205
	206	=cut
	207
	208	sub component {
	209	my ( $c, $name ) = @_;
	210	if ( my $component = $c->components->{$name} ) {
	211	return $component;
	212	}
	213	else {
	214	for my $component ( keys %{ $c->components } ) {
	215	return $c->components->{$component} if $component =~ /$name/i;
	216	}
	217	}
	218	}
	219
23f9d934	220	=item $c->errors
	221
	222	=item $c->errors($error, ...)
	223
	224	=item $c->errors($arrayref)
fc7ec1d9	225
	226	Returns an arrayref containing errors messages.
	227
	228	my @errors = @{ $c->errors };
	229
	230	Add a new error.
	231
	232	$c->errors('Something bad happened');
	233
	234	=cut
	235
	236	sub errors {
	237	my $c = shift;
	238	my $errors = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
	239	push @{ $c->{errors} }, @$errors;
	240	return $c->{errors};
	241	}
	242
23f9d934	243	=item $c->finalize
fc7ec1d9	244
	245	Finalize request.
	246
	247	=cut
	248
	249	sub finalize {
	250	my $c = shift;
23f9d934	251
	252	if ( my $location = $c->res->redirect ) {
	253	$c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
	254	$c->res->headers->header( Location => $location );
	255	$c->res->status(302);
	256	}
	257
fc7ec1d9	258	if ( !$c->res->output \|\| $#{ $c->errors } >= 0 ) {
	259	$c->res->headers->content_type('text/html');
	260	my $name = $c->config->{name} \|\| 'Catalyst Application';
	261	my ( $title, $errors, $infos );
	262	if ( $c->debug ) {
	263	$errors = join '<br/>', @{ $c->errors };
	264	$errors \|\|= 'No output';
	265	$title = $name = "$name on Catalyst $Catalyst::VERSION";
	266	my $req = encode_entities Dumper $c->req;
	267	my $res = encode_entities Dumper $c->res;
	268	my $stash = encode_entities Dumper $c->stash;
	269	$infos = <<"";
	270	<br/>
	271	<b><u>Request</u></b><br/>
	272	<pre>$req</pre>
	273	<b><u>Response</u></b><br/>
	274	<pre>$res</pre>
	275	<b><u>Stash</u></b><br/>
	276	<pre>$stash</pre>
	277
	278	}
	279	else {
	280	$title = $name;
	281	$errors = '';
	282	$infos = <<"";
	283	<pre>
	284	(en) Please come back later
	285	(de) Bitte versuchen sie es spaeter nocheinmal
	286	(nl) Gelieve te komen later terug
	287	(no) Vennligst prov igjen senere
	288	(fr) Veuillez revenir plus tard
	289	(es) Vuelto por favor mas adelante
	290	(pt) Voltado por favor mais tarde
	291	(it) Ritornato prego più successivamente
	292	</pre>
	293
	294	$name = '';
	295	}
	296	$c->res->{output} = <<"";
	297	<html>
	298	<head>
	299	<title>$title</title>
	300	<style type="text/css">
	301	body {
	302	font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
	303	Tahoma, Arial, helvetica, sans-serif;
	304	color: #ddd;
	305	background-color: #eee;
	306	margin: 0px;
	307	padding: 0px;
	308	}
	309	div.box {
	310	background-color: #ccc;
	311	border: 1px solid #aaa;
	312	padding: 4px;
	313	margin: 10px;
	314	-moz-border-radius: 10px;
	315	}
	316	div.errors {
	317	background-color: #977;
	318	border: 1px solid #755;
	319	padding: 8px;
	320	margin: 4px;
	321	margin-bottom: 10px;
322	-moz-border-radius: 10px;
323	}
324	div.infos {
325	background-color: #797;
326	border: 1px solid #575;
327	padding: 8px;
328	margin: 4px;
329	margin-bottom: 10px;
330	-moz-border-radius: 10px;
331	}
332	div.name {
333	background-color: #779;
334	border: 1px solid #557;
335	padding: 8px;
336	margin: 4px;
337	-moz-border-radius: 10px;
338	}
339	</style>
340	</head>
341	<body>
342	<div class="box">
343	<div class="errors">$errors</div>
344	<div class="infos">$infos</div>
345	<div class="name">$name</div>
346	</div>
347	</body>
348	</html>
349
350	}
fc7ec1d9	351	$c->res->headers->content_length( length $c->res->output );
	352	my $status = $c->finalize_headers;
	353	$c->finalize_output;
	354	return $status;
	355	}
	356
23f9d934	357	=item $c->finalize_headers
fc7ec1d9	358
	359	Finalize headers.
	360
	361	=cut
	362
	363	sub finalize_headers { }
	364
23f9d934	365	=item $c->finalize_output
fc7ec1d9	366
	367	Finalize output.
	368
	369	=cut
	370
	371	sub finalize_output { }
	372
23f9d934	373	=item $c->forward($command)
fc7ec1d9	374
	375	Forward processing to a private/public action or a method from a class.
	376	If you define a class without method it will default to process().
	377
	378	$c->forward('!foo');
	379	$c->forward('index.html');
	380	$c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
	381	$c->forward('MyApp::View::TT');
	382
	383	=cut
	384
	385	sub forward {
	386	my $c = shift;
	387	my $command = shift;
	388	unless ($command) {
	389	$c->log->debug('Nothing to forward to') if $c->debug;
	390	return 0;
	391	}
87e67021	392	my $caller = caller(0);
fc7ec1d9	393	if ( $command =~ /^\?(.*)$/ ) {
fc7ec1d9	394	$command = $1;
fc7ec1d9	395	$command = _prefix( $caller, $command );
fc7ec1d9	396	}
87e67021	397	my $namespace = '';
	398	if ( $command =~ /^\!/ ) {
	399	$namespace = _class2prefix($caller);
7242d068	400	}
0169d3a8	401	if ( my $results = $c->get_action( $command, $namespace ) ) {
b768faa3	402	if ( $command =~ /^\!/ ) {
	403	for my $result ( @{$results} ) {
	404	my ( $class, $code ) = @{ $result->[0] };
	405	$c->state( $c->process( $class, $code ) );
	406	}
	407	}
	408	else {
	409	return 0 unless my $result = $results->[0];
	410	if ( $result->[2] ) {
	411	$c->log->debug(qq/Couldn't forward "$command" to regex action/)
	412	if $c->debug;
	413	return 0;
	414	}
	415	my ( $class, $code ) = @{ $result->[0] };
	416	$class = $c->components->{$class} \|\| $class;
	417	$c->state( $c->process( $class, $code ) );
7e5adedd	418	}
fc7ec1d9	419	}
fc7ec1d9	420	else {
b768faa3	421	my $class = $command;
fc7ec1d9	422	if ( $class =~ /[^\w\:]/ ) {
	423	$c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
	424	return 0;
	425	}
	426	my $method = shift \|\| 'process';
b768faa3	427	if ( my $code = $class->can($method) ) {
fc7ec1d9	428	$c->actions->{reverse}->{"$code"} = "$class->$method";
b768faa3	429	$c->state( $c->process( $class, $code ) );
fc7ec1d9	430	}
	431	else {
	432	$c->log->debug(qq/Couldn't forward to "$class->$method"/)
	433	if $c->debug;
	434	return 0;
	435	}
	436	}
b768faa3	437	return $c->state;
fc7ec1d9	438	}
fc7ec1d9	439
23f9d934	440	=item $c->handler($r)
fc7ec1d9	441
	442	Handles the request.
	443
	444	=cut
	445
	446	sub handler {
	447	my ( $class, $r ) = @_;
	448
	449	# Always expect worst case!
	450	my $status = -1;
	451	eval {
	452	my $handler = sub {
eb9ff8f4	453	my $c = $class->prepare($r);
	454	my $action = $c->req->action;
	455	my $namespace = '';
	456	$namespace = join '/', @{ $c->req->args } if $action eq '!default';
	457	unless ($namespace) {
0169d3a8	458	if ( my $result = $c->get_action($action) ) {
eb9ff8f4	459	$namespace = _class2prefix( $result->[0]->[0]->[0] );
7833fdfc	460	}
87e67021	461	}
0169d3a8	462	my $results = $c->get_action( $action, $namespace );
b768faa3	463	if ( @{$results} ) {
0169d3a8	464	for my $begin ( @{ $c->get_action( '!begin', $namespace ) } ) {
d6f060b7	465	$c->state( $c->process( @{ $begin->[0] } ) );
b768faa3	466	}
0169d3a8	467	for my $result ( @{ $c->get_action( $action, $namespace ) } ) {
d6f060b7	468	$c->state( $c->process( @{ $result->[0] } ) );
b768faa3	469	}
0169d3a8	470	for my $end ( @{ $c->get_action( '!end', $namespace ) } ) {
d6f060b7	471	$c->state( $c->process( @{ $end->[0] } ) );
b768faa3	472	}
fc7ec1d9	473	}
fc7ec1d9	474	else {
87e67021	475	my $path = $c->req->path;
	476	my $error = $path
	477	? qq/Unknown resource "$path"/
7833fdfc	478	: "No default action defined";
fc7ec1d9	479	$c->log->error($error) if $c->debug;
	480	$c->errors($error);
	481	}
	482	return $c->finalize;
	483	};
	484	if ( $class->debug ) {
	485	my $elapsed;
	486	( $elapsed, $status ) = $class->benchmark($handler);
	487	$elapsed = sprintf '%f', $elapsed;
	488	my $av = sprintf '%.3f', 1 / $elapsed;
	489	$class->log->info( "Request took $elapsed" . "s ($av/s)" );
	490	}
	491	else { $status = &$handler }
	492	};
	493	if ( my $error = $@ ) {
	494	chomp $error;
	495	$class->log->error(qq/Caught exception in engine "$error"/);
	496	}
	497	$COUNT++;
	498	return $status;
	499	}
	500
23f9d934	501	=item $c->prepare($r)
fc7ec1d9	502
23f9d934	503	Turns the engine-specific request (Apache, CGI...) into a Catalyst context.
fc7ec1d9	504
	505	=cut
	506
	507	sub prepare {
	508	my ( $class, $r ) = @_;
	509	my $c = bless {
	510	request => Catalyst::Request->new(
	511	{
	512	arguments => [],
	513	cookies => {},
	514	headers => HTTP::Headers->new,
	515	parameters => {},
	516	snippets => [],
	517	uploads => {}
	518	}
	519	),
	520	response => Catalyst::Response->new(
	521	{ cookies => {}, headers => HTTP::Headers->new, status => 200 }
	522	),
b768faa3	523	stash => {},
b768faa3	524	state => 0
fc7ec1d9	525	}, $class;
	526	if ( $c->debug ) {
	527	my $secs = time - $START \|\| 1;
	528	my $av = sprintf '%.3f', $COUNT / $secs;
	529	$c->log->debug('********************************');
	530	$c->log->debug("* Request $COUNT ($av/s) [$$]");
	531	$c->log->debug('********************************');
	532	$c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
	533	}
	534	$c->prepare_request($r);
	535	$c->prepare_path;
fc7ec1d9	536	$c->prepare_cookies;
fc7ec1d9	537	$c->prepare_headers;
0556eb49	538	$c->prepare_connection;
	539	my $method = $c->req->method \|\| '';
	540	my $path = $c->req->path \|\| '';
	541	my $hostname = $c->req->hostname \|\| '';
	542	my $address = $c->req->address \|\| '';
	543	$c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
	544	if $c->debug;
fc7ec1d9	545	$c->prepare_action;
fc7ec1d9	546	$c->prepare_parameters;
c85ff642	547
	548	if ( $c->debug && keys %{ $c->req->params } ) {
	549	my @params;
	550	for my $key ( keys %{ $c->req->params } ) {
b5524568	551	my $value = $c->req->params->{$key} \|\| '';
c85ff642	552	push @params, "$key=$value";
	553	}
	554	$c->log->debug( 'Parameters are "' . join( ' ', @params ) . '"' );
	555	}
fc7ec1d9	556	$c->prepare_uploads;
	557	return $c;
	558	}
	559
23f9d934	560	=item $c->prepare_action
fc7ec1d9	561
	562	Prepare action.
	563
	564	=cut
	565
	566	sub prepare_action {
	567	my $c = shift;
	568	my $path = $c->req->path;
	569	my @path = split /\//, $c->req->path;
	570	$c->req->args( \my @args );
	571	while (@path) {
7833fdfc	572	$path = join '/', @path;
0169d3a8	573	if ( my $result = ${ $c->get_action($path) }[0] ) {
fc7ec1d9	574
	575	# It's a regex
	576	if ($#$result) {
7e5adedd	577	my $match = $result->[1];
7e5adedd	578	my @snippets = @{ $result->[2] };
fc7ec1d9	579	$c->log->debug(qq/Requested action "$path" matched "$match"/)
	580	if $c->debug;
	581	$c->log->debug(
	582	'Snippets are "' . join( ' ', @snippets ) . '"' )
	583	if ( $c->debug && @snippets );
	584	$c->req->action($match);
	585	$c->req->snippets( \@snippets );
	586	}
	587	else {
	588	$c->req->action($path);
	589	$c->log->debug(qq/Requested action "$path"/) if $c->debug;
	590	}
	591	$c->req->match($path);
fc7ec1d9	592	last;
	593	}
	594	unshift @args, pop @path;
	595	}
	596	unless ( $c->req->action ) {
87e67021	597	$c->req->action('!default');
87e67021	598	$c->req->match('');
fc7ec1d9	599	}
5783a9a5	600	$c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
5783a9a5	601	if ( $c->debug && @args );
fc7ec1d9	602	}
fc7ec1d9	603
c9afa5fc	604	=item $c->prepare_connection
0556eb49	605
	606	Prepare connection.
	607
	608	=cut
	609
	610	sub prepare_connection { }
	611
c9afa5fc	612	=item $c->prepare_cookies
fc7ec1d9	613
	614	Prepare cookies.
	615
	616	=cut
	617
	618	sub prepare_cookies { }
	619
23f9d934	620	=item $c->prepare_headers
fc7ec1d9	621
	622	Prepare headers.
	623
	624	=cut
	625
	626	sub prepare_headers { }
	627
23f9d934	628	=item $c->prepare_parameters
fc7ec1d9	629
	630	Prepare parameters.
	631
	632	=cut
	633
	634	sub prepare_parameters { }
	635
23f9d934	636	=item $c->prepare_path
fc7ec1d9	637
	638	Prepare path and base.
	639
	640	=cut
	641
	642	sub prepare_path { }
	643
23f9d934	644	=item $c->prepare_request
fc7ec1d9	645
	646	Prepare the engine request.
	647
	648	=cut
	649
	650	sub prepare_request { }
	651
23f9d934	652	=item $c->prepare_uploads
fc7ec1d9	653
	654	Prepare uploads.
	655
	656	=cut
	657
	658	sub prepare_uploads { }
	659
23f9d934	660	=item $c->process($class, $coderef)
fc7ec1d9	661
	662	Process a coderef in given class and catch exceptions.
	663	Errors are available via $c->errors.
	664
	665	=cut
	666
	667	sub process {
	668	my ( $c, $class, $code ) = @_;
	669	my $status;
	670	eval {
	671	if ( $c->debug )
	672	{
	673	my $action = $c->actions->{reverse}->{"$code"} \|\| "$code";
	674	my $elapsed;
	675	( $elapsed, $status ) =
	676	$c->benchmark( $code, $class, $c, @{ $c->req->args } );
	677	$c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
	678	if $c->debug;
	679	}
	680	else { $status = &$code( $class, $c, @{ $c->req->args } ) }
	681	};
	682	if ( my $error = $@ ) {
	683	chomp $error;
	684	$error = qq/Caught exception "$error"/;
	685	$c->log->error($error);
	686	$c->errors($error) if $c->debug;
	687	return 0;
	688	}
	689	return $status;
	690	}
	691
c9afa5fc	692	=item $c->run
	693
	694	Starts the engine.
	695
	696	=cut
	697
	698	sub run { }
	699
23f9d934	700	=item $c->request
	701
	702	=item $c->req
fc7ec1d9	703
	704	Returns a C<Catalyst::Request> object.
	705
	706	my $req = $c->req;
	707
23f9d934	708	=item $c->response
	709
	710	=item $c->res
fc7ec1d9	711
	712	Returns a C<Catalyst::Response> object.
	713
	714	my $res = $c->res;
	715
23f9d934	716	=item $class->setup
fc7ec1d9	717
	718	Setup.
	719
	720	MyApp->setup;
	721
	722	=cut
	723
	724	sub setup {
	725	my $self = shift;
	726	$self->setup_components;
	727	if ( $self->debug ) {
	728	my $name = $self->config->{name} \|\| 'Application';
	729	$self->log->info("$name powered by Catalyst $Catalyst::VERSION");
	730	}
	731	}
	732
23f9d934	733	=item $class->setup_components
fc7ec1d9	734
	735	Setup components.
	736
	737	=cut
	738
	739	sub setup_components {
	740	my $self = shift;
	741
	742	# Components
	743	my $class = ref $self \|\| $self;
	744	eval <<"";
	745	package $class;
	746	import Module::Pluggable::Fast
	747	name => '_components',
	748	search => [
	749	'$class\::Controller', '$class\::C',
	750	'$class\::Model', '$class\::M',
	751	'$class\::View', '$class\::V'
	752	];
	753
	754	if ( my $error = $@ ) {
	755	chomp $error;
	756	$self->log->error(
	757	qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
	758	}
	759	$self->components( {} );
	760	for my $component ( $self->_components($self) ) {
	761	$self->components->{ ref $component } = $component;
	762	}
	763	$self->log->debug( 'Initialized components "'
	764	. join( ' ', keys %{ $self->components } )
	765	. '"' )
	766	if $self->debug;
	767	}
	768
23f9d934	769	=item $c->stash
fc7ec1d9	770
	771	Returns a hashref containing all your data.
	772
	773	$c->stash->{foo} \|\|= 'yada';
	774	print $c->stash->{foo};
	775
	776	=cut
	777
	778	sub stash {
	779	my $self = shift;
	780	if ( $_[0] ) {
	781	my $stash = $_[1] ? {@_} : $_[0];
	782	while ( my ( $key, $val ) = each %$stash ) {
	783	$self->{stash}->{$key} = $val;
	784	}
	785	}
	786	return $self->{stash};
	787	}
	788
	789	sub _prefix {
	790	my ( $class, $name ) = @_;
7833fdfc	791	my $prefix = _class2prefix($class);
	792	$name = "$prefix/$name" if $prefix;
	793	return $name;
	794	}
	795
	796	sub _class2prefix {
b768faa3	797	my $class = shift \|\| '';
b768faa3	798	$class =~ /^.::([MVC]\|Model\|View\|Controller)?::(.)$/;
87e67021	799	my $prefix = lc $2 \|\| '';
87e67021	800	$prefix =~ s/\:\:/\//g;
7833fdfc	801	return $prefix;
fc7ec1d9	802	}
fc7ec1d9	803
23f9d934	804	=back
23f9d934	805
fc7ec1d9	806	=head1 AUTHOR
	807
	808	Sebastian Riedel, C<sri@cpan.org>
	809
	810	=head1 COPYRIGHT
	811
	812	This program is free software, you can redistribute it and/or modify it under
	813	the same terms as Perl itself.
	814
	815	=cut
	816
	817	1;