--- /dev/null
+This file documents the revision history for Perl extension Catalyst.
+
+4.00 Sun Feb 27 22:00:00 2005
+ - more verbose debug messages, especially for forward()
+ - implemented prefixed prvate actions, icluding built in
+ !?default, !?begin and !?end
+ - new Catalyst::Manual::Intro
+ - new helpers, bin/catalyst
+ - helper api
+
+3.11 Wed Feb 23 21:00:00 2005
+ - added dependency to UNIVERSAL::require (Marcus Ramberg)
+ - added a little workaround for a warning in Catalyst::Test
+ (Marcus Ramberg)
+ - improved documentation for actions
+
+3.10 Thu Feb 19 20:00:00 2005
+ - removed roles management from Catalyst::Engine
+ and added it to Catalyst::Plugin::Authentication::CDBI
+
+3.04 Thu Feb 17 21:00:00 2005
+ - error reporting for app class
+ - no more engine debug messages
+ - class->method forwards get resolved now
+
+3.03 Wed Feb 16 23:00:00 2005
+ - friendlier statistics
+
+3.02 Wed Feb 16 22:00:00 2005
+ - fixed unintialized actions (Marcus Ramberg)
+
+3.01 Wed Feb 16 20:30:00 2005
+ - better statistics
+
+3.00 Wed Feb 16 20:00:00 2005
+ - real version number for CPAN.pm
+ - fixed redirect in CGI engine
+ - more statistics in debug logs
+ - ? prefix for forward()
+
+2.99_15 Wed Feb 02 22:00:00 2005
+ - support for short namespaces, MyApp::M, MyApp::V and MyApp::C
+ - Replaced "Catched" with "Caught" in Catalyst::Engine
+ (Gary Ashton Jones)
+ - replaced _ with ! for private actions
+ - added ? for prefixed actions
+ - misc improvememts
+
+2.99_14 Mon Jan 31 22:00:00 2005
+ - arguments for _default
+ - $c->entrance removed for more flexibility
+ - added $c->req->method
+
+2.99_13 Sun Jan 30 18:00:00 2005
+ - POD fixes and improvements
+
+2.99_12 Fri Jan 28 22:00:00 2005
+ - first development release
--- /dev/null
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'Catalyst',
+ VERSION_FROM => 'lib/Catalyst.pm',
+ EXE_FILES => ['bin/catalyst'],
+ PREREQ_PM => {
+ UNIVERSAL::require => 0,
+ CGI::Simple => 0,
+ Class::Accessor::Fast => 0,
+ Class::Data::Inheritable => 0,
+ HTML::Entities => 0,
+ HTTP::Headers => 0,
+ Module::Pluggable::Fast => 0
+ }
+);
+
+my $gabb =
+ int( rand(2) ) == 1
+ ? "Gabbana is the greatest!"
+ : "Gabbana is drunk again!";
+print "$gabb\n";
--- /dev/null
+NAME
+ Catalyst - The Elegant MVC Web Application Framework
+
+SYNOPSIS
+ # use the helper to start a new application
+ catalyst MyApp
+ cd MyApp
+
+ # add models, views, controllers
+ bin/create model Something
+ bin/create view Stuff
+ bin/create controller Yada
+
+ # built in testserver
+ bin/server
+
+ # command line interface
+ bin/test /yada
+
+ See also L<Catalyst::Manual::Intro>
+
+ use Catalyst;
+
+ use Catalyst qw/My::Module My::OtherModule/;
+
+ use Catalyst '-Debug';
+
+ use Catalyst qw/-Debug -Engine=CGI/;
+
+ __PACKAGE__->action( '!default' => sub { $_[1]->res->output('Hello') } );
+
+ __PACKAGE__->action(
+ 'index.html' => sub {
+ my ( $self, $c ) = @_;
+ $c->res->output('Hello');
+ $c->forward('_foo');
+ }
+ );
+
+ __PACKAGE__->action(
+ '/^product[_]*(\d*).html$/' => sub {
+ my ( $self, $c ) = @_;
+ $c->stash->{template} = 'product.tt';
+ $c->stash->{product} = $c->req->snippets->[0];
+ }
+ );
+
+DESCRIPTION
+ Catalyst is based upon Maypole, which you should consider for smaller
+ projects.
+
+ The key concept of Catalyst is DRY (Don't Repeat Yourself).
+
+ See Catalyst::Manual for more documentation.
+
+ Omit the Catalyst::Plugin:: prefix from plugins. So
+ Catalyst::Plugin::My::Module becomes My::Module.
+
+ use Catalyst 'My::Module';
+
+ You can also set special flags like -Debug and -Engine.
+
+ use Catalyst qw/-Debug My::Module/;
+
+ The position of plugins and flags in the chain is important, because
+ they are loaded in the same order they appear.
+
+ -Debug
+ use Catalyst '-Debug';
+
+ is equivalent to
+
+ use Catalyst;
+ sub debug { 1 }
+
+ -Engine
+ Force Catalyst to use a specific engine. Omit the Catalyst::Engine::
+ prefix.
+
+ use Catalyst '-Engine=CGI';
+
+ METHODS
+ debug
+ Overload to enable debug messages.
+
+ config
+ Returns a hashref containing your applications settings.
+
+SEE ALSO
+ Catalyst::Manual, Catalyst::Test, Catalyst::Request, Catalyst::Response,
+ Catalyst::Engine
+
+AUTHOR
+ Sebastian Riedel, "sri@oook.de"
+
+THANK YOU
+ David Naughton, Gary Ashton Jones, Marcus Ramberg and all the others
+ who've helped.
+
+LICENSE
+ This library is free software . You can redistribute it and/or modify it
+ under the same terms as perl itself.
+
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Getopt::Long;
+use Pod::Usage;
+use Catalyst::Helper;
+
+my $help = 0;
+
+GetOptions( 'help|?' => \$help );
+
+pod2usage(1) if ( $help || !$ARGV[0] );
+
+my $helper = Catalyst::Helper->new;
+pod2usage(1) unless $helper->mk_app( $ARGV[0] );
+
+1;
+__END__
+
+=head1 NAME
+
+catalyst - Bootstrap a Catalyst application
+
+=head1 SYNOPSIS
+
+catalyst [options] application-name
+
+ Options:
+ -help display this help and exits
+
+ application-name has to be a valid Perl module name and can include ::
+
+ Examples:
+ catalyst My::App
+ catalyst MyApp
+
+=head1 DESCRIPTION
+
+Bootstrap a Catalyst application.
+
+=head1 AUTHOR
+
+Sebastian Riedel Sebastian Riedel, C<sri@oook.de>
+
+=head1 COPYRIGHT
+
+Copyright 2004 Sebastian Riedel. All rights reserved.
+
+This library is free software. You can redistribute it and/or modify it under
+the same terms as perl itself.
+
+=cut
--- /dev/null
+package Catalyst;
+
+use strict;
+use base 'Class::Data::Inheritable';
+use UNIVERSAL::require;
+use Catalyst::Log;
+
+__PACKAGE__->mk_classdata($_) for qw/_config log/;
+
+our $VERSION = '4.00';
+our @ISA;
+
+=head1 NAME
+
+Catalyst - The Elegant MVC Web Application Framework
+
+=head1 SYNOPSIS
+
+ # use the helper to start a new application
+ catalyst MyApp
+ cd MyApp
+
+ # add models, views, controllers
+ bin/create model Something
+ bin/create view Stuff
+ bin/create controller Yada
+
+ # built in testserver
+ bin/server
+
+ # command line interface
+ bin/test /yada
+
+
+ See also L<Catalyst::Manual::Intro>
+
+
+ use Catalyst;
+
+ use Catalyst qw/My::Module My::OtherModule/;
+
+ use Catalyst '-Debug';
+
+ use Catalyst qw/-Debug -Engine=CGI/;
+
+ __PACKAGE__->action( '!default' => sub { $_[1]->res->output('Hello') } );
+
+ __PACKAGE__->action(
+ 'index.html' => sub {
+ my ( $self, $c ) = @_;
+ $c->res->output('Hello');
+ $c->forward('_foo');
+ }
+ );
+
+ __PACKAGE__->action(
+ '/^product[_]*(\d*).html$/' => sub {
+ my ( $self, $c ) = @_;
+ $c->stash->{template} = 'product.tt';
+ $c->stash->{product} = $c->req->snippets->[0];
+ }
+ );
+
+=head1 DESCRIPTION
+
+Catalyst is based upon L<Maypole>, which you should consider for smaller
+projects.
+
+The key concept of Catalyst is DRY (Don't Repeat Yourself).
+
+See L<Catalyst::Manual> for more documentation.
+
+Omit the Catalyst::Plugin:: prefix from plugins.
+So Catalyst::Plugin::My::Module becomes My::Module.
+
+ use Catalyst 'My::Module';
+
+You can also set special flags like -Debug and -Engine.
+
+ use Catalyst qw/-Debug My::Module/;
+
+The position of plugins and flags in the chain is important,
+because they are loaded in the same order they appear.
+
+=head2 -Debug
+
+ use Catalyst '-Debug';
+
+is equivalent to
+
+ use Catalyst;
+ sub debug { 1 }
+
+=head2 -Engine
+
+Force Catalyst to use a specific engine.
+Omit the Catalyst::Engine:: prefix.
+
+ use Catalyst '-Engine=CGI';
+
+=head2 METHODS
+
+=head3 debug
+
+Overload to enable debug messages.
+
+=cut
+
+sub debug { 0 }
+
+=head3 config
+
+Returns a hashref containing your applications settings.
+
+=cut
+
+sub config {
+ my $self = shift;
+ $self->_config( {} ) unless $self->_config;
+ if ( $_[0] ) {
+ my $config = $_[1] ? {@_} : $_[0];
+ while ( my ( $key, $val ) = each %$config ) {
+ $self->_config->{$key} = $val;
+ }
+ }
+ return $self->_config;
+}
+
+sub import {
+ my ( $self, @options ) = @_;
+ my $caller = caller(0);
+
+ # Class
+ {
+ no strict 'refs';
+ *{"$caller\::handler"} =
+ sub { Catalyst::Engine::handler( $caller, @_ ) };
+ push @{"$caller\::ISA"}, $self;
+ }
+ $self->log( Catalyst::Log->new );
+
+ # Options
+ my $engine =
+ $ENV{MOD_PERL} ? 'Catalyst::Engine::Apache' : 'Catalyst::Engine::CGI';
+ foreach (@options) {
+ if (/^\-Debug$/) {
+ no warnings;
+ no strict 'refs';
+ *{"$self\::debug"} = sub { 1 };
+ $caller->log->debug('Debug messages enabled');
+ }
+ elsif (/^-Engine=(.*)$/) { $engine = "Catalyst::Engine::$1" }
+ elsif (/^-.*$/) { $caller->log->error(qq/Unknown flag "$_"/) }
+ else {
+ my $plugin = "Catalyst::Plugin::$_";
+
+ # Plugin caller should be our application class
+ eval "package $caller; require $plugin";
+ if ($@) {
+ $caller->log->error(qq/Couldn't load plugin "$plugin", "$@"/);
+ }
+ else {
+ $caller->log->debug(qq/Loaded plugin "$plugin"/)
+ if $caller->debug;
+ unshift @ISA, $plugin;
+ }
+ }
+ }
+
+ # Engine
+ $engine = "Catalyst::Engine::$ENV{CATALYST_ENGINE}"
+ if $ENV{CATALYST_ENGINE};
+ $engine->require;
+ die qq/Couldn't load engine "$engine", "$@"/ if $@;
+ push @ISA, $engine;
+ $caller->log->debug(qq/Loaded engine "$engine"/) if $caller->debug;
+}
+
+=head1 SEE ALSO
+
+L<Catalyst::Manual>, L<Catalyst::Test>, L<Catalyst::Request>,
+L<Catalyst::Response>, L<Catalyst::Engine>
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri@oook.de>
+
+=head1 THANK YOU
+
+David Naughton, Gary Ashton Jones, Marcus Ramberg and all the others who've
+helped.
+
+=head1 LICENSE
+
+This library is free software . You can redistribute it and/or modify it under
+the same terms as perl itself.
+
+=cut
+
+1;
--- /dev/null
+package Catalyst::Base;
+
+use strict;
+use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
+use NEXT;
+
+__PACKAGE__->mk_classdata('_config');
+
+=head1 NAME
+
+Catalyst::Base - Catalyst Universal Base Class
+
+=head1 SYNOPSIS
+
+ # lib/MyApp/Model/Something.pm
+ package MyApp::Model::Something;
+
+ use base 'Catalyst::Base';
+
+ __PACKAGE__->config( foo => 'bar' );
+
+ sub test {
+ my $self = shift;
+ return $self->{foo};
+ }
+
+ sub forward_to_me {
+ my ( $self, $c ) = @_;
+ $c->response->output( $self->{foo} );
+ }
+
+ 1;
+
+ # Methods can be a request step
+ $c->forward(qw/MyApp::Model::Something forward_to_me/);
+ MyApp->action( 'index.html' => \&MyApp::Model::Something::forward_to_me );
+
+ # Or just methods
+ print $c->comp('MyApp::Model::Something')->test;
+
+ print $c->comp('MyApp::Model::Something')->{foo};
+
+=head1 DESCRIPTION
+
+This is the universal base class for Catalyst components
+(Model/View/Controller).
+
+It provides you with a generic new() for instantiation through Catalyst's
+component loader with config() support and a process() method placeholder.
+
+=head2 METHODS
+
+=cut
+
+sub new {
+ my ( $self, $c ) = @_;
+ return $self->NEXT::new( $self->config );
+}
+
+=head3 config
+
+=cut
+
+sub config {
+ my $self = shift;
+ $self->_config( {} ) unless $self->_config;
+ if ( $_[0] ) {
+ my $config = $_[1] ? {@_} : $_[0];
+ while ( my ( $key, $val ) = each %$config ) {
+ $self->_config->{$key} = $val;
+ }
+ }
+ return $self->_config;
+}
+
+=head3 process
+
+=cut
+
+sub process { 1 }
+
+=head1 SEE ALSO
+
+L<Catalyst>.
+
+=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;
--- /dev/null
+package Catalyst::Engine;
+
+use strict;
+use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
+use UNIVERSAL::require;
+use B;
+use Data::Dumper;
+use HTML::Entities;
+use HTTP::Headers;
+use Time::HiRes qw/gettimeofday tv_interval/;
+use Catalyst::Request;
+use Catalyst::Response;
+
+require Module::Pluggable::Fast;
+
+$Data::Dumper::Terse = 1;
+
+__PACKAGE__->mk_classdata($_) for qw/actions components/;
+__PACKAGE__->mk_accessors(qw/request response/);
+
+__PACKAGE__->actions(
+ { plain => {}, regex => {}, compiled => {}, reverse => {} } );
+
+*comp = \&component;
+*req = \&request;
+*res = \&response;
+
+our $COUNT = 1;
+our $START = time;
+
+=head1 NAME
+
+Catalyst::Engine - The Catalyst Engine
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+=head2 METHODS
+
+=head3 action
+
+Add one or more actions.
+
+ $c->action( '!foo' => sub { $_[1]->res->output('Foo!') } );
+
+Get an action's class and coderef.
+
+ my ($class, $code) = @{ $c->action('foo') };
+
+Get a list of available actions.
+
+ my @actions = $c->action;
+
+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 ) {
+ my $class = B::svref_2object($code)->STASH->NAME;
+ my $caller = caller(0);
+ if ( $name =~ /^\/(.*)\/$/ ) {
+ my $regex = $1;
+ $self->actions->{compiled}->{qr/$regex/} = $name;
+ $self->actions->{regex}->{$name} = [ $class, $code ];
+ }
+ elsif ( $name =~ /^\?(.*)$/ ) {
+ $name = $1;
+ $name = _prefix( $caller, $name );
+ $self->actions->{plain}->{$name} = [ $class, $code ];
+ }
+ elsif ( $name =~ /^\!\?(.*)$/ ) {
+ $name = $1;
+ $name = _prefix( $caller, $name );
+ $name = "\!$name";
+ $self->actions->{plain}->{$name} = [ $class, $code ];
+ }
+ else { $self->actions->{plain}->{$name} = [ $class, $code ] }
+ $self->actions->{reverse}->{"$code"} = $name;
+ $self->log->debug(
+ qq/"$caller" defined "$name" as "$code" from "$class"/)
+ if $self->debug;
+ }
+ }
+ elsif ($action) {
+ if ( my $p = $self->actions->{plain}->{$action} ) { return [$p] }
+ elsif ( my $r = $self->actions->{regex}->{$action} ) { return [$r] }
+ else {
+ while ( my ( $regex, $name ) =
+ each %{ $self->actions->{compiled} } )
+ {
+ if ( $action =~ $regex ) {
+ my @snippets;
+ for my $i ( 1 .. 9 ) {
+ no strict 'refs';
+ last unless ${$i};
+ push @snippets, ${$i};
+ }
+ return [ $name, \@snippets ];
+ }
+ }
+ }
+ return 0;
+ }
+ else {
+ return (
+ keys %{ $self->actions->{plain} },
+ keys %{ $self->actions->{regex} }
+ );
+ }
+}
+
+=head3 benchmark
+
+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;
+}
+
+=head3 component (comp)
+
+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;
+ }
+ }
+}
+
+=head3 errors
+
+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};
+}
+
+=head3 finalize
+
+Finalize request.
+
+=cut
+
+sub finalize {
+ my $c = shift;
+ 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>
+
+ }
+ 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);
+ }
+ $c->res->headers->content_length( length $c->res->output );
+ my $status = $c->finalize_headers;
+ $c->finalize_output;
+ return $status;
+}
+
+=head3 finalize_headers
+
+Finalize headers.
+
+=cut
+
+sub finalize_headers { }
+
+=head3 finalize_output
+
+Finalize output.
+
+=cut
+
+sub finalize_output { }
+
+=head3 forward
+
+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;
+ }
+ if ( $command =~ /^\?(.*)$/ ) {
+ $command = $1;
+ my $caller = caller(0);
+ $command = _prefix( $caller, $command );
+ }
+ elsif ( $command =~ /^\!\?(.*)$/ ) {
+ $command = $1;
+ my $caller = caller(0);
+ $command = _prefix( $caller, $command );
+ $command = "\!$command";
+ }
+ my ( $class, $code );
+ if ( my $action = $c->action($command) ) {
+ ( $class, $code ) = @{ $action->[0] };
+ }
+ else {
+ $class = $command;
+ if ( $class =~ /[^\w\:]/ ) {
+ $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
+ return 0;
+ }
+ my $method = shift || 'process';
+ if ( $code = $class->can($method) ) {
+ $c->actions->{reverse}->{"$code"} = "$class->$method";
+ }
+ else {
+ $c->log->debug(qq/Couldn't forward to "$class->$method"/)
+ if $c->debug;
+ return 0;
+ }
+ }
+ $class = $c->components->{$class} || $class;
+ return $c->process( $class, $code );
+}
+
+=head3 handler
+
+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);
+ if ( $c->req->action ) {
+ my ( $begin, $end );
+ if ( my $prefix = $c->req->args->[0] ) {
+ if ( $c->actions->{plain}->{"\!$prefix/begin"} ) {
+ $begin = "\!$prefix/begin";
+ }
+ elsif ( $c->actions->{plain}->{'!begin'} ) {
+ $begin = '!begin';
+ }
+ if ( $c->actions->{plain}->{"\!$prefix/end"} ) {
+ $end = "\!$prefix/end";
+ }
+ elsif ( $c->actions->{plain}->{'!end'} ) { $end = '!end' }
+ }
+ $c->forward($begin) if $begin;
+ $c->forward( $c->req->action ) if $c->req->action;
+ $c->forward($end) if $end;
+ }
+ else {
+ my $action = $c->req->path;
+ my $error = $action
+ ? qq/Unknown resource "$action"/
+ : "Congratulations, you're on Catalyst!";
+ $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;
+}
+
+=head3 prepare
+
+Turns the 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 => {}
+ }, $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;
+ my $path = $c->request->path;
+ $c->log->debug(qq/Requested path "$path"/) if $c->debug;
+ $c->prepare_cookies;
+ $c->prepare_headers;
+ $c->prepare_action;
+ $c->prepare_parameters;
+ $c->prepare_uploads;
+ return $c;
+}
+
+=head3 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) {
+ my $path = join '/', @path;
+ if ( my $result = $c->action($path) ) {
+
+ # It's a regex
+ if ($#$result) {
+ my $match = $result->[0];
+ my @snippets = @{ $result->[1] };
+ $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);
+ $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
+ if ( $c->debug && @args );
+ last;
+ }
+ unshift @args, pop @path;
+ }
+ unless ( $c->req->action ) {
+ my $prefix = $c->req->args->[0];
+ if ( $prefix && $c->actions->{plain}->{"\!$prefix/default"} ) {
+ $c->req->match('');
+ $c->req->action("\!$prefix/default");
+ $c->log->debug('Using prefixed default action') if $c->debug;
+ }
+ elsif ( $c->actions->{plain}->{'!default'} ) {
+ $c->req->match('');
+ $c->req->action('!default');
+ $c->log->debug('Using default action') if $c->debug;
+ }
+ }
+}
+
+=head3 prepare_cookies;
+
+Prepare cookies.
+
+=cut
+
+sub prepare_cookies { }
+
+=head3 prepare_headers
+
+Prepare headers.
+
+=cut
+
+sub prepare_headers { }
+
+=head3 prepare_parameters
+
+Prepare parameters.
+
+=cut
+
+sub prepare_parameters { }
+
+=head3 prepare_path
+
+Prepare path and base.
+
+=cut
+
+sub prepare_path { }
+
+=head3 prepare_request
+
+Prepare the engine request.
+
+=cut
+
+sub prepare_request { }
+
+=head3 prepare_uploads
+
+Prepare uploads.
+
+=cut
+
+sub prepare_uploads { }
+
+=head3 process
+
+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;
+}
+
+=head3 remove_action
+
+Remove an action.
+
+ $c->remove_action('!foo');
+
+=cut
+
+sub remove_action {
+ my ( $self, $action ) = @_;
+ if ( delete $self->actions->{regex}->{$action} ) {
+ while ( my ( $regex, $name ) = each %{ $self->actions->{compiled} } ) {
+ if ( $name eq $action ) {
+ delete $self->actions->{compiled}->{$regex};
+ last;
+ }
+ }
+ }
+ else {
+ delete $self->actions->{plain}->{$action};
+ }
+}
+
+=head3 request (req)
+
+Returns a C<Catalyst::Request> object.
+
+ my $req = $c->req;
+
+=head3 response (res)
+
+Returns a C<Catalyst::Response> object.
+
+ my $res = $c->res;
+
+=head3 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");
+ }
+}
+
+=head3 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;
+}
+
+=head3 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 ) = @_;
+ $class =~ /^.*::[(M)(Model)(V)(View)(C)(Controller)]+::(.*)$/;
+ my $prefix = lc $1 || '';
+ $prefix =~ s/\:\:/_/g;
+ $name = "$prefix/$name" if $prefix;
+ return $name;
+}
+
+=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;
--- /dev/null
+package Catalyst::Engine::Apache;
+
+use strict;
+use mod_perl;
+use constant MP2 => $mod_perl::VERSION >= 1.99;
+use base 'Catalyst::Engine';
+use URI;
+
+# mod_perl
+if (MP2) {
+ require Apache2;
+ require Apache::RequestIO;
+ require Apache::RequestRec;
+ require Apache::SubRequest;
+ require Apache::RequestUtil;
+ require APR::URI;
+ require Apache::URI;
+}
+else { require Apache }
+
+# libapreq
+require Apache::Request;
+require Apache::Cookie;
+require Apache::Upload if MP2;
+
+__PACKAGE__->mk_accessors(qw/apache_request original_request/);
+
+=head1 NAME
+
+Catalyst::Engine::Apache - Catalyst Apache Engine
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+The Apache Engine.
+
+=head2 METHODS
+
+=head3 apache_request
+
+Returns an C<Apache::Request> object.
+
+=head3 original_request
+
+Returns the original Apache request object.
+
+=head2 OVERLOADED METHODS
+
+This class overloads some methods from C<Catalyst::Engine>.
+
+=head3 finalize_headers
+
+=cut
+
+sub finalize_headers {
+ my $c = shift;
+ for my $name ( $c->response->headers->header_field_names ) {
+ next if $name =~ /Content-Type/i;
+ $c->original_request->headers_out->set(
+ $name => $c->response->headers->header($name) );
+ }
+ while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
+ my %cookie = ( -name => $name, -value => $cookie->{value} );
+ $cookie->{-expires} = $cookie->{expires} if $cookie->{expires};
+ $cookie->{-domain} = $cookie->{domain} if $cookie->{domain};
+ $cookie->{-path} = $cookie->{path} if $cookie->{path};
+ $cookie->{-secure} = $cookie->{secure} if $cookie->{secure};
+ my $cookie = Apache::Cookie->new( $c->original_request, %cookie );
+ MP2
+ ? $c->apache_request->err_headers_out->add(
+ 'Set-Cookie' => $cookie->as_string )
+ : $cookie->bake;
+ }
+ $c->original_request->status( $c->response->status );
+ $c->original_request->content_type( $c->response->headers->content_type
+ || 'text/plain' );
+ MP2 || $c->apache_request->send_http_header;
+ return 0;
+}
+
+=head3 finalize_output
+
+=cut
+
+sub finalize_output {
+ my $c = shift;
+ $c->original_request->print( $c->response->{output} );
+}
+
+=head3 prepare_cookies
+
+=cut
+
+sub prepare_cookies {
+ my $c = shift;
+ MP2
+ ? $c->req->cookies( { Apache::Cookie->fetch } )
+ : $c->req->cookies(
+ { Apache::Cookie->new( $c->apache_request )->fetch } );
+}
+
+=head3 prepare_headers
+
+=cut
+
+sub prepare_headers {
+ my $c = shift;
+ $c->req->method( $c->apache_request->method );
+ $c->req->headers->header( %{ $c->apache_request->headers_in } );
+}
+
+=head3 prepare_parameters
+
+=cut
+
+sub prepare_parameters {
+ my $c = shift;
+ my %args;
+ foreach my $key ( $c->apache_request->param ) {
+ my @values = $c->apache_request->param($key);
+ $args{$key} = @values == 1 ? $values[0] : \@values;
+ }
+ $c->req->parameters( \%args );
+}
+
+=head3 prepare_path
+
+=cut
+
+sub prepare_path {
+ my $c = shift;
+ $c->req->path( $c->apache_request->uri );
+ my $loc = $c->apache_request->location;
+ no warnings 'uninitialized';
+ $c->req->{path} =~ s/^($loc)?\///;
+ my $base = URI->new;
+ $base->scheme( $c->apache_request->protocol =~ /HTTPS/ ? 'https' : 'http' );
+ $base->host( $c->apache_request->hostname );
+ $base->port( $c->apache_request->get_server_port );
+ $base->path( $c->apache_request->location );
+ $c->req->base( $base->as_string );
+}
+
+=head3 prepare_request
+
+=cut
+
+sub prepare_request {
+ my ( $c, $r ) = @_;
+ $c->apache_request( Apache::Request->new($r) );
+ $c->original_request($r);
+}
+
+=head3 prepare_uploads
+
+=cut
+
+sub prepare_uploads {
+ my $c = shift;
+ for my $upload ( $c->apache_request->upload ) {
+ $upload = $c->apache_request->upload($upload) if MP2;
+ $c->req->uploads->{ $upload->name } = {
+ fh => $upload->fh,
+ filename => $upload->filename,
+ size => $upload->size,
+ type => $upload->type
+ };
+ }
+}
+
+=head1 SEE ALSO
+
+L<Catalyst>.
+
+=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;
--- /dev/null
+package Catalyst::Engine::CGI;
+
+use strict;
+use base 'Catalyst::Engine';
+use URI;
+
+require CGI::Simple;
+require CGI::Cookie;
+
+__PACKAGE__->mk_accessors('cgi');
+
+=head1 NAME
+
+Catalyst::Engine::CGI - The CGI Engine
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+This is the CGI engine for Catalyst.
+
+=head2 METHODS
+
+=head3 run
+
+To be called from a CGI script to start the Catalyst application.
+
+=head3 cgi
+
+This config parameter contains the C<CGI::Simple> object.
+
+=head2 OVERLOADED METHODS
+
+This class overloads some methods from C<Catalyst>.
+
+=head3 finalize_headers
+
+=cut
+
+sub finalize_headers {
+ my $c = shift;
+ my %headers = ( -nph => 1 );
+ $headers{-status} = $c->response->status if $c->response->status;
+ for my $name ( $c->response->headers->header_field_names ) {
+ $headers{"-$name"} = $c->response->headers->header($name);
+ }
+ my @cookies;
+ while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
+ push @cookies, $c->cgi->cookie(
+ -name => $name,
+ -value => $cookie->{value},
+ -expires => $cookie->{expires},
+ -domain => $cookie->{domain},
+ -path => $cookie->{path},
+ -secure => $cookie->{secure} || 0
+ );
+ }
+ $headers{-cookie} = \@cookies if @cookies;
+ print $c->cgi->header(%headers);
+}
+
+=head3 finalize_output
+
+=cut
+
+sub finalize_output {
+ my $c = shift;
+ print $c->response->output;
+}
+
+=head3 prepare_cookies
+
+=cut
+
+sub prepare_cookies { shift->req->cookies( { CGI::Cookie->fetch } ) }
+
+=head3 prepare_headers
+
+=cut
+
+sub prepare_headers {
+ my $c = shift;
+ $c->req->method( $c->cgi->request_method );
+ for my $header ( $c->cgi->http ) {
+ ( my $field = $header ) =~ s/^HTTPS?_//;
+ $c->req->headers->header( $field => $c->cgi->http($header) );
+ }
+}
+
+=head3 prepare_parameters
+
+=cut
+
+sub prepare_parameters {
+ my $c = shift;
+ my %vars = $c->cgi->Vars;
+ while ( my ( $key, $value ) = each %vars ) {
+ my @values = split "\0", $value;
+ $vars{$key} = @values <= 1 ? $values[0] : \@values;
+ }
+ $c->req->parameters( {%vars} );
+}
+
+=head3 prepare_path
+
+=cut
+
+sub prepare_path {
+ my $c = shift;
+ $c->req->path( $c->cgi->url( -absolute => 1, -path_info => 1 ) );
+ my $loc = $c->cgi->url( -absolute => 1 );
+ no warnings 'uninitialized';
+ $c->req->{path} =~ s/^($loc)?\///;
+ $c->req->{path} .= '/' if $c->req->path eq $loc;
+ my $base = $c->cgi->url;
+ $base = URI->new($base);
+ $base->path('/') if ( $ENV{CATALYST_TEST} || !$base->path );
+ $c->req->base( $base->as_string );
+}
+
+=head3 prepare_request
+
+=cut
+
+sub prepare_request { shift->cgi( CGI::Simple->new ) }
+
+=head3 prepare_uploads
+
+=cut
+
+sub prepare_uploads {
+ my $c = shift;
+ for my $name ( $c->cgi->upload ) {
+ my $filename = $c->req->params->{$name};
+ $c->req->uploads->{$name} = {
+ fh => $c->cgi->upload($filename),
+ filename => $filename,
+ size => $c->cgi->upload_info( $filename, 'size' ),
+ type => $c->cgi->upload_info( $filename, 'mime' )
+ };
+ }
+}
+
+sub run { shift->handler }
+
+=head1 SEE ALSO
+
+L<Catalyst>.
+
+=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;
+## Please see file perltidy.ERR
--- /dev/null
+package Catalyst::Helper;
+
+use strict;
+use base 'Class::Accessor::Fast';
+use File::Spec;
+use File::Path;
+use IO::File;
+use FindBin;
+
+=head1 NAME
+
+Catalyst::Helper - Bootstrap a Catalyst application
+
+=head1 SYNOPSIS
+
+See L<Catalyst::Manual::Intro>
+
+=head1 DESCRIPTION
+
+Bootstrap a Catalyst application.
+
+=head2 METHODS
+
+=head3 mk_app
+
+=cut
+
+sub mk_app {
+ my ( $self, $name ) = @_;
+ return 0 if $name =~ /[^\w\:]/;
+ $self->{name} = $name;
+ $self->{dir} = $name;
+ $self->{dir} =~ s/\:\:/-/g;
+ $self->_mk_dirs;
+ $self->_mk_appclass;
+ $self->_mk_makefile;
+ $self->_mk_apptest;
+ $self->_mk_server;
+ $self->_mk_test;
+ $self->_mk_create;
+ return 1;
+}
+
+sub _mk_dirs {
+ my $self = shift;
+ mkpath $self->{dir} unless -d $self->{dir};
+ $self->{bin} = File::Spec->catdir( $self->{dir}, 'bin' );
+ mkpath $self->{bin};
+ $self->{lib} = File::Spec->catdir( $self->{dir}, 'lib' );
+ mkpath $self->{lib};
+ $self->{root} = File::Spec->catdir( $self->{dir}, 'root' );
+ mkpath $self->{root};
+ $self->{t} = File::Spec->catdir( $self->{dir}, 't' );
+ mkpath $self->{t};
+ $self->{class} = File::Spec->catdir( split( /\:\:/, $self->{name} ) );
+ $self->{mod} = File::Spec->catdir( $self->{lib}, $self->{class} );
+ mkpath $self->{mod};
+ $self->{m} = File::Spec->catdir( $self->{mod}, 'M' );
+ mkpath $self->{m};
+ $self->{v} = File::Spec->catdir( $self->{mod}, 'V' );
+ mkpath $self->{v};
+ $self->{c} = File::Spec->catdir( $self->{mod}, 'C' );
+ mkpath $self->{c};
+ $self->{base} = File::Spec->rel2abs( $self->{dir} );
+}
+
+sub _mk_appclass {
+ my $self = shift;
+ my $mod = $self->{mod};
+ my $name = $self->{name};
+ my $base = $self->{base};
+ my $class = IO::File->new("> $mod.pm")
+ or die qq/Couldn't open "$mod.pm", "$!"/;
+ print $class <<"EOF";
+package $name;
+
+use strict;
+use Catalyst qw/-Debug/;
+
+our \$VERSION = '0.01';
+
+$name->config(
+ name => '$name',
+ root => '$base/root',
+);
+
+$name->action(
+
+ '!default' => sub {
+ my ( \$self, \$c ) = \@_;
+ \$c->res->output('Congratulations, $name is on Catalyst!');
+ },
+
+);
+
+=head1 NAME
+
+$name - A very nice application
+
+=head1 SYNOPSIS
+
+ Very simple to use
+
+=head1 DESCRIPTION
+
+Very nice application.
+
+=head1 AUTHOR
+
+Clever guy
+
+=head1 LICENSE
+
+This library is free software . You can redistribute it and/or modify it under
+the same terms as perl itself.
+
+=cut
+
+1;
+EOF
+}
+
+sub _mk_makefile {
+ my $self = shift;
+ my $name = $self->{name};
+ my $dir = $self->{dir};
+ my $class = $self->{class};
+ my $makefile = IO::File->new("> $dir/Makefile.PL")
+ or die qq/Couldn't open "$dir\/Makefile.PL", "$!"/;
+ print $makefile <<"EOF";
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => '$name',
+ VERSION_FROM => 'lib/$class.pm',
+ PREREQ_PM => { Catalyst => 0 }
+);
+EOF
+}
+
+sub _mk_apptest {
+ my $self = shift;
+ my $t = $self->{t};
+ my $name = $self->{name};
+ my $test = IO::File->new("> $t/01app.t")
+ or die qq/Couldn't open "$t\/01app.t", "$!"/;
+ print $test <<"EOF";
+use Test::More tests => 2;
+use_ok( Catalyst::Test, '$name' );
+
+ok( request('/')->is_success );
+EOF
+}
+
+sub _mk_server {
+ my $self = shift;
+ my $name = $self->{name};
+ my $bin = $self->{bin};
+ my $server = IO::File->new("> $bin/server")
+ or die qq/Could't open "$bin\/server", "$!"/;
+ print $server <<"EOF";
+#!/usr/bin/perl -w
+
+use strict;
+use Getopt::Long;
+use Pod::Usage;
+use FindBin;
+use lib "\$FindBin::Bin/../lib";
+use Catalyst::Test '$name';
+
+my \$help = 0;
+my \$port = 3000;
+
+GetOptions( 'help|?' => \\\$help, 'port=s' => \\\$port );
+
+pod2usage(1) if \$help;
+
+Catalyst::Test::server(\$port);
+
+1;
+__END__
+
+=head1 NAME
+
+server - Catalyst Testserver
+
+=head1 SYNOPSIS
+
+server [options]
+
+ Options:
+ -help display this help and exits
+ -port port (defaults to 3000)
+
+=head1 DESCRIPTION
+
+Run a Catalyst Testserver for this application.
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri\@oook.de>
+
+=head1 COPYRIGHT
+
+Copyright 2004 Sebastian Riedel. All rights reserved.
+
+This library is free software. You can redistribute it and/or modify it under
+the same terms as perl itself.
+
+=cut
+EOF
+ chmod 0700, "$bin/server";
+}
+
+sub _mk_test {
+ my $self = shift;
+ my $name = $self->{name};
+ my $bin = $self->{bin};
+ my $test = IO::File->new("> $bin/test")
+ or die qq/Could't open "$bin\/test", "$!"/;
+ print $test <<"EOF";
+#!/usr/bin/perl -w
+
+use strict;
+use Getopt::Long;
+use Pod::Usage;
+use FindBin;
+use lib "\$FindBin::Bin/../lib";
+
+my \$help = 0;
+
+GetOptions( 'help|?' => \\\$help );
+
+pod2usage(1) if ( \$help || !\$ARGV[0] );
+
+require Catalyst::Test;
+import Catalyst::Test '$name';
+
+print get(\$ARGV[0]) . "\n";
+
+1;
+__END__
+
+=head1 NAME
+
+test - Catalyst Test
+
+=head1 SYNOPSIS
+
+test [options] uri
+
+ Options:
+ -help display this help and exits
+
+ Examples:
+ test http://localhost/some_action
+ test /some_action
+
+=head1 DESCRIPTION
+
+Run a Catalyst action from the comand line.
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri\@oook.de>
+
+=head1 COPYRIGHT
+
+Copyright 2004 Sebastian Riedel. All rights reserved.
+
+This library is free software. You can redistribute it and/or modify it under
+the same terms as perl itself.
+
+=cut
+EOF
+ chmod 0700, "$bin/test";
+}
+
+sub _mk_create {
+ my $self = shift;
+ my $name = $self->{name};
+ my $bin = $self->{bin};
+ my $create = IO::File->new("> $bin/create")
+ or die qq/Could't open "$bin\/create", "$!"/;
+ print $create <<"EOF";
+#!/usr/bin/perl -w
+
+use strict;
+use Getopt::Long;
+use Pod::Usage;
+use Catalyst::Helper;
+
+my \$help = 0;
+
+GetOptions( 'help|?' => \$help );
+
+pod2usage(1) if ( \$help || !\$ARGV[1] );
+
+my \$helper = Catalyst::Helper->new;
+pod2usage(1) unless \$helper->mk_component( '$name', \@ARGV );
+
+1;
+__END__
+
+=head1 NAME
+
+create - Create a new Catalyst Component
+
+=head1 SYNOPSIS
+
+create [options] model|view|controller name
+
+ Options:
+ -help display this help and exits
+
+ Examples:
+ create controller My::Controller
+ create model My::Model
+ create view My::View
+
+=head1 DESCRIPTION
+
+Create a new Catalyst Component.
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri\@oook.de>
+
+=head1 COPYRIGHT
+
+Copyright 2004 Sebastian Riedel. All rights reserved.
+
+This library is free software. You can redistribute it and/or modify it under
+the same terms as perl itself.
+
+=cut
+EOF
+ chmod 0700, "$bin/create";
+}
+
+=head3 mk_component
+
+=cut
+
+sub mk_component {
+ my ( $self, $app, $type, $name, $helper, @args ) = @_;
+ return 0
+ if ( $name =~ /[^\w\:]/ || !\$type =~ /^model|m|view|v|controller|c\$/i );
+ return 0 if $name =~ /[^\w\:]/;
+ $type = 'M' if $type =~ /model|m/i;
+ $type = 'V' if $type =~ /view|v/i;
+ $type = 'C' if $type =~ /controller|c/i;
+ $self->{type} = $type;
+ $self->{name} = $name;
+ $self->{class} = "$app\::$type\::$name";
+ $self->{app} = $app;
+
+ # Class
+ my $appdir = File::Spec->catdir( split /\:\:/, $app );
+ my $path = File::Spec->catdir( $FindBin::Bin, '..', 'lib', $appdir, $type );
+ my $file = $name;
+ if ( $name =~ /\:/ ) {
+ my @path = split /\:\:/, $name;
+ $file = pop @path;
+ $path = File::Spec->catdir( $path, @path );
+ mkpath $path;
+ }
+ $file = File::Spec->catfile( $path, "$file.pm" );
+ $self->{file} = $file;
+
+ # Test
+ my $dir = File::Spec->catdir( $FindBin::Bin, '..', 't' );
+ my $num = '01';
+ for my $i (<$dir/*.t>) {
+ $i =~ /(\d+)[^\/]*.t$/;
+ my $j = $1 || $num;
+ $num = $j if $j > $num;
+ }
+ $num++;
+ $num = sprintf '%02d', $num;
+ my $prefix = $name;
+ $prefix =~ s/::/_/g;
+ $prefix = lc $prefix;
+ my $tname = lc( $num . $type . '_' . $prefix . '.t' );
+ $self->{prefix} = $prefix;
+ $self->{test_dir} = $dir;
+ $self->{test} = "$dir/$tname";
+
+ # Helper
+ if ($helper) {
+ my $comp = 'Model';
+ $comp = 'View' if $type eq 'V';
+ $comp = 'Controller' if $type eq 'C';
+ my $class = "Catalyst::Helper::$comp\::$helper";
+ eval "require $class";
+ die qq/Couldn't load helper "$class", "$@"/ if $@;
+ if ( $class->can('mk_compclass') ) {
+ $class->mk_compclass( $self, @args );
+ }
+ else { $self->_mk_compclass }
+
+ if ( $class->can('mk_comptest') ) {
+ $class->mk_comptest( $self, @args );
+ }
+ else { $self->_mk_comptest }
+ }
+
+ # Fallback
+ else {
+ $self->_mk_compclass;
+ $self->_mk_comptest;
+ }
+ return 1;
+}
+
+sub _mk_compclass {
+ my $self = shift;
+ my $app = $self->{app};
+ my $class = $self->{class};
+ my $type = $self->{type};
+ my $action = '';
+ $action = <<"EOF" if $type eq 'C';
+
+$app->action(
+
+ '!?default' => sub {
+ my ( \$self, \$c ) = \@_;
+ \$c->res->output('Congratulations, $class is on Catalyst!');
+ },
+
+);
+EOF
+ my $file = $self->{file};
+ my $comp = IO::File->new("> $file")
+ or die qq/Couldn't open "$file", "$!"/;
+ print $comp <<"EOF";
+package $class;
+
+use strict;
+use base 'Catalyst::Base';
+$action
+=head1 NAME
+
+$class - A Component
+
+=head1 SYNOPSIS
+
+ Very simple to use
+
+=head1 DESCRIPTION
+
+Very nice component.
+
+=head1 AUTHOR
+
+Clever guy
+
+=head1 LICENSE
+
+This library is free software . You can redistribute it and/or modify it under
+the same terms as perl itself.
+
+=cut
+
+1;
+EOF
+}
+
+sub _mk_comptest {
+ my $self = shift;
+ my $prefix = $self->{prefix};
+ my $type = $self->{type};
+ my $class = $self->{class};
+ my $app = $self->{app};
+ my $test = $self->{test};
+ my $t = IO::File->new("> $test") or die qq/Couldn't open "$test", "$!"/;
+
+ if ( $self->{type} eq 'C' ) {
+ print $t <<"EOF";
+use Test::More tests => 3;
+use_ok( Catalyst::Test, '$app' );
+use_ok('$class');
+
+ok( request('$prefix')->is_success );
+EOF
+ }
+ else {
+ print $t <<"EOF";
+use Test::More tests => 1;
+use_ok('$class');
+EOF
+ }
+}
+
+=head1 SEE ALSO
+
+L<Catalyst::Manual>, L<Catalyst::Test>, L<Catalyst::Request>,
+L<Catalyst::Response>, L<Catalyst>
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri@oook.de>
+
+=head1 LICENSE
+
+This library is free software . You can redistribute it and/or modify it under
+the same terms as perl itself.
+
+=cut
+
+1;
--- /dev/null
+package Catalyst::Log;
+
+use strict;
+use base 'Class::Accessor::Fast';
+
+=head1 NAME
+
+Catalyst::Log - Catalyst Log Class
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+Simple logging functionality for Catalyst.
+
+=head2 METHODS
+
+=head3 debug
+
+Log debug informations.
+
+=cut
+
+sub debug { _format( 'debug', $_[1] ) }
+
+=head3 error
+
+Log error informations.
+
+=cut
+
+sub error { _format( 'error', $_[1] ) }
+
+=head3 info
+
+Log informations.
+
+=cut
+
+sub info { _format( 'info', $_[1] ) }
+
+=head3 warn
+
+Log warnings.
+
+=cut
+
+sub warn { _format( 'warn', $_[1] ) }
+
+sub _format {
+ print STDERR '[' . localtime(time) . "] [catalyst] [$_[0]] $_[1]\n";
+}
+
+=head1 SEE ALSO
+
+L<Catalyst>.
+
+=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;
--- /dev/null
+=head1 NAME
+
+Catalyst::Manual - User guide and reference for Catalyst
+
+=head1 DESCRIPTION
+
+This is the comprehensive user guide and reference for Catalyst.
+
+L<Catalyst::Manual::Intro>
+ Introduction to Catalyst.
+
+L<Catalyst::Manual::Cookbook>
+ Cooking with Catalyst.
+
+L<Catalyst::Manual::Internals>
+ Here be dragons!
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri@oook.de>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
--- /dev/null
+=head1 NAME
+
+Catalyst::Manual::Cookbook - Cooking with Catalyst
+
+=head1 DESCRIPTION
+
+Yummy!
+
+=head1 RECIPES
+
+=head2 Force debug screen
+
+You can force Catalyst to display the debug screen at the end of the request by
+placing a die() call in the _end action.
+
+ __PACKAGE__->action(
+ '!end' => sub {
+ my ( $self, $c ) = @_;
+ die "testing";
+ }
+ );
+
+=head2 Disable statistics
+
+Just add this line to your application class if you don't want those nifty
+statistics in your debug messages.
+
+ sub Catalyst::Log::info { }
+
+=head2 Scaffolding
+
+Scaffolding is very simple with Catalyst.
+Just use Catalyst::Model::CDBI::CRUD as baseclass.
+
+ # lib/MyApp/Model/CDBI.pm
+ package MyApp::Model::CDBI;
+
+ use strict;
+ use base 'Catalyst::Model::CDBI::CRUD';
+
+ __PACKAGE__->config(
+ dsn => 'dbi:SQLite:/tmp/myapp.db',
+ relationships => 1
+ );
+
+ 1;
+
+ # lib/MyApp.pm
+ package MyApp;
+
+ use Catalyst 'FormValidator';
+
+ __PACKAGE__->config(
+ name => 'My Application',
+ root => '/home/joeuser/myapp/root'
+ );
+
+ __PACKAGE__->action(
+ 'table' => sub {
+ my ( $self, $c ) = @_;
+ $c->form( optional => [ MyApp::Model::CDBI::Table->columns ] );
+ $c->forward('MyApp::Model::CDBI::Table');
+ }
+ );
+
+ 1;
+
+Modify the $c->form() parameters to match your needs, and don't forget to copy
+the templates. ;)
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri@oook.de>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
--- /dev/null
+=head1 NAME
+
+Catalyst::Manual::Internals - Catalyst Internals
+
+=head1 DESCRIPTION
+
+=head2 Lifecycle
+
+These are the steps of a Catalyst request, every step can be overloaded to
+extend Catalyst.
+
+ handler
+ prepare
+ prepare_request
+ prepare_path
+ prepare_cookies
+ prepare_headers
+ prepare_action
+ prepare_parameters
+ prepare_uploads
+ process
+ finalize
+ finalize_headers
+ finalize_output
+
+These steps are normally overloaded from engine classes, and extended by
+plugins.
+Extending means using multiple inheritance with L<NEXT>.
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri@oook.de>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
--- /dev/null
+=head1 NAME
+
+Catalyst::Manual::Intro - Introduction to Catalyst
+
+=head1 DESCRIPTION
+
+This is a brief overview of why and how to use Catalyst. It explains how Catalyst works and shows how to quickly get a simple application up and running.
+
+=head2 What is Catalyst?
+
+Catalyst is an elegant web application framework, extremely flexible yet extremely simple. It's similar to Ruby on Rails, Spring (Java) and L<Maypole>, upon which it was originally based.
+
+=head3 MVC
+
+Catalyst follows the Model-View-Controller (MVC) design pattern, allowing you to easily separate concerns, like content, presentation and flow control, into separate modules. This separation allows you to modify code tat handles one concern without affecting code that handles the others. Catalyst promotes re-use of existing Perl modules that already handle common web application concerns well.
+
+Here's how the M, V and C map to those concerns, with examples of well-known Perl modules you may want to use for each.
+
+=over 4
+
+=item * Model
+
+Access and modify content (data). L<Class::DBI>, L<Plucene>, L<Net::LDAP>...
+
+=item * View
+
+Present content to the user. L<Template Toolkit|Template>, L<Mason|HTML::Mason>...
+
+=item * Controller
+
+Control the whole request phase, check parameters, dispatch actions, flow control. Catalyst!
+
+=back
+
+If you're unfamiliar with MVC and design patterns, you may want to check out the original book on the subject, I<Design Patterns>, by Gamma, Helm, Johson and Vlissides, a.k.a. the Gang of Four (GoF). Or just search the web. Many, many web application frameworks follow MVC, including all those listed above.
+
+=head3 Flexibility
+
+Catalyst is much more flexible than many other frameworks.
+
+=over 4
+
+=item * Multiple Models, Views and Controllers
+
+To build a Catalyst application, you handle each type of concern inside special modules called L</Components>. Often this code will be very simple, just calling out to Perl modules like those listed above under L</MVC>. Catalyst is very flexible about these Components. Use as many Models, Views and Controllers as you like, using as many different Perl modules as you like, all in the same application. Want to manipulate multiple databases, plus retrieve some data via LDAP? No problem. Want to present data from the same Model using L<Template Toolkit|Template> and L<PDF::Template>? Easy.
+
+=item * Re-Useable Components
+
+Not only does Catalyst promote the re-use of already-existing Perl modules, it also allows you to re-use your Catalyst components in multiple Catalyst applications.
+
+=item * Unrestrained URL-to-Action Dispatching
+
+Catalyst allows you to dispatch any URLs to any application L<Actions>, even via regular expressions! Unlike some other frameworks, it doesn't require you to put class and method names in your URLs.
+
+With Catalyst you register your actions and address them directly. For example:
+
+ MyApp->action( 'hello' => sub {
+ my ( $self, $context ) = @_;
+ $context->response->output('Hello World!');
+ });
+
+Now http://localhost:3000/hello prints "Hello World!".
+
+=item * Support for CGI, mod_perl, Apache::Request
+
+Use L<Catalyst::Engine::Apache> or L<Catalyst::Engine::CGI>.
+
+=back
+
+=head3 Simplicity
+
+The best part is that Catalyst implements all this flexibility in a very simple way.
+
+=item * Building Block Interface
+
+Components interoperate very smoothly. For example, Catalyst automatically makes a L<Context> object available in every component. Via the context, you can access the request object, share data between components, and control the flow of your application. Building a Catalyst application feels a lot like snapping together toy building blocks, and everything just works.
+
+=item * Component Auto-Discovery
+
+No need to C<use> all of your components. Catalyst automatically finds and loads them.
+
+=item * Pre-Built Components for Popular Modules
+
+See L<Catalyst::Model::CDBI> for L<Class::DBI>, or L<Catalyst::View::TT> for L<Template Toolkit|Template>. You can even get an instant web database front end with L<Catalyst::Model::CDBI::CRUD>.
+
+=item * Builtin Test Framework
+
+Catalyst comes with a builtin, lightweight http server and test framework, making it easy to test applications from the command line.
+
+=item * Helper Scripts
+
+Catalyst provides helper scripts to quickly generate running starter code for components and unit tests.
+
+=head2 Quickstart
+
+Here's how to install Catalyst and get a simple application up and running, using the helper scripts described above.
+
+=head3 Install
+
+ $ perl -MCPAN -e 'install Bundle::Catalyst'
+
+=head3 Setup
+
+ $ catalyst My::App
+ $ cd My-App
+ $ bin/create controller My::Controller
+
+=head3 Run
+
+ $ bin/server
+
+Now visit these locations with your favorite browser or user agent to see Catalyst in action:
+
+=over 4
+
+=item http://localhost:3000/
+
+=item http://localhost:3000/my_controller/
+
+=back
+
+Dead easy!
+
+=head2 How It Works
+
+Let's see how Catalyst works, by taking a closer look at the components and other parts of a Catalyst application.
+
+=head3 Application Class
+
+In addition to the Model, View and Controller components, there's a single class that represents your application itself. This is where you configure your application, load plugins, define application-wide actions and extend Catalyst.
+
+ package MyApp;
+
+ use strict;
+ use Catalyst qw/-Debug/;
+
+ MyApp->config(
+ name => 'My Application',
+ root => '/home/joeuser/myapp/root',
+
+ # You can put whatever you want in here:
+ # my_param_name => $my_param_value,
+ );
+
+ MyApp->action( '!default' => sub {
+ my ( $self, $context ) = @_;
+ $context->response->output('Catalyst rockz!');
+ });
+
+ 1;
+
+For most applications, Catalyst requires you to define only two config parameters:
+
+=over 4
+
+=item * name
+
+Name of your application.
+
+=item * root
+
+Path to additional files like templates, images or other static data.
+
+=back
+
+However, you can define as many parameters as you want for plugins or whatever you need. You can access them anywhere in your application via $context->config->{$param_name}.
+
+=head3 Context
+
+Catalyst automatically blesses a Context object into your application class and makes it available everywhere in your application. Use the Context to directly interact with Catalyst and glue your L<Components> together.
+
+As illustrated earlier in our URL-to-Action dispatching example, the Context is always the second method parameter, behind the Component object reference itself. Previously we called it $context for clarity, but most Catalyst developers just call it $c:
+
+ MyApp->action( 'hello' => sub {
+ my ( $self, $c ) = @_;
+ $c->res->output('Hello World!');
+ });
+
+The Context contains several important objects:
+
+=over 4
+
+=item * L<Catalyst::Request>
+
+ $c->request
+ $c->req # alias
+
+The request contains all kind of request specific informations like query parameters, cookies, uploads, headers and more.
+
+ $c->req->params->{foo};
+ $c->req->cookies->{sessionid};
+ $c->req->headers->content_type;
+ $c->req->base;
+
+=item * L<Catalyst::Reponse>
+
+ $c->response
+ $c->res # alias
+
+The response is like the request but contais just response specific informations.
+
+ $c->res->output('Hello World');
+ $c->res->status(404);
+ $c->res->redirect('http://oook.de');
+
+=item * L<Catalyst::Config>
+
+ $c->config
+
+ $c->config->root;
+ $c->config->name;
+
+=item * L<Catalyst::Log>
+
+ $c->log
+
+ $c->log->debug('Something happened');
+ $c->log->info('Something you should know');
+
+=item * Stash
+
+ $c->stash
+
+ $c->stash->{foo} = 'bar';
+
+=back
+
+The last of these, the stash, is a universal hash for sharing data among application components. For an example, we return to our 'hello' action example:
+
+ MyApp->action(
+
+ 'hello' => sub {
+ my ( $self, $c ) = @_;
+ $c->stash->{message} = 'Hello World!';
+ $c->forward('!show-message');
+ },
+
+ '!show-message' => sub {
+ my ( $self, $c ) = @_;
+ $c->res->output( $c->stash->{message} );
+ },
+
+ );
+
+=head3 Actions
+
+To define a Catalyst action, register it into your applicaton with the C<action> method. C<action> accepts a key-value pair, where the key represents one or more URLs or application states and the value is a code reference, the action to execute in reponse to the URL(s) or application state(s).
+
+Catalyst supports several ways to define Actions:
+
+=over 4
+
+=item * Literal
+
+ $c->action( 'foo/bar' => sub { } );
+
+Matches only http://localhost:3000/foo/bar.
+
+=item * Regex
+
+ $c->action( '^/foo(\d+)/bar(\d+)$/' => sub { } );
+
+Matches any URL that matches the pattern in the action key, e.g. http://localhost:3000/foo23/bar42. The pattern must be enclosed with forward slashes, i.e. '/$pattern/'.
+
+If you use capturing parantheses to extract values within the matching URL (23, 42 in the above example), those values are available in the $c->req->snippets array. Be sure to use ^ and $ if your action has arguments.
+
+=item * Namespace-Prefixed
+
+ package MyApp::Controller::My::Controller;
+ $c->action( '?foo' => sub { } );
+
+Matches http://localhost:3000/my_controller/foo. The action key must be prefixed with '?'.
+
+Prefixing the action key with '?' indicates that the matching URL must be prefixed with a modified form of the component's class (package) name. This modified class name excludes the parts that have a pre-defined meaning in Catalyst ("MyApp::Controller" in the above example), replaces "::" with "_" and converts the name to lower case. See L</Components> for a full explanation of the pre-defined meaning of Catalyst component class names.
+
+=item * Private
+
+ $c->action( '!foo' => sub { } );
+
+Matches no URL, and cannot be executed by requesting a URL that corresponds to the action key. Private actions can be executed only inside a Catalyst application, by calling the C<forward> method:
+
+ $c->forward('!foo');
+
+See L</Flow Control> for a full explanation of C<forward>.
+
+=back
+
+=head4 Builtin Private Actions
+
+In response to specific application states, Catalyst will automatically call these built in private actions:
+
+=over 4
+
+=item * !default
+
+Called when no other action matches.
+
+=item * !begin
+
+Called at the beginning of a request, before any matching actions are called.
+
+=item * !end
+
+Called at the end of a request, after all matching actions are called.
+
+=item * !?default, !?begin and !?end
+
+Like their equivalents above but used to overload them from Controllers.
+So each Controller can have their own !?default, !?begin and !?end.
+
+=back
+
+=head3 Flow Control
+
+Control the application flow with the C<forward> method, which accepts the key of an action to execute.
+
+ MyApp->action(
+
+ 'hello' => sub {
+ my ( $self, $c ) = @_;
+ $c->stash->{message} = 'Hello World!';
+ $c->forward('!check-message');
+ },
+
+ '!check-message' => sub {
+ my ( $self, $c ) = @_;
+ return unless $c->stash->{message};
+ $c->forward('!show-message');
+ },
+
+ '!show-message' => sub {
+ my ( $self, $c ) = @_;
+ $c->res->output( $c->stash->{message} );
+ },
+
+ );
+
+You can also forward to classes and methods.
+
+ MyApp->action(
+
+ 'hello' => sub {
+ my ( $self, $c ) = @_;
+ $c->forward(qw/MyApp::M::Hello say_hello/);
+ },
+
+ 'bye' => sub {
+ my ( $self, $c ) = @_;
+ $c->forward('MyApp::M::Hello');
+ },
+
+ );
+
+ package MyApp::M::Hello;
+
+ sub say_hello {
+ my ( $self, $c ) = @_;
+ $c->res->output('Hello World!');
+ }
+
+ sub process {
+ my ( $self, $c ) = @_;
+ $c->res->output('Goodbye World!');
+ }
+
+Note that C<forward> returns after processing.
+Catalyst will automatically try to call process() if you omit the method.
+
+=head3 Components
+
+Again, Catalyst has an uncommonly flexible component system. You can define as many L<Models>, L<Views> and Controllers as you like.
+
+All components are must inherit from L<Catalyst::Base>, which provides a simple class structure and some common class methods like C<config> and C<new> (constructor).
+
+ package MyApp::Controller::MyController;
+
+ use strict;
+ use base 'Catalyst::Base';
+
+ __PACKAGE__->config( foo => 'bar' );
+
+ 1;
+
+You don't have to C<use> or otherwise register Models, Views and Controllers. Catalyst automatically discovers and instantiates them, at startup. All you need to do is put them in directories named for each Component type. Notice that you can use some very terse aliases for each one.
+
+=over 4
+
+=item * MyApp/Model/
+
+=item * MyApp/M/
+
+=item * MyApp/View/
+
+=item * MyApp/V/
+
+=item * MyApp/Controller/
+
+=item * MyApp/C/
+
+=back
+
+=head4 Views
+
+To show how to define views, we'll use an already-existing base class for the L<Template Toolkit|Template>, L<Catalyst::View::TT>. All we need to do is inherit from this class:
+
+ package MyApp::V::TT;
+
+ use strict;
+ use base 'Catalyst::View::TT';
+
+ 1;
+
+This gives us a process() method and we can now just do $c->forward('MyApp::V::TT') to render our templates. The base class makes process() implicit, so we don't have to say C<$c-E<gt>forward(qw/MyApp::V::TT process/)>.
+
+ MyApp->action(
+
+ 'hello' => sub {
+ my ( $self, $c ) = @_;
+ $c->stash->{template} = 'hello.tt';
+ },
+
+ '!end' => sub {
+ my ( $self, $c ) = @_;
+ $c->forward('MyApp::View::TT');
+ },
+
+ );
+
+You normally render templates at the end of a request, so it's a perfect use for the !end action.
+
+Also, be sure to put the template under the directory specified in C<$c-E<gt>config->{root}>, or you'll be forced to look at our eyecandy debug screen. ;)
+
+=head4 Models
+
+To show how to define models, again we'll use an already-existing base class, this time for L<Class::DBI>: L<Catalyst::Model::CDBI>.
+
+But first, we need a database.
+
+ -- myapp.sql
+ CREATE TABLE foo (
+ id INTEGER PRIMARY KEY,
+ data TEXT
+ );
+
+ CREATE TABLE bar (
+ id INTEGER PRIMARY KEY,
+ foo INTEGER REFERENCES foo,
+ data TEXT
+ );
+
+ INSERT INTO foo (data) VALUES ('TEST!');
+
+
+ % sqlite /tmp/myapp.db < myapp.sql
+
+Now we can create a CDBI component for this database.
+
+ package MyApp::M::CDBI;
+
+ use strict;
+ use base 'Catalyst::Model::CDBI';
+
+ __PACKAGE__->config(
+ dsn => 'dbi:SQLite:/tmp/myapp.db',
+ relationships => 1
+ );
+
+ 1;
+
+Catalyst automatically loads table layouts and relationships. Use the stash to pass data to your templates.
+
+ package MyApp;
+
+ use strict;
+ use Catalyst '-Debug';
+
+ __PACKAGE__->config(
+ name => 'My Application',
+ root => '/home/joeuser/myapp/root'
+ );
+
+ __PACKAGE__->action(
+
+ '!end' => sub {
+ my ( $self, $c ) = @_;
+ $c->stash->{template} ||= 'index.tt';
+ $c->forward('MyApp::V::TT');
+ },
+
+ 'view' => sub {
+ my ( $self, $c, $id ) = @_;
+ $c->stash->{item} = MyApp::M::CDBI::Foo->retrieve($id);
+ }
+
+ );
+
+ 1;
+
+ The id is [% item.data %]
+
+=head4 Controllers
+
+Multiple Controllers are a good way to separate logical domains of your application and distribute tasks to different programmers in a teams.
+
+ package MyApp::C::Login;
+
+ MyApp->action(
+ '?sign-in' => sub { },
+ '?new-password' => sub { },
+ '?sign-out' => sub { },
+ );
+
+ package MyApp::C::Catalog;
+
+ MyApp->action(
+ '?view' => sub { },
+ '?list' => sub { },
+ );
+
+ package MyApp::C::Cart;
+
+ MyApp->action(
+ '?add' => sub { },
+ '?update' => sub { },
+ '?order' => sub { },
+ );
+
+=head3 Testing
+
+Catalyst has a built in http server for testing! (Later, you can easily use a more powerful server, e.g. Apache/mod_perl, in a production environment).
+
+Start your application on the command line...
+
+ perl -I/home/joeuser/myapp/lib -MCatalyst::Test=MyApp -e1 3000
+
+...then visit http://localhost:3000/ in a browser to view the output.
+
+You can also do it all from the command line:
+
+ perl -I/home/joeuser/myapp/lib -MCatalyst::Test=MyApp -e1 http://localhost/
+
+Have fun!
+
+=head1 AUTHOR
+
+Sebastian Riedel, C<sri@oook.de> and David Naughton, C<naughton@umn.edu>
+
+=head1 COPYRIGHT
+
+This program is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
--- /dev/null
+package Catalyst::Request;
+
+use strict;
+use base 'Class::Accessor::Fast';
+
+__PACKAGE__->mk_accessors(
+ qw/action arguments base cookies headers match method parameters path
+ snippets uploads user/
+);
+
+*args = \&arguments;
+*params = \¶meters;
+
+=head1 NAME
+
+Catalyst::Request - Catalyst Request Class
+
+=head1 SYNOPSIS
+
+See L<Catalyst>.
+
+=head1 DESCRIPTION
+
+The Catalyst Request.
+
+=head2 METHODS
+
+=head3 action
+
+Contains the action.
+
+ print $c->request->action;
+
+=head3 arguments (args)
+
+Returns an arrayref containing the arguments.
+
+ print $c->request->arguments->[0];
+
+=head3 base
+
+Contains the uri base.
+
+=head3 cookies
+
+Returns a hashref containing the cookies.
+
+ print $c->request->cookies->{mycookie}->value;
+
+=head3 headers
+
+Returns a L<HTTP::Headers> object containing the headers.
+
+ print $c->request->headers->header('X-Catalyst');
+
+=head3 match
+
+Contains the match.
+
+ print $c->request->match;
+
+=head3 parameters (params)
+
+Returns a hashref containing the parameters.
+
+ print $c->request->parameters->{foo};
+
+=head3 path
+
+Contains the path.
+
+ print $c->request->path;
+
+=head3 method
+
+Contains the request method.
+
+ print $c->request->method
+
+=head3 snippets
+
+Returns an arrayref containing regex snippets.
+
+ my @snippets = @{ $c->request->snippets };
+
+=head3 uploads
+
+Returns a hashref containing the uploads.
+
+ print $c->request->uploads->{foo}->filename;
+ print $c->request->uploads->{foo}->type;
+ print $c->request->uploads->{foo}->size;
+ my $fh = $c->request->uploads->{foo}->fh;
+
+=head3 user
+
+Returns the user.
+
+=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;
--- /dev/null
+package Catalyst::Response;
+
+use strict;
+use base 'Class::Accessor::Fast';
+
+__PACKAGE__->mk_accessors(qw/cookies headers output redirect status/);
+
+=head1 NAME
+
+Catalyst::Response - Catalyst Response Class
+
+=head1 SYNOPSIS
+
+See L<Catalyst::Application>.
+
+=head1 DESCRIPTION
+
+The Catalyst Response.
+
+=head2 METHODS
+
+=head3 cookies
+
+Returns a hashref containing the cookies.
+
+ $c->response->cookies->{foo} = { value => '123' };
+
+=head3 headers
+
+Returns a L<HTTP::Headers> object containing the headers.
+
+ $c->response->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
+
+=head3 output
+
+Contains the final output.
+
+ $c->response->output('Catalyst rockz!');
+
+=head3 redirect
+
+Contains a location to redirect to.
+
+ $c->response->redirect('http://slashdot.org');
+
+=head3 status
+
+Contains the HTTP status.
+
+ $c->response->status(404);
+
+=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;
--- /dev/null
+package Catalyst::Test;
+
+use strict;
+use UNIVERSAL::require;
+use HTTP::Response;
+use Socket;
+use URI;
+
+my $class;
+$ENV{CATALYST_ENGINE} = 'CGI';
+$ENV{CATALYST_TEST} = 1;
+
+=head1 NAME
+
+Catalyst::Test - Test Catalyst applications
+
+=head1 SYNOPSIS
+
+ # Tests
+ use Catalyst::Test 'TestApp';
+ request('index.html');
+ get('index.html');
+
+ # Request
+ perl -MCatalyst::Test=MyApp -e1 index.html
+
+ # Server
+ perl -MCatalyst::Test=MyApp -e1 3000
+
+=head1 DESCRIPTION
+
+Test Catalyst applications.
+
+=head2 METHODS
+
+=head3 get
+
+Returns the content.
+
+ my $content = get('foo/bar?test=1');
+
+=head3 request
+
+Returns a C<HTTP::Response> object.
+
+ my $res =request('foo/bar?test=1');
+
+=cut
+
+{
+ no warnings;
+ CHECK {
+ if ( ( caller(0) )[1] eq '-e' ) {
+ if ( $ARGV[0] =~ /^\d+$/ ) { server( $ARGV[0] ) }
+ else { print request( $ARGV[0] || 'http://localhost' )->content }
+ }
+ }
+}
+
+sub import {
+ my $self = shift;
+ $class = shift;
+ $class->require;
+ if ( ( caller(0) )[1] eq '-e' ) {
+ die qq/Couldn't load "$class", "$@"/ if $@;
+ }
+ my $caller = caller(0);
+ no strict 'refs';
+ *{"$caller\::request"} = \&request;
+ *{"$caller\::get"} = sub { request(@_)->content };
+}
+
+sub request {
+ my $uri = shift;
+ local *STDOUT;
+ my $output = '';
+ open STDOUT, '>', \$output;
+ $uri = URI->new($uri);
+ my %clean = %ENV;
+ $ENV{REQUEST_METHOD} ||= 'GET';
+ $ENV{HTTP_HOST} ||= $uri->authority || 'localhost';
+ $ENV{SCRIPT_NAME} ||= $uri->path || '/';
+ $ENV{QUERY_STRING} ||= $uri->query || '';
+ $ENV{CONTENT_TYPE} ||= 'text/plain';
+ $class->handler;
+ %ENV = %clean;
+ return HTTP::Response->parse($output);
+}
+
+=head3 server
+
+Starts a testserver.
+
+ Catalyst::Test::server(3000);
+
+=cut
+
+sub server {
+ my $port = shift;
+
+ # Listen
+ my $tcp = getprotobyname('tcp');
+ socket( HTTPDaemon, PF_INET, SOCK_STREAM, $tcp ) or die $!;
+ setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) )
+ or warn $!;
+ bind( HTTPDaemon, sockaddr_in( $port, INADDR_ANY ) ) or die $!;
+ listen( HTTPDaemon, SOMAXCONN ) or die $!;
+
+ print "You can connect to your server at http://localhost:$port\n";
+
+ # Process
+ my %clean = %ENV;
+ for ( ; accept( Remote, HTTPDaemon ) ; close Remote ) {
+ *STDIN = *Remote;
+ *STDOUT = *Remote;
+ my $remote_sockaddr = getpeername(STDIN);
+ my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
+ my $peername = gethostbyaddr( $iaddr, AF_INET ) || "localhost";
+ my $peeraddr = inet_ntoa($iaddr) || "127.0.0.1";
+ my $local_sockaddr = getsockname(STDIN);
+ my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
+ my $localname = gethostbyaddr( $localiaddr, AF_INET ) || 'localhost';
+ my $localaddr = inet_ntoa($localiaddr) || '127.0.0.1';
+ my $chunk;
+
+ while ( sysread( STDIN, my $buff, 1 ) ) {
+ last if $buff eq "\n";
+ $chunk .= $buff;
+ }
+ my ( $method, $request_uri, $proto, undef ) = split /\s+/, $chunk;
+ my ( $file, undef, $query_string ) =
+ ( $request_uri =~ /([^?]*)(\?(.*))?/ );
+ last if ( $method !~ /^(GET|POST|HEAD)$/ );
+ %ENV = %clean;
+
+ $chunk = '';
+ while ( sysread( STDIN, my $buff, 1 ) ) {
+ if ( $buff eq "\n" ) {
+ $chunk =~ s/[\r\l\n\s]+$//;
+ if ( $chunk =~ /^([\w\-]+): (.+)/i ) {
+ my $tag = uc($1);
+ $tag =~ s/^COOKIES$/COOKIE/;
+ my $val = $2;
+ $tag =~ s/-/_/g;
+ $tag = "HTTP_" . $tag
+ unless ( grep /^$tag$/, qw(CONTENT_LENGTH CONTENT_TYPE) );
+ if ( $ENV{$tag} ) { $ENV{$tag} .= "; $val" }
+ else { $ENV{$tag} = $val }
+ }
+ last if $chunk =~ /^$/;
+ $chunk = '';
+ }
+ else { $chunk .= $buff }
+ }
+ $ENV{SERVER_PROTOCOL} = $proto;
+ $ENV{SERVER_PORT} = $port;
+ $ENV{SERVER_NAME} = $localname;
+ $ENV{SERVER_URL} = "http://$localname:$port/";
+ $ENV{PATH_INFO} = $file;
+ $ENV{REQUEST_URI} = $request_uri;
+ $ENV{REQUEST_METHOD} = $method;
+ $ENV{REMOTE_ADDR} = $peeraddr;
+ $ENV{REMOTE_HOST} = $peername;
+ $ENV{QUERY_STRING} = $query_string || '';
+ $ENV{CONTENT_TYPE} ||= 'text/plain';
+ $ENV{SERVER_SOFTWARE} ||= "Catalyst/$Catalyst::VERSION";
+ $class->run;
+ }
+}
+
+=head1 SEE ALSO
+
+L<Catalyst>.
+
+=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;
--- /dev/null
+use Test::More tests => 1;
+
+use_ok('Catalyst');
--- /dev/null
+use Test::More;
+
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@;
+plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD};
+
+all_pod_coverage_ok();
--- /dev/null
+package TestApp;
+
+use Catalyst;
+
+__PACKAGE__->action(
+ foo => sub {
+ my ( $self, $c ) = @_;
+ $c->res->output('bar');
+ }
+);
+
+package main;
+
+use Test::More tests => 1;
+use Catalyst::Test 'TestApp';
+
+ok( get('/foo') =~ /bar/ );
--- /dev/null
+package TestApp;
+
+use Catalyst;
+
+__PACKAGE__->action(
+ '/foo/(.*)/' => sub {
+ my ( $self, $c ) = @_;
+ $c->res->output( $c->req->snippets->[0] );
+ }
+);
+
+package main;
+
+use Test::More tests => 1;
+use Catalyst::Test 'TestApp';
+
+ok( get('/foo/bar') =~ /bar/ );
--- /dev/null
+package TestApp;
+
+use Catalyst;
+
+__PACKAGE__->action(
+ foo => sub {
+ my ( $self, $c ) = @_;
+ $c->res->output( $c->req->params->{foo} );
+ }
+);
+
+package main;
+
+use Test::More tests => 1;
+use Catalyst::Test 'TestApp';
+
+ok( get('/foo?foo=bar') =~ /bar/ );
--- /dev/null
+package TestApp;
+
+use Catalyst;
+
+__PACKAGE__->action(
+ foo => sub {
+ my ( $self, $c, $arg ) = @_;
+ $c->res->output($arg);
+ }
+);
+
+package main;
+
+use Test::More tests => 1;
+use Catalyst::Test 'TestApp';
+
+ok( get('/foo/bar') =~ /bar/ );
--- /dev/null
+package TestApp;
+
+use Catalyst;
+
+__PACKAGE__->action(
+ foo => sub {
+ my ( $self, $c ) = @_;
+ $c->res->headers->header( 'X-Foo' => 'Bar' );
+ }
+);
+
+package main;
+
+use Test::More tests => 1;
+use Catalyst::Test 'TestApp';
+
+ok( request('/foo')->header('X-Foo') );
--- /dev/null
+package TestApp;
+
+use Catalyst;
+
+__PACKAGE__->action(
+ foo => sub {
+ my ( $self, $c ) = @_;
+ $c->res->cookies->{foo} = { value => 'bar' };
+ }
+);
+
+package main;
+
+use Test::More tests => 1;
+use Catalyst::Test 'TestApp';
+
+ok( request('/foo')->header('Set-Cookie') =~ /bar/ );
--- /dev/null
+package TestApp;
+
+use Catalyst;
+
+__PACKAGE__->action(
+ foo => sub {
+ my ( $self, $c ) = @_;
+ $c->forward('bar');
+ },
+ bar => sub {
+ my ( $self, $c, $arg ) = @_;
+ $c->res->output($arg);
+ }
+);
+
+package main;
+
+use Test::More tests => 1;
+use Catalyst::Test 'TestApp';
+
+ok( get('/foo/bar') =~ /bar/ );
--- /dev/null
+package TestApp;
+
+use Catalyst;
+
+__PACKAGE__->action(
+ foo => sub {
+ my ( $self, $c ) = @_;
+ $c->res->redirect('http://localhost/bar');
+ }
+);
+
+package main;
+
+use Test::More tests => 1;
+use Catalyst::Test 'TestApp';
+
+ok( request('/foo')->header('Location') =~ /localhost/ );
--- /dev/null
+package TestApp;
+
+use Catalyst;
+
+__PACKAGE__->action(
+ foo => sub {
+ my ( $self, $c ) = @_;
+ $c->stash->{test} ||= 'foo';
+ $c->forward('bar');
+ },
+ bar => sub {
+ my ( $self, $c ) = @_;
+ $c->stash->{test} ||= 'bar';
+ $c->forward('yada');
+ },
+ yada => sub {
+ my ( $self, $c ) = @_;
+ $c->stash->{test} ||= 'yada';
+ $c->res->output( $c->stash->{test} );
+ }
+);
+
+package main;
+
+use Test::More tests => 2;
+use Catalyst::Test 'TestApp';
+
+ok( get('/foo') =~ /foo/ );
+ok( get('/bar') =~ /bar/ );
--- /dev/null
+package TestApp;
+
+use Catalyst;
+
+__PACKAGE__->action(
+ '!default' => sub {
+ my ( $self, $c ) = @_;
+ $c->res->output('bar');
+ }
+);
+
+package TestApp::C::Foo::Bar;
+
+TestApp->action(
+ '!?default' => sub {
+ my ( $self, $c ) = @_;
+ $c->res->output('yada');
+ }
+);
+
+package main;
+
+use Test::More tests => 2;
+use Catalyst::Test 'TestApp';
+
+ok( get('/foo') =~ /bar/ );
+ok( get('/foo_bar/foo') =~ /yada/ );
--- /dev/null
+package TestApp;
+
+use Catalyst;
+
+__PACKAGE__->action(
+
+ '!begin' => sub {
+ my ( $self, $c ) = @_;
+ $c->res->output('foo');
+ },
+
+ '!default' => sub { },
+
+ '!end' => sub {
+ my ( $self, $c ) = @_;
+ $c->res->output( $c->res->output . 'bar' );
+ },
+
+);
+
+package TestApp::C::Foo::Bar;
+
+TestApp->action(
+
+ '!?begin' => sub {
+ my ( $self, $c ) = @_;
+ $c->res->output('yada');
+ },
+
+ '!?default' => sub { },
+
+ '!?end' => sub {
+ my ( $self, $c ) = @_;
+ $c->res->output('yada');
+ $c->res->output( $c->res->output . 'yada' );
+ },
+
+);
+
+package main;
+
+use Test::More tests => 2;
+use Catalyst::Test 'TestApp';
+
+ok( get('/foo') =~ /foobar/ );
+ok( get('/foo_bar/foo') =~ /yadayada/ );
projects / catagits/Catalyst-Runtime.git / commitdiff