File Coverage

blib/lib/Catalyst.pm

Criterion	Covered	Total	%
statement	503	688	73.1
branch	169	294	57.5
condition	55	119	46.2
subroutine	93	111	83.8
pod	62	62	100.0
total	882	1274	69.2

line	stmt	bran	cond	sub	pod	time	code
1							package Catalyst;
2
3	55			55		1423	use strict;
	55					535
	55					946
4	55			55		2326	use base 'Catalyst::Component';
	55					806
	55					2900
5	55			55		45418	use bytes;
	55					787
	55					923
6	55			55		1008	use Catalyst::Exception;
	55					566
	55					1175
7	55			55		1515	use Catalyst::Log;
	55					566
	55					4305
8	55			55		1712	use Catalyst::Request;
	55					675
	55					1275
9	55			55		4288	use Catalyst::Request::Upload;
	55					623
	55					1553
10	55			55		3293	use Catalyst::Response;
	55					2759
	55					1190
11	55			55		1074	use Catalyst::Utils;
	55					564
	55					891
12	55			55		1913	use Catalyst::Controller;
	55					618
	55					2085
13	55			55		2621	use Devel::InnerPackage ();
	55					613
	55					587
14	55			55		1017	use File::stat;
	55					607
	55					880
15	55			55		3061	use Module::Pluggable::Object ();
	55					1422
	55					857
16	55			55		1911	use NEXT;
	55					674
	55					1148
17	55			55		2304	use Text::SimpleTable ();
	55					922
	55					601
18	55			55		1657	use Path::Class::Dir ();
	55					3725
	55					606
19	55			55		5323	use Path::Class::File ();
	55					524
	55					542
20	55			55		2357	use Time::HiRes qw/gettimeofday tv_interval/;
	55					691
	55					899
21	55			55		1143	use URI ();
	55					895
	55					742
22	55			55		999	use Scalar::Util qw/weaken blessed/;
	55					511
	55					1616
23	55			55		3207	use Tree::Simple qw/use_weak_refs/;
	55					1506
	55					1157
24	55			55		2441	use Tree::Simple::Visitor::FindByUID;
	55					22821
	55					2226
25	55			55		1891	use attributes;
	55					527
	55					1247
26	55			55		948	use utf8;
	55					583
	55					872
27	55			55		2654	use Carp qw/croak/;
	55					539
	55					1154
28
29	55			55		805	BEGIN { require 5.008001; }
30
31							__PACKAGE__->mk_accessors(
32							qw/counter request response state action stack namespace stats/
33							);
34
35							attributes->import( __PACKAGE__, \&namespace, 'lvalue' );
36
37	8484	50		8484	1	104464	sub depth { scalar @{ shift->stack \|\| [] }; }
	8484					141409
