File Coverage

blib/lib/Gantry.pm

Criterion	Covered	Total	%
statement	52	421	12.3
branch	14	188	7.4
condition	5	80	6.2
subroutine	8	79	10.1
pod	70	70	100.0
total	149	838	17.7

line	stmt	bran	cond	sub	pod	time	code
1							package Gantry;
2
3	5			5		41497	use strict;
	5					10
	5					167
4	5			5		2433	use Gantry::Stash;
	5					12
	5					132
5	5			5		2644	use Gantry::Init;
	5					13
	5					119
6	5			5		8396	use CGI::Simple;
	5					98152
	5					47
7	5			5		272	use File::Spec;
	5					12
	5					148
8	5			5		6284	use POSIX qw( strftime );
	5					49242
	5					39
9
10							############################################################
11							# Variables #
12							############################################################
13							our $VERSION = '3.64';
14							our $DEFAULT_PLUGIN_TEMPLATE = 'Gantry::Template::Default';
15							our $DEFAULT_STATE_MACHINE = 'Gantry::State::Default';
16							our $CONF;
17							our $engine_cycle = 0;
18							my %plugin_callbacks;
19
20							############################################################
21							# Functions #
22							############################################################
23
24							#-------------------------------------------------
25							# $self->handler( $r );
26							#-------------------------------------------------
27							sub handler : method {
28	0			0	1	0	my $class = shift;
29	0					0	my $r_or_cgi = shift;
30	0					0	my $self = bless( {}, $class );
31
32	0					0	my $status;
33
34							# Create the stash object
35	0					0	$self->make_stash();
36	0					0	$self->_increment_engine_cycle();
37
38							# die if we don't know the engine
39	0	0				0	if ( ! $self->can( 'engine' ) ) {
40	0					0	die( 'No engine specified, engine required' );
41							}
42
43							# initialize the engine
44	0					0	$self->engine_init( $r_or_cgi );
45
46							# handle the request
47	0					0	$status = $self->state_run($r_or_cgi, \%plugin_callbacks);
48
49	0					0	return $status;
50
51							} # end handler
52
53							#-------------------------------------------------
54							# $self->gantry_version( )
55							#-------------------------------------------------
56							sub gantry_version {
57	0			0	1	0	return $VERSION;
58							}
59
60							#-------------------------------------------------
61							# $self->make_stash( )
62							#-------------------------------------------------
63							sub make_stash {
64	0			0	1	0	my $self = shift;
65
66	0					0	$self->{__STASH__} = stash->new();
67
68							} # end make_stash
69
70							#-------------------------------------------------
71							# $self->stash( )
72							#-------------------------------------------------
73							sub stash {
74	0			0	1	0	my $self = shift;
75
76	0	0				0	$self->{__STASH__} = stash->new() unless defined $self->{__STASH__};
77
78	0					0	return $self->{__STASH__};
79
80							} # end stash
81
82							#-------------------------------------------------
83							# $self->engine_cycle()
84							#-------------------------------------------------
85							sub engine_cycle {
86	0			0	1	0	my ( $self ) = ( shift );
87
88	0					0	return( $engine_cycle );
89
90							} # end engine_cycle
91
92							#-------------------------------------------------
93							# $self->_increment_engine_cycle()
94							#-------------------------------------------------
95							sub _increment_engine_cycle {
96	0			0		0	my ( $self ) = ( shift );
97
98	0					0	++$engine_cycle;
99
100							} # end _increment_engine_cycle
101
102							#-------------------------------------------------
103							# $self->declined( value )
104							#-------------------------------------------------
105							sub declined {
106	0			0	1	0	my ( $self, $p ) = ( shift, shift );
107
108	0	0				0	$$self{__DECLINED__} = $p if defined $p;
109	0					0	return( $$self{__DECLINED__} );
110
111							} # end declined
112
113							#-------------------------------------------------
114							# $self->gantry_response_page( value )
115							#-------------------------------------------------
116							sub gantry_response_page {
117	0			0	1	0	my ( $self, $p ) = ( shift, shift );
118
119	0	0				0	$$self{__RESPONSE_PAGE__} = $p if defined $p;
120	0					0	return( $$self{__RESPONSE_PAGE__} );
121
122							} # end gantry_response_page
123
124							#-------------------------------------------------
125							# $self->redirect( value )
126							#-------------------------------------------------
127							sub redirect {
128	0			0	1	0	my ( $self, $p ) = ( shift, shift );
129
130	0	0				0	$$self{__REDIRECT__} = $p if defined $p;
131	0					0	return( $$self{__REDIRECT__} );
132
133							} # end redirect
134
135							#-------------------------------------------------
136							# $self->status( value )
137							#-------------------------------------------------
138							sub status {
139	0			0	1	0	my ( $self, $p ) = ( shift, shift );
140
141	0	0				0	$$self{__STATUS__} = $p if defined $p;
142	0					0	return( $$self{__STATUS__} );
143
144							} # end status
145
146							#-----------------------------------------------------------------
147							# $self->smtp_host( value )
148							#-----------------------------------------------------------------
149							sub smtp_host {
150	0			0	1	0	my ( $self, $p ) = @_;
151
152	0	0				0	$$self{__SMTP_HOST__} = $p if defined $p;
153	0					0	return( $$self{__SMTP_HOST__} );
154
155							} # end smtp_host
156
157							#-------------------------------------------------
158							# $self->get_cookies
159							#-------------------------------------------------
160							sub get_cookies {
161	0			0	1	0	my ( $self, $want_cookie ) = ( shift, shift );
162
163							# return the cookies if previously parsed
164	0	0				0	if ( $self->{__PARSED_COOKIES__} ) {
165
166	0	0				0	return $self->{__PARSED_COOKIES__}->{$want_cookie}
167							if defined $want_cookie;
168
169	0					0	return $self->{__PARSED_COOKIES__};
170							}
171
172	0		0			0	my $client =
173							$self->header_in( 'Cookie' ) \|\| $self->header_in( 'HTTP_COOKIE' );
174
175	0	0				0	return () if ( ! defined $client );
176
177	0					0	my %cookies;
178
179	0					0	for my $crumb ( split ( /; /, $client ) ) {
180	0					0	my ( $key, $value ) = split( /=/, $crumb );
181	0					0	$cookies{$key} = $value;
182							}
183
184	0					0	$self->{__PARSED_COOKIES__} = \%cookies;
185
186	0	0				0	if ( defined $want_cookie ) {
187	0					0	return( $cookies{$want_cookie} );
188							}
189							else {
190	0					0	return( \%cookies );
191							}
192
193							} # end get_cookies
194
195							#-------------------------------------------------
196							# set_cookie( { @options } )
197							# name => cookie name
198							# value => cookie value
199							# expire => cookie expires
200							# path => cookie path
201							# domain => cookie domain
202							# secure => [0/1] cookie secure
203							#-------------------------------------------------
204							sub set_cookie {
205	0			0	1	0	my ( $self, @opts ) = @_;
206
207	0	0	0			0	my $options = (@opts == 1) && UNIVERSAL::isa($opts[0], 'HASH')
208							? shift(@opts) : { @opts };
209
210	0	0				0	croak( 'Cookie has no name' ) if ( ! defined $$options{name} );
211	0	0				0	croak( 'Cookie has no value' ) if ( ! defined $$options{value} );
212
213							# Only required fields in the cookie.
214	0					0	my $cookie = sprintf( "%s=%s; ", $$options{name}, $$options{value} );
215
216
217
218	0	0				0	$cookie .= sprintf( "path=%s; ", $$options{path} )
219							if ( defined $$options{path} );
220	0	0				0	$cookie .= sprintf( "domain=%s; ", $$options{domain} )
221							if ( defined $$options{domain} );
222	0	0	0			0	$cookie .= 'secure'
223							if ( defined $$options{secure} && $$options{secure} );
224
225							# these are all optional. and should be created as such.
226	0	0				0	if ( defined $$options{expire} ) {
227	0	0				0	$$options{expire} = 0 if ( $$options{expire} !~ /^\d+$/ );
228	0					0	$cookie .= strftime( "expires=%a, %d-%b-%Y %H:%M:%S GMT; ",
229							gmtime( time + $$options{expire} ) );
230							}
231
232	0					0	$cookie =~ s/\;\s*$/ /;
233
234	0					0	$self->err_header_out( 'Set-Cookie', $cookie ); # mp13 mp20
235	0					0	$self->cookie_stash( $cookie ); # cgi
236
237	0					0	return();
238
239							} # end set_cookies
240
241							sub cookie_stash {
242	0			0	1	0	my ( $self, $p ) = @_;
243
244	0	0				0	$self->{__COOKIE_STASH__} = []
245							unless defined $self->{__COOKIE_STASH__};
246
247	0	0				0	if ( defined $p ) {
248	0					0	push( @{ $self->{__COOKIE_STASH__} }, $p );
	0					0
249							}
250	0					0	return( $self->{__COOKIE_STASH__} );
251
252							} # end method
253
254							sub response_headers {
255	0			0	1	0	my ( $self, $key, $value ) = @_;
256
257	0	0				0	$self->{__RESPONSE_HEADERS__} = {}
258							unless defined $self->{__RESPONSE_HEADERS__};
259
260	0	0				0	if ( defined $key ) {
261	0					0	$self->{__RESPONSE_HEADERS__}{ $key } = $value;
262							}
263	0					0	return( $self->{__RESPONSE_HEADERS__} );
264
265							} # end method
266
267							#-------------------------------------------------
268							# $self->cleanroot( $uri, $root )
269							#-------------------------------------------------
270							sub cleanroot {
271	0			0	1	0	my ( $self, $uri, $root ) = @_;
272
273	0					0	$uri =~ s!^$root!!g;
274	0					0	$uri =~ s/\/\//\//g;
275	0					0	$uri =~ s/^\///;
276
277	0					0	return( split( '/', $uri ) );
278
279							} # end cleanroot
280
281							#-------------------------------------------------
282							# $self->import( $self, @options )
283							#-------------------------------------------------
284							sub import {
285	8			8		93	my ( $class, @options ) = @_;
286
287	8					16	my( $engine, $tplugin, $plugin, $splugin, $conf_instance, $conf_file );
288
289	8					17	my $plugin_namespace = 'Gantry';
290	8					15	my $plugin_dir = 'Gantry::Plugins';
291
292	8					29	foreach (@options) {
293
294							# Import the proper engine
295	5	100				61	if ( /^-Engine=(\S+)/ ) {
		50
		0
		0
		0
296	1	50				14	unless ( $class->can( 'engine' ) ) {
297	1					6	$engine = "Gantry::Engine::$1";
298	1					26	my $engine_file = File::Spec->catfile(
299							'Gantry', 'Engine', "${1}.pm"
300							);
301
302	1					4	eval {
303	1					731	require $engine_file;
304	1					273	$engine->import();
305							};
306
307	1	50				10	if ( $@ ) { die qq/Could not load engine "$engine", "$@"/ }
	0					0
308							}
309							}
310
311							# Load Template Engine
312							elsif ( /^-TemplateEngine=(\S+)/ ) {
313	4					22	$tplugin = "Gantry::Template::$1";
314	4					109	my $tfile = File::Spec->catfile(
315							'Gantry', 'Template', "${1}.pm"
316							);
317
318	4					437	eval qq[
319							package $plugin_namespace;
320							require "$tfile";
321							$tplugin->import();
322							];
323
324	4	50				34	if ($@) { die qq/Could not load plugin "$tplugin", "$@"/ }
	0					0
325							}
326
327							# Load the desired State Machine
328							elsif ( /^-StateMachine=(\S+)/ ) {
329	0					0	$splugin = "Gantry::State::$1";
330	0					0	my $sfile = File::Spec->catfile(
331							'Gantry', 'State', "${1}.pm"
332							);
333
334	0					0	eval qq[
335							package $plugin_namespace;
336							require "$sfile";
337							$splugin->import();
338							];
339
340	0	0				0	if ($@) { die qq/Could not load state machine "$splugin", "$@"/ }
	0					0
341							}
342
343							elsif ( /^-PluginNamespace=(\S+)/ ) {
344	0					0	$plugin_namespace = $1;
345							}
346
347							elsif ( /^-PluginDir=(\S+)/ ) {
348	0					0	$plugin_dir = $1;
349							}
350
351							else {
352	0					0	my @plugin_path;
353							my $plugin_file;
354	0					0	my $import_list = '';
355
356							# Check for plugin import list.
357							# Save list and strip it from the plugin.
358	0	0				0	if ( /\=(.*)$/o ) {
359	0					0	$import_list = $1;
360	0					0	$_ =~ s/=.*$//o;
361							}
362
363	0					0	$plugin = sprintf('%s::%s', $plugin_dir, $_);
364	0					0	@plugin_path = split /::/, $plugin . '.pm';
365
366	0					0	$plugin_file = File::Spec->catfile(
367							@plugin_path
368							);
369
370	0					0	eval qq[
371							package $plugin_namespace;
372							require "$plugin_file";
373							$plugin->import( qw( $import_list ) );
374							];
375
376	0	0				0	if ($@) { die qq/Could not load plugin "$plugin", "$@"/ }
	0					0
377
378	0					0	eval {
379	0	0				0	if ( $plugin_namespace eq 'Gantry' ) {
380	0					0	$plugin_namespace = $class->namespace;
381							}
382
383	0					0	my @new_callbacks = $plugin->get_callbacks(
384							$plugin_namespace
385							);
386
387	0					0	foreach my $callback ( @new_callbacks ) {
388							push @{
389							$plugin_callbacks{ $plugin_namespace }
390							{ $callback->{ phase } }
391	0					0	}, $callback->{ callback };
	0					0
392							}
393							};
394
395							# failure means not having to register callbacks
396							}
397							}
398
399							# Load Default template plugin if one hasn't been defined
400	8	100	66			95	if ( ! $tplugin && ! $class->can( 'do_action' ) ) {
401	1					15	my( $tengine ) = ( $DEFAULT_PLUGIN_TEMPLATE =~ m!::(\w+)$! );
402	1					25	my $def_tengine_file = File::Spec->catfile(
403							'Gantry', 'Template', "${tengine}.pm"
404							);
405
406	1					21	eval {
407	1					723	require $def_tengine_file;
408	1					46	import $DEFAULT_PLUGIN_TEMPLATE;
409							};
410	1	50				6	if ($@) { die qq/Could not load Default template engine, "$@"/ }
	0					0
411
412							}
413
414							# Load the default state machine if one hasn't been defined
415	8	100	66			185	if ( ! $splugin && ! $class->can( 'state_run' ) ) {
416
417	5					40	my( $sengine ) = ( $DEFAULT_STATE_MACHINE =~ m!::(\w+)$! );
418	5					79	my $def_sengine_file = File::Spec->catfile(
419							'Gantry', 'State', "${sengine}.pm"
420							);
421
422	5					68	eval {
423	5					3435	require $def_sengine_file;
424	5					249	import $DEFAULT_STATE_MACHINE;
425							};
426	5	50				2722	if ($@) { die qq/Could not load Default state machine, "$@"/ }
	0					0
427
428							}
429
430							}
431
432							#-------------------------------------------------
433							# $class->namespace or $site->namespace
434							#-------------------------------------------------
435							sub namespace {
436	0			0	1	0	return 'Gantry';
437							}
438
439							#-------------------------------------------------
440							# $site->init( $r )
441							# note: this function should be redefined in the application.
442							# This will act as the default but it's recommended
443							# that only global init rules are defined here
444							#
445							# application note: for "proper" or suggested practice,
446							# the application level init function should immeadiatly
447							# call:
448							#
449							# $site->SUPER::init( $r );
450							#
451							# After the call to SUPER, the application level init
452							# should include its init intructions.
453							#-------------------------------------------------
454							sub init {
455	0			0	1	0	my ( $self, $r_or_cgi ) = @_;
456
457	0					0	$self->uri( $self->fish_uri() );
458	0					0	$self->location( $self->fish_location() );
459	0					0	$self->path_info( $self->fish_path_info() );
460	0					0	$self->method( $self->fish_method() );
461	0	0				0	$self->protocol( $ENV{HTTPS} ? 'https://' : 'http://' );
462	0					0	$self->status( "" );
463
464	0	0				0	if (defined $plugin_callbacks{ $self->namespace }{ init }) {
465							# Do the plugin callbacks for the 'init' phase
466	0					0	foreach my $callback (sort
467	0					0	@{ $plugin_callbacks{ $self->namespace }{ init } }
468							) {
469	0					0	$callback->( $self );
470							}
471							}
472
473							# set post_max - used for apache request object
474	0		0			0	$self->post_max( $self->fish_config( 'post_max' ) \|\| '20000000' );
475
476							# set user varible
477	0					0	$self->user( $self->fish_user() );
478
479							# set default content-type
480	0		0			0	$self->content_type( $self->fish_config( 'content_type' ) \|\| 'text/html' );
481
482							# set template variables
483	0					0	$self->template( $self->fish_config( 'template' ) );
484	0					0	$self->template_default( $self->fish_config( 'template_default' ) );
485	0					0	$self->template_wrapper( $self->fish_config( 'template_wrapper' ) );
486	0					0	$self->template_disable( $self->fish_config( 'template_disable' ) );
487
488							# set application directory variables
489	0		0			0	my $app_root = $self->fish_config( 'root' ) \|\| '';
490
491	0					0	$self->root( $app_root );
492	0					0	$self->doc_root( $self->fish_config( 'doc_root' ) );
493	0					0	$self->css_root( $self->fish_config( 'css_root' ) );
494	0					0	$self->img_root( $self->fish_config( 'img_root' ) );
495	0					0	$self->js_root( $self->fish_config( 'js_root' ) );
496	0					0	$self->tmp_root( $self->fish_config( 'tmp_root' ) );
497
498							# set application uri variables
499	0					0	$self->doc_rootp( $self->fish_config( 'doc_rootp' ) );
500	0					0	$self->web_rootp( $self->fish_config( 'web_rootp' ) );
501	0					0	$self->app_rootp( $self->fish_config( 'app_rootp' ) );
502	0					0	$self->img_rootp( $self->fish_config( 'img_rootp' ) );
503	0					0	$self->css_rootp( $self->fish_config( 'css_rootp' ) );
504	0					0	$self->js_rootp( $self->fish_config( 'js_rootp' ) );
505	0					0	$self->tmp_rootp( $self->fish_config( 'tmp_rootp' ) );
506	0					0	$self->editor_rootp( $self->fish_config( 'editor_rootp' ) );
507
508							# set no cache
509	0					0	$self->no_cache( $self->fish_config( 'no_cache' ) );
510
511							# set page title
512	0		0			0	$self->page_title( $self->fish_config( 'page_title' ) \|\| $self->uri );
513
514							# set default date format
515	0		0			0	$self->date_fmt( $self->fish_config( 'date_fmt' ) \|\| '%b %d, %Y' );
516
517
518							# set request body paramater variables
519	0					0	$self->set_req_params();
520
521							# database and auth database variables are handled in each engine's
522							# Gantry::Utils::DBConnHelper::* sublcass.
523
524							} # END $site->init
525
526							#-------------------------------------------------
527							# $self->r( value )
528							#-------------------------------------------------
529							sub r {
530	0			0	1	0	my ( $self, $p ) = @_;
531
532	0	0				0	$self->{__R__} = $p if ( defined $p );
533	0					0	return( $self->{__R__} );
534
535							} # end r
536
537							#-------------------------------------------------
538							# $self->cgi( value )
539							#-------------------------------------------------
540							sub cgi {
541	0			0	1	0	my( $self, $p ) = @_;
542
543	0	0				0	$self->{__CGI__} = $p if ( defined $p );
544	0					0	return( $self->{__CGI__} );
545							} # end cgi
546
547							#-------------------------------------------------
548							# $self->method( value )
549							#-------------------------------------------------
550							sub method {
551	0			0	1	0	my ( $self, $p ) = @_;
552
553	0	0				0	$self->{__METHOD__} = $p if ( defined $p );
554	0					0	return( $self->{__METHOD__} );
555
556							} # end method
557
558							#-------------------------------------------------
559							# $self->no_cache( value )
560							#-------------------------------------------------
561							sub no_cache {
562	0			0	1	0	my ( $self, $p ) = @_;
563
564	0	0				0	$self->{__NO_CACHE__} = $p if ( defined $p );
565	0					0	return( $self->{__NO_CACHE__} );
566
567							} # end no_cache
568
569							#-------------------------------------------------
570							# $self->uri( value )
571							#-------------------------------------------------
572							sub uri {
573	0			0	1	0	my ( $self, $p ) = @_;
574
575	0	0				0	$self->{__URI__} = $p if ( defined $p );
576	0		0			0	return( $self->{__URI__} \|\| '' );
577
578							} # end uri
579
580							#-------------------------------------------------
581							# $self->location( value )
582							#-------------------------------------------------
583							sub location {
584	9			9	1	1713	my ( $self, $p ) = @_;
585
586	9	100				24	$self->{__LOCATION__} = $p if ( defined $p );
587	9		50			28	return( $self->{__LOCATION__} \|\| '' );
588
589							} # end location
590
591							#-------------------------------------------------
592							# $self->action( value )
593							#-------------------------------------------------
594							sub action {
595	0			0	1		my ( $self, $p ) = @_;
596
597	0	0					$self->{__ACTION__} = $p if ( defined $p );
598	0		0				return( $self->{__ACTION__} \|\| '' );
599
600							} # end action
601
602							#-------------------------------------------------
603							# $self->current_url( )
604							#-------------------------------------------------
605							sub current_url {
606	0			0	1		my ( $self ) = @_;
607
608	0						return $self->protocol . $self->base_server . $self->uri;
609							} # end location
610
611							#-------------------------------------------------
612							# $self->path_info( value )
613							#-------------------------------------------------
614							sub path_info {
615	0			0	1		my ( $self, $p ) = @_;
616
617	0	0					$self->{__PATH_INFO__} = $p if ( defined $p );
618	0		0				return( $self->{__PATH_INFO__} \|\| '' );
619
620							} # end path_info
621
622							#-------------------------------------------------
623							# $self->content_length( value )
624							#-------------------------------------------------
625							sub content_length {
626	0			0	1		my ( $self, $p ) = @_;
627
628	0	0					$self->{__CONTENT_LENGTH__} = $p if ( defined $p );
629	0						return( $self->{__CONTENT_LENGTH__} );
630
631							} # end content_length
632
633							#-------------------------------------------------
634							# $self->content_type( value )
635							#-------------------------------------------------
636							sub content_type {
637	0			0	1		my ( $self, $p ) = @_;
638
639	0	0					$self->{__CONTENT_TYPE__} = $p if ( defined $p );
640	0						return( $self->{__CONTENT_TYPE__} );
641
642							} # end content_type
643
644							#-------------------------------------------------
645							# $self->template( value )
646							#-------------------------------------------------
647							sub template {
648	0			0	1		my ( $self, $p ) = @_;
649
650	0	0					$self->{__TEMPLATE__} = $p if ( defined $p );
651	0						return( $self->{__TEMPLATE__} );
652
653							} # end template
654
655							#-------------------------------------------------
656							# $self->template_default( value )
657							#-------------------------------------------------
658							sub template_default {
659	0			0	1		my ( $self, $p ) = @_;
660
661	0	0					$self->{__TEMPLATE_DEFAULT__} = $p if ( defined $p );
662	0						return( $self->{__TEMPLATE_DEFAULT__} );
663
664							} # end template_default
665
666							#-------------------------------------------------
667							# $self->template_wrapper( value )
668							#-------------------------------------------------
669							sub template_wrapper {
670	0			0	1		my ( $self, $p ) = @_;
671
672	0	0					$self->{__TEMPLATE_WRAPPER__} = $p if ( defined $p );
673	0						return( $self->{__TEMPLATE_WRAPPER__} );
674
675							} # end template_wrapper
676
677							#-------------------------------------------------
678							# $self->template_disable( value )
679							#-------------------------------------------------
680							sub template_disable {
681	0			0	1		my ( $self, $p ) = @_;
682
683	0	0					$self->{__TEMPLATE_DISABLE__} = $p if ( defined $p );
684	0						return( $self->{__TEMPLATE_DISABLE__} );
685
686							} # end template_disable
687
688							#-------------------------------------------------
689							# $self->root( value )
690							#-------------------------------------------------
691							sub root {
692	0			0	1		my ( $self, $p ) = @_;
693
694	0	0					$self->{__ROOT__} = $p if ( defined $p );
695	0		0				return( $self->{__ROOT__} \|\| '' );
696
697							} # end root
698
699							#-------------------------------------------------
700							# $self->css_root( value )
701							#-------------------------------------------------
702							sub css_root {
703	0			0	1		my ( $self, $p ) = @_;
704
705	0	0					$self->{__CSS_ROOT__} = $p if ( defined $p );
706	0		0				return( $self->{__CSS_ROOT__} \|\| '' );
707
708							} # end css_root
709
710							#-------------------------------------------------
711							# $self->tmp_root( value )
712							#-------------------------------------------------
713							sub tmp_root {
714	0			0	1		my ( $self, $p ) = @_;
715
716	0	0					$self->{__TMP_ROOT__} = $p if ( defined $p );
717	0		0				return( $self->{__TMP_ROOT__} \|\| '' );
718
719							} # end tmp_root
720
721							#-------------------------------------------------
722							# $self->tmp_rootp( value )
723							#-------------------------------------------------
724							sub tmp_rootp {
725	0			0	1		my ( $self, $p ) = @_;
726
727	0	0					$self->{__TMP_ROOTP__} = $p if ( defined $p );
728	0		0				return( $self->{__TMP_ROOTP__} \|\| '' );
729
730							} # end tmp_rootp
731
732							#-------------------------------------------------
733							# $self->editor_rootp( value )
734							#-------------------------------------------------
735							sub editor_rootp {
736	0			0	1		my ( $self, $p ) = @_;
737
738	0	0					$self->{__EDITOR_ROOTP__} = $p if ( defined $p );
739	0		0				return( $self->{__EDITOR_ROOTP__} \|\| '' );
740
741							} # end editor_rootp
742
743							#-------------------------------------------------
744							# $self->img_root( value )
745							#-------------------------------------------------
746							sub img_root {
747	0			0	1		my ( $self, $p ) = @_;
748
749	0	0					$self->{__IMG_ROOT__} = $p if ( defined $p );
750	0		0				return( $self->{__IMG_ROOT__} \|\| '' );
751
752							} # end img_root
753
754							#-------------------------------------------------
755							# $self->js_root( value )
756							#-------------------------------------------------
757							sub js_root {
758	0			0	1		my ( $self, $p ) = @_;
759
760	0	0					$self->{__JS_ROOT__} = $p if ( defined $p );
761	0		0				return( $self->{__JS_ROOT__} \|\| '' );
762
763							} # end js_root
764
765							#-------------------------------------------------
766							# $self->app_rootp( value )
767							#-------------------------------------------------
768							sub app_rootp {
769	0			0	1		my ( $self, $p ) = @_;
770
771	0	0					if ( defined $p ) {
772							# trim trailing slashes
773	0						$p =~ s{/+$}{}g;
774
775	0						$self->{__APP_ROOTP__} = $p;
776							}
777	0		0				return( $self->{__APP_ROOTP__} \|\| '' );
778
779							} # end app_rootp
780
781							#-------------------------------------------------
782							# $self->web_rootp( value )
783							#-------------------------------------------------
784							sub web_rootp {
785	0			0	1		my ( $self, $p ) = @_;
786
787	0	0					$self->{__WEB_ROOTP__} = $p if ( defined $p );
788	0		0				return( $self->{__WEB_ROOTP__} \|\| '' );
789
790							} # end web_rootp
791
792							#-------------------------------------------------
793							# $self->doc_rootp( value )
794							#-------------------------------------------------
795							sub doc_rootp {
796	0			0	1		my ( $self, $p ) = @_;
797
798	0	0					$self->{__DOC_ROOTP__} = $p if ( defined $p );
799	0		0				return( $self->{__DOC_ROOTP__} \|\| '' );
800
801							} # end doc_rootp
802
803							#-------------------------------------------------
804							# $self->js_rootp( value )
805							#-------------------------------------------------
806							sub js_rootp {
807	0			0	1		my ( $self, $p ) = @_;
808
809	0	0					$self->{__JS_ROOTP__} = $p if ( defined $p );
810	0		0				return( $self->{__JS_ROOTP__} \|\| '' );
811
812							} # end js_rootp
813
814							#-------------------------------------------------
815							# $self->doc_root( value )
816							#-------------------------------------------------
817							sub doc_root {
818	0			0	1		my ( $self, $p ) = @_;
819
820	0	0					$self->{__DOC_ROOT__} = $p if ( defined $p );
821	0		0				return( $self->{__DOC_ROOT__} \|\| '' );
822
823							} # end doc_root
824
825							#-------------------------------------------------
826							# $self->img_rootp( value )
827							#-------------------------------------------------
828							sub img_rootp {
829	0			0	1		my ( $self, $p ) = @_;
830
831	0	0					if ( defined $p ) {
832							# trim trailing slashes
833	0						$p =~ s{/+$}{}g;
834
835	0						$self->{__IMG_ROOTP__} = $p;
836							}
837	0		0				return( $self->{__IMG_ROOTP__} \|\| '' );
838
839							} # end img_rootp
840
841							#-------------------------------------------------
842							# $self->css_rootp( value )
843							#-------------------------------------------------
844							sub css_rootp {
845	0			0	1		my ( $self, $p ) = @_;
846
847	0	0					if ( defined $p ) {
848							# trim trailing slashes
849	0						$p =~ s{/+$}{}g;
850
851	0						$self->{__CSS_ROOTP__} = $p;
852							}
853	0		0				return( $self->{__CSS_ROOTP__} \|\| '' );
854
855							} # end css_rootp
856
857							#-------------------------------------------------
858							# $self->page_title( value )
859							#-------------------------------------------------
860							sub page_title {
861	0			0	1		my ( $self, $p ) = @_;
862
863	0	0					$self->{__PAGE_TITLE__} = $p if ( defined $p );
864	0		0				return( $self->{__PAGE_TITLE__} \|\| '' );
865
866							} # end uri
867
868							#-------------------------------------------------
869							# $self->date_fmt( value )
870							#-------------------------------------------------
871							sub date_fmt {
872	0			0	1		my ( $self, $p ) = @_;
873
874	0	0					$self->{__DATE_FMT__} = $p if ( defined $p );
875	0						return( $self->{__DATE_FMT__} );
876
877							} # end date_fmt
878
879							#-------------------------------------------------
880							# $self->user( value )
881							#-------------------------------------------------
882							sub user {
883	0			0	1		my ( $self, $p ) = @_;
884
885	0	0					$self->{__USER__} = $p if ( defined $p );
886	0						return( $self->{__USER__} );
887
888							} # end user
889
890							#-------------------------------------------------
891							# $self->test( value )
892							#-------------------------------------------------
893							sub test {
894	0			0	1		my ( $self, $p ) = @_;
895
896	0	0					$self->{__TEST__} = $p if ( defined $p );
897	0						return( $self->{__TEST__} );
898
899							} # end test
900
901							#-------------------------------------------------
902							# $self->get_auth_model_name( )
903							#-------------------------------------------------
904							sub get_auth_model_name {
905	0			0	1		my ( $self ) = shift;
906
907	0		0				return $self->{__MODELS__}{__AUTH_USERS__}
908							\|\| 'Gantry::Control::Model::auth_users';
909							}
910
911							#-------------------------------------------------
912							# $self->set_auth_model_name( )
913							#-------------------------------------------------
914							sub set_auth_model_name {
915	0			0	1		my ( $self, $model ) = @_;
916
917	0	0					$model = $self->get_auth_model_name() unless $model;
918
919	0						$self->{__MODELS__}{__AUTH_USERS__} = $model;
920
921	0						my @pieces = split /::/, $model;
922	0						my $base = pop @pieces;
923
924	0						my $file_name = File::Spec->catfile( @pieces, "$base.pm" );
925
926	0						require $file_name;
927							}
928
929							#-------------------------------------------------
930							# $self->user_row( { model => '', user_name => '' } )
931							#-------------------------------------------------
932							sub user_row {
933	0			0	1		my ( $self, @opts ) = @_;
934
935	0	0	0				my $options = (@opts == 1) && UNIVERSAL::isa($opts[0], 'HASH')
936							? shift(@opts) : { @opts };
937
938	0						$self->set_auth_model_name( $options->{model} );
939
940	0	0					if ( defined $self->{__MODELS__}{__AUTH_USERS__} ) {
941
942							# use request user_name if passed to function
943	0	0					my $user_name = defined $options->{user_name} ?
944							$options->{user_name} : $self->user;
945
946	0						my @rows = $self->{__MODELS__}{__AUTH_USERS__}->search(
947							{ user_name => $user_name }, $self, undef
948							);
949
950	0	0					return( $rows[0] ) if @rows;
951							}
952							else {
953	0						die( "failed to lookup user: unknown auth_users model" );
954							}
955
956	0						return; # don't know
957
958							} # end user_row
959
960							#-------------------------------------------------
961							# $self->user_id( { model => '', user_name => '' } )
962							#-------------------------------------------------
963							sub user_id {
964	0			0	1		my ( $self, @opts ) = @_;
965
966	0						my $row = $self->user_row( @opts );
967
968	0	0					( defined $row ) ? return $row->user_id : return;
969							}
970
971							#-------------------------------------------------
972							# $self->post_max( value )
973							#-------------------------------------------------
974							sub post_max {
975	0			0	1		my ( $self, $p ) = @_;
976
977	0	0					$self->{__POST_MAX__} = $p if ( defined $p );
978	0						return( $self->{__POST_MAX__} );
979
980							} # end POST_MAX
981
982							#-------------------------------------------------
983							# $self->ap_req( value )
984							#-------------------------------------------------
985							sub ap_req {
986	0			0	1		my ( $self, $p ) = @_;
987
988	0	0	0				$self->{__AP_REQ__} = $p
989							if ( ( ! defined $self->{__AP_REQ__} ) and defined $p );
990
991	0						return( $self->{__AP_REQ__} );
992							} # end ap_req
993
994							#-------------------------------------------------
995							# $self->params( value )
996							#-------------------------------------------------
997							sub params {
998	0			0	1		my ( $self, $p ) = @_;
999
1000	0	0					$self->{__PARAMS__} = $p if ( defined $p );
1001	0						return( $self->{__PARAMS__} );
1002
1003							} # end params
1004
1005							#-------------------------------------------------
1006							# $self->uf_params( value )
1007							#-------------------------------------------------
1008							sub uf_params {
1009	0			0	1		my ( $self, $p ) = @_;
1010
1011	0	0					$self->{__UF_PARAMS__} = $p if ( defined $p );
1012	0						return( $self->{__UF_PARAMS__} );
1013
1014							} # end uf_params
1015
1016							#-------------------------------------------------
1017							# $self->get_param_hash()
1018							#-------------------------------------------------
1019							sub get_param_hash {
1020	0			0	1		my $self = shift;
1021
1022	0						my %param = ();
1023
1024	0						eval {
1025	0						%param = %{ $self->params };
	0
1026							};
1027	0	0					if ( $@ ) {
1028	0						die "$@";
1029							}
1030
1031	0	0					return wantarray ? %param : \%param;
1032
1033							} # end get_param_hash
1034
1035							#-------------------------------------------------
1036							# $self->get_uf_param_hash()
1037							#-------------------------------------------------
1038							sub get_uf_param_hash {
1039	0			0	1		my $self = shift;
1040
1041	0						my %param = ();
1042
1043	0						eval {
1044	0						%param = %{ $self->uf_params };
	0
1045							};
1046	0	0					if ( $@ ) {
1047	0						die "$@";
1048							}
1049
1050	0	0					return wantarray ? %param : \%param;
1051
1052							} # end get_uf_param_hash
1053
1054							#-------------------------------------------------
1055							# $self->protocol( value )
1056							#-------------------------------------------------
1057							sub protocol {
1058	0			0	1		my ( $self, $p ) = @_;
1059
1060	0	0					$self->{__PROTOCOL__} = $p if ( defined $p );
1061	0						return( $self->{__PROTOCOL__} );
1062
1063							} # end protocol
1064
1065							#-------------------------------------------------
1066							# $self->is_post()
1067							#-------------------------------------------------
1068							sub is_post {
1069	0			0	1		my ( $self ) = @_;
1070
1071	0	0					return( $self->method eq 'POST' ? 1 : 0 );
1072
1073							} # end is_post
1074
1075							#-------------------------------------------------
1076							# $self->gantry_secret()
1077							#-------------------------------------------------
1078							sub gantry_secret {
1079	0			0	1		my ( $self ) = @_;
1080
1081	0		0				return $self->fish_config( 'gantry_secret' ) \|\| 'w3s3cR7';
1082							} # end gantry_secret
1083
1084							#-------------------------------------------------
1085							# $self->controller_config()
1086							#-------------------------------------------------
1087							sub controller_config {
1088	0			0	1		return {};
1089							} # end controller_config
1090
1091							##-------------------------------------------------
1092							## $self->get_conf( )
1093							##-------------------------------------------------
1094							#sub get_conf {
1095							# my $class = shift;
1096							# my $instance = shift;
1097							# my $file = shift;
1098							#
1099							# return Gantry::Conf->retrieve(
1100							# $instance,
1101							# $file
1102							# );
1103							#}
1104
1105							#-------------------------------------------------
1106							# $self->cleanup( $r )
1107							# note: this function should be redefined in the application.
1108							# This will act as the default but it's recommended
1109							# that only global cleanup rules are defined here
1110							#
1111							# application note: for "proper" or suggested practice,
1112							# the application level cleanup function should immeadiatly
1113							# call:
1114							#
1115							# $self->SUPER::cleanup( $r );
1116							#
1117							# After the call to SUPER, the application level cleanup
1118							# should include its cleanup intructions.
1119							#-------------------------------------------------
1120							sub cleanup {
1121	0			0	1		my ( $self ) = @_;
1122
1123							# Make sure get_schema() is available first.
1124	0	0					if ( $self->can( 'get_schema' ) ) {
1125							# Get main database schema.
1126	0						my $schema = $self->get_schema();
1127
1128							# Disconnect from database, if the schema exists.
1129	0	0					if ($schema) {
1130	0						$schema->storage()->disconnect();
1131							}
1132							}
1133
1134							# Create helper to get and set auth schema dbh.
1135	0						my $helper = Gantry::Utils::DBConnHelper->get_subclass();
1136	0						my $auth_schema = $helper->get_auth_dbh();
1137
1138							# Disconnect from database, if the schema exists.
1139	0	0					if ($auth_schema) {
1140	0						$auth_schema->disconnect();
1141
1142							# Undefine the dbh so that it will re-connect automatically
1143							# on the next request.
1144	0						$helper->set_auth_dbh( undef );
1145							}
1146
1147							# db_disconnect( $$self{dbh} );
1148
1149							} # end cleanup
1150
1151							#-------------------------------------------------
1152							# $self->custom_error( @errors )
1153							#-------------------------------------------------
1154							sub custom_error {
1155	0			0	1		my( $self, @err ) = @_;
1156
1157	0						eval "use Data::Dumper";
1158
1159	0						my $die_msg = join( "\n", @err );
1160
1161	0						my $param_dump = Dumper( $self->params );
1162	0						$param_dump =~ s/(?:^\|\n)(\s+)/&trim( $1 )/ge;
	0
1163	0						$param_dump =~ s/
1164
1165	0						my $request_dump = Dumper( $self );
1166	0						my $response_dump = '';
1167	0						$request_dump =~ s/(?:^\|\n)(\s+)/&trim( $1 )/ge;
	0
1168	0						$request_dump =~ s/
1169
1170	0		0				my $status = $self->status \|\| 'Bad Request';
1171
1172	0						my $page = $self->_error_page();
1173
1174	0						$page =~ s/##DIE_MESSAGE##/$die_msg/sg;
1175	0						$page =~ s/##PARAM_DUMP##/$param_dump/sg;
1176	0						$page =~ s/##REQUEST_DUMP##/$request_dump/sg;
1177	0						$page =~ s/##RESPONSE_DUMP##/$response_dump/sg;
1178	0						$page =~ s/##STATUS##/$status/sg;
1179	0						$page =~ s/##PAGE_TITLE##/$self->page_title/sge;
	0
1180
1181	0						return( $page );
1182
1183
1184							} # end custom_error
1185
1186							sub trim {
1187	0			0	1		my $spaces = $1;
1188
1189	0						my $new_sp = " " x int( length($spaces) / 4 );
1190	0						return( "\n$new_sp" );
1191							}
1192
1193							#-------------------------------------------------
1194							# $self->serialize_params( [ keys to exclude ], )
1195							#-------------------------------------------------
1196							sub serialize_params {
1197	0			0	1		my( $self, $exclude_ref, $separator ) = @_;
1198
1199	0		0				$exclude_ref \|\|= [];
1200	0		0				$separator \|\|= '&';
1201	0						my $exclude_hash = {};
1202
1203	0						foreach ( @{ $exclude_ref } ) {
	0
1204	0						++$exclude_hash->{$_};
1205							}
1206
1207	0						my @page_params;
1208	0						foreach my $p ( keys %{ $self->params } ) {
	0
1209	0	0					next if $p =~ /^\./;
1210	0	0					next if exists $exclude_hash->{$p};
1211
1212	0						push( @page_params, sprintf( "%s=%s", $p, $self->params->{$p} ) );
1213							}
1214
1215	0						return join( $separator, @page_params );
1216
1217							}
1218
1219							#-------------------------------------------------
1220							# $self->escape_html($value)
1221							#-------------------------------------------------
1222							sub escape_html {
1223	0			0	1		my ($self, $value) = @_;
1224
1225	0						$value =~ s/
1226	0						$value =~ s/>/>/go;
1227	0						$value =~ s/"/"/go;
1228	0						$value =~ s/'/'/go;
1229
1230	0						return $value;
1231							}
1232
1233							#-------------------------------------------------
1234							# $self->unescape_html($value)
1235							#-------------------------------------------------
1236							sub unescape_html {
1237	0			0	1		my ($self, $value) = @_;
1238
1239	0						$value =~ s/</
1240	0						$value =~ s/>/>/go;
1241	0						$value =~ s/"/"/go;
1242	0						$value =~ s/'/'/go;
1243
1244	0						return $value;
1245							}
1246
1247							#-------------------------------------------------
1248							# $self->_error_page()
1249							#-------------------------------------------------
1250							sub _error_page {
1251	0			0			my( $self ) = ( shift );
1252
1253	0						return( qq!
1254
1255
1256							##PAGE_TITLE## ##STATUS##
1257
1303
1304
1305
1306							##DIE_MESSAGE##
1307
1308
1309							site.params
1310
1311
1312							##PARAM_DUMP##
1313
1314
1315							site
1316
1317							##REQUEST_DUMP##
1318
1319							Response
1320
1321							##RESPONSE_DUMP##
1322
1323
1324
1325
1326							Running on Gantry $Gantry::VERSION
1327
1328
1329							! );
1330
1331							} # end _error_page
1332
1333							1;
1334
1335							__END__