38
39							# Laziness++
40							*comp = \&component;
41							*req = \&request;
42							*res = \&response;
43
44							# For backwards compatibility
45							*finalize_output = \&finalize_body;
46
47							# For statistics
48							our $COUNT = 1;
49							our $START = time;
50							our $RECURSION = 1000;
51							our $DETACH = "catalyst_detach\n";
52
53							__PACKAGE__->mk_classdata($_)
54							for qw/components arguments dispatcher engine log dispatcher_class
55							engine_class context_class request_class response_class setup_finished/;
56
57							__PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
58							__PACKAGE__->engine_class('Catalyst::Engine::CGI');
59							__PACKAGE__->request_class('Catalyst::Request');
60							__PACKAGE__->response_class('Catalyst::Response');
61
62							# Remember to update this in Catalyst::Runtime as well!
63
64							our $VERSION = '5.7007';
65
66							sub import {
67	105			105		1438	my ( $class, @arguments ) = @_;
68
69							# We have to limit $class to Catalyst to avoid pushing Catalyst upon every
70							# callers @ISA.
71	105	100				1519	return unless $class eq 'Catalyst';
72
73	58					704	my $caller = caller(0);
74
75	58	50				8845	unless ( $caller->isa('Catalyst') ) {
76	55			55		2746	no strict 'refs';
	55					558
	55					926
77	58					863	push @{"$caller\::ISA"}, $class, 'Catalyst::Controller';
	58					1353
78							}
79
80	58					1433	$caller->arguments( [@arguments] );
81	58					1037	$caller->setup_home;
82							}
83
84							=head1 NAME
85
86							Catalyst - The Elegant MVC Web Application Framework
87
88							=head1 SYNOPSIS
89
90							See the L<Catalyst::Manual> distribution for comprehensive
91							documentation and tutorials.
92
93							# Install Catalyst::Devel for helpers and other development tools
94							# use the helper to create a new application
95							catalyst.pl MyApp
96
97							# add models, views, controllers
98							script/myapp_create.pl model MyDatabase DBIC::Schema create=dynamic dbi:SQLite:/path/to/db
99							script/myapp_create.pl view MyTemplate TT
100							script/myapp_create.pl controller Search
101
102							# built in testserver -- use -r to restart automatically on changes
103							# --help to see all available options
104							script/myapp_server.pl
105
106							# command line testing interface
107							script/myapp_test.pl /yada
108
109							### in lib/MyApp.pm
110							use Catalyst qw/-Debug/; # include plugins here as well
111
112							### In lib/MyApp/Controller/Root.pm (autocreated)
113							sub foo : Global { # called for /foo, /foo/1, /foo/1/2, etc.
114							my ( $self, $c, @args ) = @_; # args are qw/1 2/ for /foo/1/2
115							$c->stash->{template} = 'foo.tt'; # set the template
116							# lookup something from db -- stash vars are passed to TT
117							$c->stash->{data} =
118							$c->model('Database::Foo')->search( { country => $args[0] } );
119							if ( $c->req->params->{bar} ) { # access GET or POST parameters
120							$c->forward( 'bar' ); # process another action
121							# do something else after forward returns
122							}
123							}
124
125							# The foo.tt TT template can use the stash data from the database
126							[% WHILE (item = data.next) %]
127							[% item.foo %]
128							[% END %]
129
130							# called for /bar/of/soap, /bar/of/soap/10, etc.
131							sub bar : Path('/bar/of/soap') { ... }
132
133							# called for all actions, from the top-most controller downwards
134							sub auto : Private {
135							my ( $self, $c ) = @_;
136							if ( !$c->user_exists ) { # Catalyst::Plugin::Authentication
137							$c->res->redirect( '/login' ); # require login
138							return 0; # abort request and go immediately to end()
139							}
140							return 1; # success; carry on to next action
141							}
142
143							# called after all actions are finished
144							sub end : Private {
145							my ( $self, $c ) = @_;
146							if ( scalar @{ $c->error } ) { ... } # handle errors
147							return if $c->res->body; # already have a response
148							$c->forward( 'MyApp::View::TT' ); # render template
149							}
150
151							### in MyApp/Controller/Foo.pm
152							# called for /foo/bar
153							sub bar : Local { ... }
154
155							# called for /blargle
156							sub blargle : Global { ... }
157
158							# an index action matches /foo, but not /foo/1, etc.
159							sub index : Private { ... }
160
161							### in MyApp/Controller/Foo/Bar.pm
162							# called for /foo/bar/baz
163							sub baz : Local { ... }
164
165							# first Root auto is called, then Foo auto, then this
166							sub auto : Private { ... }
167
168							# powerful regular expression paths are also possible
169							sub details : Regex('^product/(\w+)/details$') {
170							my ( $self, $c ) = @_;
171							# extract the (\w+) from the URI
172							my $product = $c->req->captures->[0];
173							}
174
175							See L<Catalyst::Manual::Intro> for additional information.
176
177							=head1 DESCRIPTION
178
179							Catalyst is a modern framework for making web applications without the
180							pain usually associated with this process. This document is a reference
181							to the main Catalyst application. If you are a new user, we suggest you
182							start with L<Catalyst::Manual::Tutorial> or L<Catalyst::Manual::Intro>.
183
184							See L<Catalyst::Manual> for more documentation.
185
186							Catalyst plugins can be loaded by naming them as arguments to the "use
187							Catalyst" statement. Omit the C<Catalyst::Plugin::> prefix from the
188							plugin name, i.e., C<Catalyst::Plugin::My::Module> becomes
189							C<My::Module>.
190
191							use Catalyst qw/My::Module/;
192
193							If your plugin starts with a name other than C<Catalyst::Plugin::>, you can
194							fully qualify the name by using a unary plus:
195
196							use Catalyst qw/
197							My::Module
198							+Fully::Qualified::Plugin::Name
199							/;
200
201							Special flags like C<-Debug> and C<-Engine> can also be specified as
202							arguments when Catalyst is loaded:
203
204							use Catalyst qw/-Debug My::Module/;
205
206							The position of plugins and flags in the chain is important, because
207							they are loaded in the order in which they appear.
208
209							The following flags are supported:
210
211							=head2 -Debug
212
213							Enables debug output. You can also force this setting from the system
214							environment with CATALYST_DEBUG or <MYAPP>_DEBUG. The environment
215							settings override the application, with <MYAPP>_DEBUG having the highest
216							priority.
217
218							=head2 -Engine
219
220							Forces Catalyst to use a specific engine. Omit the
221							C<Catalyst::Engine::> prefix of the engine name, i.e.:
222
223							use Catalyst qw/-Engine=CGI/;
224
225							=head2 -Home
226
227							Forces Catalyst to use a specific home directory, e.g.:
228
229							use Catalyst qw[-Home=/usr/mst];
230
231							This can also be done in the shell environment by setting either the
232							C<CATALYST_HOME> environment variable or C<MYAPP_HOME>; where C<MYAPP>
233							is replaced with the uppercased name of your application, any "::" in
234							the name will be replaced with underscores, e.g. MyApp::Web should use
235							MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used.
236
237							=head2 -Log
238
239							Specifies log level.
240
241							=head1 METHODS
242
243							=head2 INFORMATION ABOUT THE CURRENT REQUEST
244
245							=head2 $c->action
246
247							Returns a L<Catalyst::Action> object for the current action, which
248							stringifies to the action name. See L<Catalyst::Action>.
249
250							=head2 $c->namespace
251
252							Returns the namespace of the current action, i.e., the URI prefix
253							corresponding to the controller of the current action. For example:
254
255							# in Controller::Foo::Bar
256							$c->namespace; # returns 'foo/bar';
257
258							=head2 $c->request
259
260							=head2 $c->req
261
262							Returns the current L<Catalyst::Request> object, giving access to
263							information about the current client request (including parameters,
264							cookies, HTTP headers, etc.). See L<Catalyst::Request>.
265
266							=head2 REQUEST FLOW HANDLING
267
268							=head2 $c->forward( $action [, \@arguments ] )
269
270							=head2 $c->forward( $class, $method, [, \@arguments ] )
271
272							Forwards processing to another action, by its private name. If you give a
273							class name but no method, C<process()> is called. You may also optionally
274							pass arguments in an arrayref. The action will receive the arguments in
275							C<@_> and C<< $c->req->args >>. Upon returning from the function,
276							C<< $c->req->args >> will be restored to the previous values.
277
278							Any data C<return>ed from the action forwarded to, will be returned by the
279							call to forward.
280
281							my $foodata = $c->forward('/foo');
282							$c->forward('index');
283							$c->forward(qw/MyApp::Model::DBIC::Foo do_stuff/);
284							$c->forward('MyApp::View::TT');
285
286							Note that forward implies an C<<eval { }>> around the call (actually
287							C<execute> does), thus de-fatalizing all 'dies' within the called
288							action. If you want C<die> to propagate you need to do something like:
289
290							$c->forward('foo');
291							die $c->error if $c->error;
292
293							Or make sure to always return true values from your actions and write
294							your code like this:
295
296							$c->forward('foo') \|\| return;
297
298							=cut
299
300	6199			6199	1	114220	sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
	6199					99125
301
302							=head2 $c->detach( $action [, \@arguments ] )
303
304							=head2 $c->detach( $class, $method, [, \@arguments ] )
305
306							=head2 $c->detach()
307
308							The same as C<forward>, but doesn't return to the previous action when
309							processing is finished.
310
311							When called with no arguments it escapes the processing chain entirely.
312
313							=cut
314
315	12			12	1	477	sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
	12					160
316
317							=head2 $c->response
318
319							=head2 $c->res
320
321							Returns the current L<Catalyst::Response> object, see there for details.
322
323							=head2 $c->stash
324
325							Returns a hashref to the stash, which may be used to store data and pass
326							it between components during a request. You can also set hash keys by
327							passing arguments. The stash is automatically sent to the view. The
328							stash is cleared at the end of a request; it cannot be used for
329							persistent storage (for this you must use a session; see
330							L<Catalyst::Plugin::Session> for a complete system integrated with
331							Catalyst).
332
333							$c->stash->{foo} = $bar;
334							$c->stash( { moose => 'majestic', qux => 0 } );
335							$c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref
336
337							# stash is automatically passed to the view for use in a template
338							$c->forward( 'MyApp::View::TT' );
339
340							=cut
341
342							sub stash {
343	280			280	1	9857	my $c = shift;
344	280	50				2875	if (@_) {
345	0	0				0	my $stash = @_ > 1 ? {@_} : $_[0];
346	0	0				0	croak('stash takes a hash or hashref') unless ref $stash;
347	0					0	foreach my $key ( keys %$stash ) {
348	0					0	$c->{stash}->{$key} = $stash->{$key};
349							}
350							}
351	280					5213	return $c->{stash};
352							}
353
354							=head2 $c->error
355
356							=head2 $c->error($error, ...)
357
358							=head2 $c->error($arrayref)
359
360							Returns an arrayref containing error messages. If Catalyst encounters an
361							error while processing a request, it stores the error in $c->error. This
362							method should only be used to store fatal error messages.
363
364							my @error = @{ $c->error };
365
366							Add a new error.
367
368							$c->error('Something bad happened');
369
370							=cut
371
372							sub error {
373	3609			3609	1	59962	my $c = shift;
374	3609	100				58293	if ( $_[0] ) {
		50
375	14	50				187	my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
376	14	50				449	croak @$error unless ref $c;
377	14					126	push @{ $c->{error} }, @$error;
	14					222
378							}
379	0					0	elsif ( defined $_[0] ) { $c->{error} = undef }
380	3609		100			161080	return $c->{error} \|\| [];
381							}
382
383
384							=head2 $c->state
385
386							Contains the return value of the last executed action.
387
388							=head2 $c->clear_errors
389
390							Clear errors. You probably don't want to clear the errors unless you are
391							implementing a custom error screen.
392
393							This is equivalent to running
394
395							$c->error(0);
396
397							=cut
398
399							sub clear_errors {
400	0			0	1	0	my $c = shift;
401	0					0	$c->error(0);
402							}
403
404
405							# search via regex
406							sub _comp_search {
407	8			8		81	my ( $c, @names ) = @_;
408
409	8					73	foreach my $name (@names) {
410	8					67	foreach my $component ( keys %{ $c->components } ) {
	8					94
411	151	100				7088	return $c->components->{$component} if $component =~ /$name/i;
412							}
413							}
414
415	3					42	return undef;
416							}
417
418							# try explicit component names
419							sub _comp_explicit {
420	17117			17117		299347	my ( $c, @names ) = @_;
421
422	17117					213207	foreach my $try (@names) {
423	17186	100				274883	return $c->components->{$try} if ( exists $c->components->{$try} );
424							}
425
426	4					142	return undef;
427							}
428
429							# like component, but try just these prefixes before regex searching,
430							# and do not try to return "sort keys %{ $c->components }"
431							sub _comp_prefixes {
432	71			71		874	my ( $c, $name, @prefixes ) = @_;
433
434	71		66			932	my $appclass = ref $c \|\| $c;
435
436	71					638	my @names = map { "${appclass}::${_}::${name}" } @prefixes;
	142					3501
437
438	71					1015	my $comp = $c->_comp_explicit(@names);
439	71	50				3237	return $comp if defined($comp);
440	0					0	$comp = $c->_comp_search($name);
441	0					0	return $comp;
442							}
443
444							# Find possible names for a prefix
445
446							sub _comp_names {
447	3			3		32	my ( $c, @prefixes ) = @_;
448
449	3		33			44	my $appclass = ref $c \|\| $c;
450
451	3					29	my @pre = map { "${appclass}::${_}::" } @prefixes;
	6					68
452
453	3					27	my @names;
454
455	3					37	COMPONENT: foreach my $comp ($c->component) {
456	27					325	foreach my $p (@pre) {
457	48	100				1026	if ($comp =~ s/^$p//) {
458	9					83	push(@names, $comp);
459	9					88	next COMPONENT;
460							}
461							}
462							}
463
464	3					99	return @names;
465							}
466
467							# Return a component if only one matches.
468							sub _comp_singular {
469	2			2		24	my ( $c, @prefixes ) = @_;
470
471	2		33			30	my $appclass = ref $c \|\| $c;
472
473	4					83	my ( $comp, $rest ) =
474	2					19	map { $c->_comp_search("^${appclass}::${_}::") } @prefixes;
475	2	50				838	return $comp unless $rest;
476							}
477
478							# Filter a component before returning by calling ACCEPT_CONTEXT if available
479							sub _filter_component {
480	17116			17116		220187	my ( $c, $comp, @args ) = @_;
481	17116	100				198464	if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
	17116					341923
482	2					26	return $comp->ACCEPT_CONTEXT( $c, @args );
483							}
484	17114					381867	else { return $comp }
485							}
486
487							=head2 COMPONENT ACCESSORS
488
489							=head2 $c->controller($name)
490
491							Gets a L<Catalyst::Controller> instance by name.
492
493							$c->controller('Foo')->do_stuff;
494
495							If the name is omitted, will return the controller for the dispatched
496							action.
497
498							=cut
499
500							sub controller {
501	24			24	1	1055	my ( $c, $name, @args ) = @_;
502	24	50				420	return $c->_filter_component( $c->_comp_prefixes( $name, qw/Controller C/ ),
503							@args )
504							if ($name);
505	0					0	return $c->component( $c->action->class );
506							}
507
508							=head2 $c->model($name)
509
510							Gets a L<Catalyst::Model> instance by name.
511
512							$c->model('Foo')->do_stuff;
513
514							Any extra arguments are directly passed to ACCEPT_CONTEXT.
515
516							If the name is omitted, it will look for
517							- a model object in $c->stash{current_model_instance}, then
518							- a model name in $c->stash->{current_model}, then
519							- a config setting 'default_model', or
520							- check if there is only one model, and return it if that's the case.
521
522							=cut
523
524							sub model {
525	31			31	1	379	my ( $c, $name, @args ) = @_;
526	31	100				437	return $c->_filter_component( $c->_comp_prefixes( $name, qw/Model M/ ),
527							@args )
528							if $name;
529	6	100				177	if (ref $c) {
530	4	100				61	return $c->stash->{current_model_instance}
531							if $c->stash->{current_model_instance};
532	2	100				22	return $c->model( $c->stash->{current_model} )
533							if $c->stash->{current_model};
534							}
535	3	100				183	return $c->model( $c->config->{default_model} )
536							if $c->config->{default_model};
537	1					65	return $c->_filter_component( $c->_comp_singular(qw/Model M/) );
538
539							}
540
541							=head2 $c->controllers
542
543							Returns the available names which can be passed to $c->controller
544
545							=cut
546
547							sub controllers {
548	1			1	1	11	my ( $c ) = @_;
549	1					13	return $c->_comp_names(qw/Controller C/);
550							}
551
552
553							=head2 $c->view($name)
554
555							Gets a L<Catalyst::View> instance by name.
556
557							$c->view('Foo')->do_stuff;
558
559							Any extra arguments are directly passed to ACCEPT_CONTEXT.
560
561							If the name is omitted, it will look for
562							- a view object in $c->stash{current_view_instance}, then
563							- a view name in $c->stash->{current_view}, then
564							- a config setting 'default_view', or
565							- check if there is only one view, and return it if that's the case.
566
567							=cut
568
569							sub view {
570	28			28	1	14907	my ( $c, $name, @args ) = @_;
571	28	100				448	return $c->_filter_component( $c->_comp_prefixes( $name, qw/View V/ ),
572							@args )
573							if $name;
574	6	100				73	if (ref $c) {
575	4	100				101	return $c->stash->{current_view_instance}
576							if $c->stash->{current_view_instance};
577	2	100				24	return $c->view( $c->stash->{current_view} )
578							if $c->stash->{current_view};
579							}
580	3	100				40	return $c->view( $c->config->{default_view} )
581							if $c->config->{default_view};
582	1					18	return $c->_filter_component( $c->_comp_singular(qw/View V/) );
583							}
584
585							=head2 $c->models
586
587							Returns the available names which can be passed to $c->model
588
589							=cut
590
591							sub models {
592	1			1	1	11	my ( $c ) = @_;
593	1					13	return $c->_comp_names(qw/Model M/);
594							}
595
596
597							=head2 $c->views
598
599							Returns the available names which can be passed to $c->view
600
601							=cut
602
603							sub views {
604	1			1	1	11	my ( $c ) = @_;
605	1					16	return $c->_comp_names(qw/View V/);
606							}
607
608							=head2 $c->comp($name)
609
610							=head2 $c->component($name)
611
612							Gets a component object by name. This method is not recommended,
613							unless you want to get a specific component by full
614							class. C<< $c->controller >>, C<< $c->model >>, and C<< $c->view >>
615							should be used instead.
616
617							=cut
618
619							sub component {
620	17050			17050	1	843250	my $c = shift;
621
622	17050	100				229214	if (@_) {
623
624	17046					193356	my $name = shift;
625
626	17046		66			240891	my $appclass = ref $c \|\| $c;
627
628	102276					1739241	my @names = (
629							$name, "${appclass}::${name}",
630	17046					291313	map { "${appclass}::${_}::${name}" }
631							qw/Model M Controller C View V/
632							);
633
634	17046					766151	my $comp = $c->_comp_explicit(@names);
635	17046	100				316827	return $c->_filter_component( $comp, @_ ) if defined($comp);
636
637	4					127	$comp = $c->_comp_search($name);
638	4	100				73	return $c->_filter_component( $comp, @_ ) if defined($comp);
639							}
640
641	7					63	return sort keys %{ $c->components };
	7					94
642							}
643
644
645
646							=head2 CLASS DATA AND HELPER CLASSES
647
648							=head2 $c->config
649
650							Returns or takes a hashref containing the application's configuration.
651
652							__PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } );
653
654							You can also use a C<YAML>, C<XML> or C<Config::General> config file
655							like myapp.yml in your applications home directory. See
656							L<Catalyst::Plugin::ConfigLoader>.
657
658							---
659							db: dsn:SQLite:foo.db
660
661
662							=cut
663
664							sub config {
665	347			347	1	16839	my $c = shift;
666
667	347	50	66			5062	$c->log->warn("Setting config after setup has been run is not a good idea.")
668							if ( @_ and $c->setup_finished );
669
670	347					13881	$c->NEXT::config(@_);
671							}
672
673							=head2 $c->log
674
675							Returns the logging object instance. Unless it is already set, Catalyst
676							sets this up with a L<Catalyst::Log> object. To use your own log class,
677							set the logger with the C<< __PACKAGE__->log >> method prior to calling
678							C<< __PACKAGE__->setup >>.
679
680							__PACKAGE__->log( MyLogger->new );
681							__PACKAGE__->setup;
682
683							And later:
684
685							$c->log->info( 'Now logging with my own logger!' );
686
687							Your log class should implement the methods described in
688							L<Catalyst::Log>.
689
690
691							=head2 $c->debug
692
693							Overload to enable debug messages (same as -Debug option).
694
695							Note that this is a static method, not an accessor and should be overloaded
696							by declaring "sub debug { 1 }" in your MyApp.pm, not by calling $c->debug(1).
697
698							=cut
699
700	25543			25543	1	592010	sub debug { 0 }
701
702							=head2 $c->dispatcher
703
704							Returns the dispatcher instance. Stringifies to class name. See
705							L<Catalyst::Dispatcher>.
706
707							=head2 $c->engine
708
709							Returns the engine instance. Stringifies to the class name. See
710							L<Catalyst::Engine>.
711
712
713							=head2 UTILITY METHODS
714
715							=head2 $c->path_to(@path)
716
717							Merges C<@path> with C<< $c->config->{home} >> and returns a
718							L<Path::Class::Dir> object.
719
720							For example:
721
722							$c->path_to( 'db', 'sqlite.db' );
723
724							=cut
725
726							sub path_to {
727	2			2	1	25	my ( $c, @path ) = @_;
728	2					98	my $path = Path::Class::Dir->new( $c->config->{home}, @path );
729	2	50				22	if ( -d $path ) { return $path }
	0					0
730	2					1049	else { return Path::Class::File->new( $c->config->{home}, @path ) }
731							}
732
733							=head2 $c->plugin( $name, $class, @args )
734
735							Helper method for plugins. It creates a classdata accessor/mutator and
736							loads and instantiates the given class.
737
738							MyApp->plugin( 'prototype', 'HTML::Prototype' );
739
740							$c->prototype->define_javascript_functions;
741
742							=cut
743
744							sub plugin {
745	1			1	1	59	my ( $class, $name, $plugin, @args ) = @_;
746	1					31	$class->_register_plugin( $plugin, 1 );
747
748	1					10	eval { $plugin->import };
	1					20
749	1					27	$class->mk_classdata($name);
750	1					51	my $obj;
751	1					10	eval { $obj = $plugin->new(@args) };
	1					14
752
753	1	50				29	if ($@) {
754	0					0	Catalyst::Exception->throw( message =>
755							qq/Couldn't instantiate instant plugin "$plugin", "$@"/ );
756							}
757
758	1					14	$class->$name($obj);
759	1	50				45	$class->log->debug(qq/Initialized instant plugin "$plugin" as "$name"/)
760							if $class->debug;
761							}
762
763							=head2 MyApp->setup
764
765							Initializes the dispatcher and engine, loads any plugins, and loads the
766							model, view, and controller components. You may also specify an array
767							of plugins to load here, if you choose to not load them in the C<use
768							Catalyst> line.
769
770							MyApp->setup;
771							MyApp->setup( qw/-Debug/ );
772
773							=cut
774
775							sub setup {
776	51			51	1	737	my ( $class, @arguments ) = @_;
777
778	51	50				1534	$class->log->warn("Running setup twice is not a good idea.")
779							if ( $class->setup_finished );
780
781	51	50				2417	unless ( $class->isa('Catalyst') ) {
782
783	0					0	Catalyst::Exception->throw(
784							message => qq/'$class' does not inherit from Catalyst/ );
785							}
786
787	51	50				685	if ( $class->arguments ) {
788	51					546	@arguments = ( @arguments, @{ $class->arguments } );
	51					619
789							}
790
791							# Process options
792	51					699	my $flags = {};
793
794	51					684	foreach (@arguments) {
795
796	189	50				3476	if (/^-Debug$/) {
		50
797	0	0				0	$flags->{log} =
798							( $flags->{log} ) ? 'debug,' . $flags->{log} : 'debug';
799							}
800							elsif (/^-(\w+)=?(.*)$/) {
801	0					0	$flags->{ lc $1 } = $2;
802							}
803							else {
804	189					1624	push @{ $flags->{plugins} }, $_;
	189					2280
805							}
806							}
807
808	51					1027	$class->setup_home( delete $flags->{home} );
809
810	51					1803	$class->setup_log( delete $flags->{log} );
811	51					1264	$class->setup_plugins( delete $flags->{plugins} );
812	51					4297	$class->setup_dispatcher( delete $flags->{dispatcher} );
813	51					5151	$class->setup_engine( delete $flags->{engine} );
814
815	51					566	for my $flag ( sort keys %{$flags} ) {
	51					900
816
817	0	0				0	if ( my $code = $class->can( 'setup_' . $flag ) ) {
818	0					0	&$code( $class, delete $flags->{$flag} );
819							}
820							else {
821	0					0	$class->log->warn(qq/Unknown flag "$flag"/);
822							}
823							}
824
825	51					627	eval { require Catalyst::Devel; };
	51					953
826	51	50	33			2093	if( !$@ && $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::Devel::CATALYST_SCRIPT_GEN ) ) {
			33
827	0					0	$class->log->warn(<<"EOF");
828							You are running an old script!
829
830							Please update by running (this will overwrite existing files):
831							catalyst.pl -force -scripts $class
832
833							or (this will not overwrite existing files):
834							catalyst.pl -scripts $class
835
836							EOF
837							}
838
839	51	50				3533	if ( $class->debug ) {
840	0		0			0	my @plugins = map { "$_ " . ( $_->VERSION \|\| '' ) } $class->registered_plugins;
	0					0
841
842	0	0				0	if (@plugins) {
843	0					0	my $t = Text::SimpleTable->new(74);
844	0					0	$t->row($_) for @plugins;
	0					0
845	0					0	$class->log->debug( "Loaded plugins:\n" . $t->draw . "\n" );
846							}
847
848	0					0	my $dispatcher = $class->dispatcher;
849	0					0	my $engine = $class->engine;
850	0					0	my $home = $class->config->{home};
851
852	0					0	$class->log->debug(qq/Loaded dispatcher "$dispatcher"/);
853	0					0	$class->log->debug(qq/Loaded engine "$engine"/);
854
855	0	0				0	$home
		0
856							? ( -d $home )
857							? $class->log->debug(qq/Found home "$home"/)
858							: $class->log->debug(qq/Home "$home" doesn't exist/)
859							: $class->log->debug(q/Couldn't find home/);
860							}
861
862							# Call plugins setup
863							{
864	55			55		1981	no warnings qw/redefine/;
	55					580
	55					985
	51					554
865	51			4		968	local *setup = sub { };
	4					42
866	51					1516	$class->setup;
867							}
868
869							# Initialize our data structure
870	51					13895	$class->components( {} );
871
872	51					3152	$class->setup_components;
873
874	51	50				3396	if ( $class->debug ) {
875	0					0	my $t = Text::SimpleTable->new( [ 63, 'Class' ], [ 8, 'Type' ] );
876	0					0	for my $comp ( sort keys %{ $class->components } ) {
	0					0
877	0	0				0	my $type = ref $class->components->{$comp} ? 'instance' : 'class';
878	0					0	$t->row( $comp, $type );
879							}
880	0					0	$class->log->debug( "Loaded components:\n" . $t->draw . "\n" )
881	0	0				0	if ( keys %{ $class->components } );
882							}
883
884							# Add our self to components, since we are also a component
885	51					739	$class->components->{$class} = $class;
886
887	51					8619	$class->setup_actions;
888
889	50	50				792	if ( $class->debug ) {
890	0		0			0	my $name = $class->config->{name} \|\| 'Application';
891	0					0	$class->log->info("$name powered by Catalyst $Catalyst::VERSION");
892							}
893	50	50				791	$class->log->_flush() if $class->log->can('_flush');
894
895	50					2194	$class->setup_finished(1);
896							}
897
898							=head2 $c->uri_for( $path, @args?, \%query_values? )
899
900							Merges path with C<< $c->request->base >> for absolute URIs and with
901							C<< $c->namespace >> for relative URIs, then returns a normalized L<URI>
902							object. If any args are passed, they are added at the end of the path.
903							If the last argument to C<uri_for> is a hash reference, it is assumed to
904							contain GET parameter key/value pairs, which will be appended to the URI
905							in standard fashion.
906
907							Instead of C<$path>, you can also optionally pass a C<$action> object
908							which will be resolved to a path using
909							C<< $c->dispatcher->uri_for_action >>; if the first element of
910							C<@args> is an arrayref it is treated as a list of captures to be passed
911							to C<uri_for_action>.
912
913							=cut
914
915							sub uri_for {
916	30			30	1	644	my ( $c, $path, @args ) = @_;
917	30					651	my $base = $c->request->base->clone;
918	30					1048	my $basepath = $base->path;
919	30					373	$basepath =~ s/\/$//;
920	30					273	$basepath .= '/';
921	30		100			1212	my $namespace = $c->namespace \|\| '';
922
923	30	100				470	if ( Scalar::Util::blessed($path) ) { # action object
924	18	100	100			303	my $captures = ( scalar @args && ref $args[0] eq 'ARRAY'
925							? shift(@args)
926							: [] );
927	18					234	$path = $c->dispatcher->uri_for_action($path, $captures);
928	18	100				238	return undef unless defined($path);
929	15	50				157	$path = '/' if $path eq '';
930							}
931
932							# massage namespace, empty if absolute path
933	27	100				2467	$namespace =~ s/^\/// if $namespace;
934	27	100				327	$namespace .= '/' if $namespace;
935	27		100			261	$path \|\|= '';
936	27	100				318	$namespace = '' if $path =~ /^\//;
937	27					253	$path =~ s/^\///;
938	27					267	$path =~ s/\?/%3F/g;
939
940	27	100	100			447	my $params =
941							( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
942
943	27					1239	for my $value ( values %$params ) {
944	9	100				110	next unless defined $value;
945	8	50				99	for ( ref $value eq 'ARRAY' ? @$value : $value ) {
946	8					238	$_ = "$_";
947	8					182	utf8::encode( $_ );
948							}
949							};
950
951							# join args with '/', or a blank string
952	27	100				299	my $args = ( scalar @args ? '/' . join( '/', map {s/\?/%3F/g; $_} @args ) : '' );
	27					247
	27					298
953	27	100				277	$args =~ s/^\/// unless $path;
954	27					429	my $res =
955							URI->new_abs( URI->new_abs( "$path$args", "$basepath$namespace" ), $base )
956							->canonical;
957	27					584	$res->query_form(%$params);
958	27					789	$res;
959							}
960
961							=head2 $c->welcome_message
962
963							Returns the Catalyst welcome HTML page.
964
965							=cut
966
967							sub welcome_message {
968	0			0	1	0	my $c = shift;
969	0					0	my $name = $c->config->{name};
970	0					0	my $logo = $c->uri_for('/static/images/catalyst_logo.png');
971	0					0	my $prefix = Catalyst::Utils::appprefix( ref $c );
972	0					0	$c->response->content_type('text/html; charset=utf-8');
973	0					0	return <<"EOF";
974							<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
975							"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
976							<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
977							<head>
978							<meta http-equiv="Content-Language" content="en" />
979							<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
980							<title>$name on Catalyst $VERSION</title>
981							<style type="text/css">
982							body {
983							color: #000;
984							background-color: #eee;
985							}
986							div#content {
987							width: 640px;
988							margin-left: auto;
989							margin-right: auto;
990							margin-top: 10px;
991							margin-bottom: 10px;
992							text-align: left;
993							background-color: #ccc;
994							border: 1px solid #aaa;
995							}
996							p, h1, h2 {
997							margin-left: 20px;
998							margin-right: 20px;
999							font-family: verdana, tahoma, sans-serif;
1000							}
1001							a {
1002							font-family: verdana, tahoma, sans-serif;
1003							}
1004							:link, :visited {
1005							text-decoration: none;
1006							color: #b00;
1007							border-bottom: 1px dotted #bbb;
1008							}
1009							:link:hover, :visited:hover {
1010							color: #555;
1011							}
1012							div#topbar {
1013							margin: 0px;
1014							}
1015							pre {
1016							margin: 10px;
1017							padding: 8px;
1018							}
1019							div#answers {
1020							padding: 8px;
1021							margin: 10px;
1022							background-color: #fff;
1023							border: 1px solid #aaa;
1024							}
1025							h1 {
1026							font-size: 0.9em;
1027							font-weight: normal;
1028							text-align: center;
1029							}
1030							h2 {
1031							font-size: 1.0em;
1032							}
1033							p {
1034							font-size: 0.9em;
1035							}
1036							p img {
1037							float: right;
1038							margin-left: 10px;
1039							}
1040							span#appname {
1041							font-weight: bold;
1042							font-size: 1.6em;
1043							}
1044							</style>
1045							</head>
1046							<body>
1047							<div id="content">
1048							<div id="topbar">
1049							<h1><span id="appname">$name</span> on <a href="http://catalyst.perl.org">Catalyst</a>
1050							$VERSION</h1>
1051							</div>
1052							<div id="answers">
1053							<p>
1054							<img src="$logo" alt="Catalyst Logo" />
1055							</p>
1056							<p>Welcome to the world of Catalyst.
1057							This <a href="http://en.wikipedia.org/wiki/MVC">MVC</a>
1058							framework will make web development something you had
1059							never expected it to be: Fun, rewarding, and quick.</p>
1060							<h2>What to do now?</h2>
1061							<p>That really depends on what <b>you</b> want to do.
1062							We do, however, provide you with a few starting points.</p>
1063							<p>If you want to jump right into web development with Catalyst
1064							you might want want to start with a tutorial.</p>
1065							<pre>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
1066							</pre>
1067							<p>Afterwards you can go on to check out a more complete look at our features.</p>
1068							<pre>
1069							<code>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Intro.pod">Catalyst::Manual::Intro</a>
1070							<!-- Something else should go here, but the Catalyst::Manual link seems unhelpful -->
1071							</code></pre>
1072							<h2>What to do next?</h2>
1073							<p>Next it's time to write an actual application. Use the
1074							helper scripts to generate <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AController%3A%3A&mode=all">controllers</a>,
1075							<a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&mode=all">models</a>, and
1076							<a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&mode=all">views</a>;
1077							they can save you a lot of work.</p>
1078							<pre><code>script/${prefix}_create.pl -help</code></pre>
1079							<p>Also, be sure to check out the vast and growing
1080							collection of <a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3APlugin%3A%3A&mode=all">plugins for Catalyst on CPAN</a>;
1081							you are likely to find what you need there.
1082							</p>
1083
1084							<h2>Need help?</h2>
1085							<p>Catalyst has a very active community. Here are the main places to
1086							get in touch with us.</p>
1087							<ul>
1088							<li>
1089							<a href="http://dev.catalyst.perl.org">Wiki</a>
1090							</li>
1091							<li>
1092							<a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
1093							</li>
1094							<li>
1095							<a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
1096							</li>
1097							</ul>
1098							<h2>In conclusion</h2>
1099							<p>The Catalyst team hopes you will enjoy using Catalyst as much
1100							as we enjoyed making it. Please contact us if you have ideas
1101							for improvement or other feedback.</p>
1102							</div>
1103							</div>
1104							</body>
1105							</html>
1106							EOF
1107							}
1108
1109							=head1 INTERNAL METHODS
1110
1111							These methods are not meant to be used by end users.
1112
1113							=head2 $c->components
1114
1115							Returns a hash of components.
1116
1117							=head2 $c->context_class
1118
1119							Returns or sets the context class.
1120
1121							=head2 $c->counter
1122
1123							Returns a hashref containing coderefs and execution counts (needed for
1124							deep recursion detection).
1125
1126							=head2 $c->depth
1127
1128							Returns the number of actions on the current internal execution stack.
1129
1130							=head2 $c->dispatch
1131
1132							Dispatches a request to actions.
1133
1134							=cut
1135
1136	817			817	1	11385	sub dispatch { my $c = shift; $c->dispatcher->dispatch( $c, @_ ) }
	817					11191
1137
1138							=head2 $c->dispatcher_class
1139
1140							Returns or sets the dispatcher class.
1141
1142							=head2 $c->dump_these
1143
1144							Returns a list of 2-element array references (name, structure) pairs
1145							that will be dumped on the error page in debug mode.
1146
1147							=cut
1148
1149							sub dump_these {
1150	0			0	1	0	my $c = shift;
1151	0					0	[ Request => $c->req ],
1152							[ Response => $c->res ],
1153							[ Stash => $c->stash ],
1154							[ Config => $c->config ];
1155							}
1156
1157							=head2 $c->engine_class
1158
1159							Returns or sets the engine class.
1160
1161							=head2 $c->execute( $class, $coderef )
1162
1163							Execute a coderef in given class and catch exceptions. Errors are available
1164							via $c->error.
1165
1166							=cut
1167
1168							sub execute {
1169	8460			8460	1	3520060	my ( $c, $class, $code ) = @_;
1170	8460		33			120496	$class = $c->component($class) \|\| $class;
1171	8460					139911	$c->state(0);
1172
1173	8460	100				396999	if ( $c->depth >= $RECURSION ) {
1174	1					15	my $action = "$code";
1175	1	50				20	$action = "/$action" unless $action =~ /->/;
1176	1					16	my $error = qq/Deep recursion detected calling "$action"/;
1177	1					16	$c->log->error($error);
1178	1					48	$c->error($error);
1179	1					15	$c->state(0);
1180	1					28	return $c->state;
1181							}
1182
1183	8459	50				1804744	my $stats_info = $c->_stats_start_execute( $code ) if $c->debug;
1184
1185	8459					123247	push( @{ $c->stack }, $code );
	8459					131792
1186
1187	8459		100			286136	eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) \|\| 0 ) };
	8459					110443
	8459					140726
1188
1189	8456	50	33			553823	$c->_stats_finish_execute( $stats_info ) if $c->debug and $stats_info;
1190
1191	8456					118653	my $last = pop( @{ $c->stack } );
	8456					165363
1192
1193	8456	100				350030	if ( my $error = $@ ) {
1194	26	100	66			405	if ( !ref($error) and $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
	24	100				247
1195							else {
1196	2	50				23	unless ( ref $error ) {
1197	55			55		7230	no warnings 'uninitialized';
	55					800
	55					937
1198	2					49	chomp $error;
1199	2					28	my $class = $last->class;
1200	2					50	my $name = $last->name;
1201	2					49	$error = qq/Caught exception in $class->$name "$error"/;
1202							}
1203	2					39	$c->error($error);
1204	2					27	$c->state(0);
1205							}
1206							}
1207	8444					153363	return $c->state;
1208							}
1209
1210							sub _stats_start_execute {
1211	0			0		0	my ( $c, $code ) = @_;
1212
1213	0	0	0			0	return if ( ( $code->name =~ /^_.*/ )
1214							&& ( !$c->config->{show_internal_actions} ) );
1215
1216	0					0	$c->counter->{"$code"}++;
1217
1218	0					0	my $action = "$code";
1219	0	0				0	$action = "/$action" unless $action =~ /->/;
1220
1221							# determine if the call was the result of a forward
1222							# this is done by walking up the call stack and looking for a calling
1223							# sub of Catalyst::forward before the eval
1224	0					0	my $callsub = q{};
1225	0					0	for my $index ( 2 .. 11 ) {
1226							last
1227	0	0	0			0	if ( ( caller($index) )[0] eq 'Catalyst'
1228							&& ( caller($index) )[3] eq '(eval)' );
1229
1230	0	0				0	if ( ( caller($index) )[3] =~ /forward$/ ) {
1231	0					0	$callsub = ( caller($index) )[3];
1232	0					0	$action = "-> $action";
1233	0					0	last;
1234							}
1235							}
1236
1237	0					0	my $node = Tree::Simple->new(
1238							{
1239							action => $action,
1240							elapsed => undef, # to be filled in later
1241							comment => "",
1242							}
1243							);
1244	0					0	$node->setUID( "$code" . $c->counter->{"$code"} );
1245
1246							# is this a root-level call or a forwarded call?
1247	0	0				0	if ( $callsub =~ /forward$/ ) {
1248
1249							# forward, locate the caller
1250	0	0				0	if ( my $parent = $c->stack->[-1] ) {
1251	0					0	my $visitor = Tree::Simple::Visitor::FindByUID->new;
1252	0					0	$visitor->searchForUID(
1253							"$parent" . $c->counter->{"$parent"} );
1254	0					0	$c->stats->accept($visitor);
1255	0	0				0	if ( my $result = $visitor->getResult ) {
1256	0					0	$result->addChild($node);
1257							}
1258							}
1259							else {
1260
1261							# forward with no caller may come from a plugin
1262	0					0	$c->stats->addChild($node);
1263							}
1264							}
1265							else {
1266
1267							# root-level call
1268	0					0	$c->stats->addChild($node);
1269							}
1270
1271							return {
1272	0					0	start => [gettimeofday],
1273							node => $node,
1274							};
1275							}
1276
1277							sub _stats_finish_execute {
1278	0			0		0	my ( $c, $info ) = @_;
1279	0					0	my $elapsed = tv_interval $info->{start};
1280	0					0	my $value = $info->{node}->getNodeValue;
1281	0					0	$value->{elapsed} = sprintf( '%fs', $elapsed );
1282							}
1283
1284							=head2 $c->_localize_fields( sub { }, \%keys );
1285
1286							=cut
1287
1288							sub _localize_fields {
1289	0			0		0	my ( $c, $localized, $code ) = ( @_ );
1290
1291	0		0			0	my $request = delete $localized->{request} \|\| {};
1292	0		0			0	my $response = delete $localized->{response} \|\| {};
1293
1294	0					0	local @{ $c }{ keys %$localized } = values %$localized;
	0					0
1295	0					0	local @{ $c->request }{ keys %$request } = values %$request;
	0					0
1296	0					0	local @{ $c->response }{ keys %$response } = values %$response;
	0					0
1297
1298	0					0	$code->();
1299							}
1300
1301							=head2 $c->finalize
1302
1303							Finalizes the request.
1304
1305							=cut
1306
1307							sub finalize {
1308	816			816	1	12032	my $c = shift;
1309
1310	816					11379	for my $error ( @{ $c->error } ) {
	816					17745
1311	14					209	$c->log->error($error);
1312							}
1313
1314							# Allow engine to handle finalize flow (for POE)
1315	816	50				24776	if ( $c->engine->can('finalize') ) {
1316	0					0	$c->engine->finalize($c);
1317							}
1318							else {
1319
1320	816					45725	$c->finalize_uploads;
1321
1322							# Error
1323	816	100				9645	if ( $#{ $c->error } >= 0 ) {
	816					12823
1324	14					384	$c->finalize_error;
1325							}
1326
1327	816					14907	$c->finalize_headers;
1328
1329							# HEAD request
1330	816	100				34544	if ( $c->request->method eq 'HEAD' ) {
1331	1					12	$c->response->body('');
1332							}
1333
1334	816					16547	$c->finalize_body;
1335							}
1336
1337	816	50				14281	if ($c->debug) {
1338	0					0	my $elapsed = sprintf '%f', tv_interval($c->stats->getNodeValue);
1339	0	0				0	my $av = sprintf '%.3f', ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
1340
1341	0					0	my $t = Text::SimpleTable->new( [ 62, 'Action' ], [ 9, 'Time' ] );
1342							$c->stats->traverse(
1343							sub {
1344	0			0		0	my $action = shift;
1345	0					0	my $stat = $action->getNodeValue;
1346	0		0			0	$t->row( ( q{ } x $action->getDepth ) . $stat->{action} . $stat->{comment},
1347							$stat->{elapsed} \|\| '??' );
1348							}
1349	0					0	);
1350
1351	0					0	$c->log->info(
1352							"Request took ${elapsed}s ($av/s)\n" . $t->draw . "\n" );
1353							}
1354
1355	816					11758	return $c->response->status;
1356							}
1357
1358							=head2 $c->finalize_body
1359
1360							Finalizes body.
1361
1362							=cut
1363
1364	816			816	1	9584	sub finalize_body { my $c = shift; $c->engine->finalize_body( $c, @_ ) }
	816					25151
1365
1366							=head2 $c->finalize_cookies
1367
1368							Finalizes cookies.
1369
1370							=cut
1371
1372	816			816	1	8666	sub finalize_cookies { my $c = shift; $c->engine->finalize_cookies( $c, @_ ) }
	816					16764
1373
1374							=head2 $c->finalize_error
1375
1376							Finalizes error.
1377
1378							=cut
1379
1380	14			14	1	518	sub finalize_error { my $c = shift; $c->engine->finalize_error( $c, @_ ) }
	14					195
1381
1382							=head2 $c->finalize_headers
1383
1384							Finalizes headers.
1385
1386							=cut
1387
1388							sub finalize_headers {
1389	846			846	1	30650	my $c = shift;
1390
1391							# Check if we already finalized headers
1392	846	100				15043	return if $c->response->{_finalized_headers};
1393
1394							# Handle redirects
1395	816	100				30509	if ( my $location = $c->response->redirect ) {
1396	5	50				122	$c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
1397	5					57	$c->response->header( Location => $location );
1398
1399	5	50				930	if ( !$c->response->body ) {
1400							# Add a default body if none is already present
1401	5					746	$c->response->body(
1402							qq{<html><body><p>This item has moved <a href="$location">here</a>.</p></body></html>}
1403							);
1404							}
1405							}
1406
1407							# Content-Length
1408	816	100	66			21139	if ( $c->response->body && !$c->response->content_length ) {
1409
1410							# get the length from a filehandle
1411	797	100	66			102950	if ( blessed( $c->response->body ) && $c->response->body->can('read') )
1412							{
1413	2	50				24	if ( my $stat = stat $c->response->body ) {
1414	2					157	$c->response->content_length( $stat->size );
1415							}
1416							else {
1417	0					0	$c->log->warn('Serving filehandle without a content-length');
1418							}
1419							}
1420							else {
1421	795					12638	$c->response->content_length( bytes::length( $c->response->body ) );
1422							}
1423							}
1424
1425							# Errors
1426	816	50				114454	if ( $c->response->status =~ /^(1\d\d\|[23]04)$/ ) {
1427	0					0	$c->response->headers->remove_header("Content-Length");
1428	0					0	$c->response->body('');
1429							}
1430
1431	816					20639	$c->finalize_cookies;
1432
1433	816					11237	$c->engine->finalize_headers( $c, @_ );
1434
1435							# Done
1436	816					518195	$c->response->{_finalized_headers} = 1;
1437							}
1438						</