File Coverage

blib/lib/WebDyne.pm

Criterion	Covered	Total	%
statement	569	1343	42.3
branch	132	522	25.2
condition	101	467	21.6
subroutine	62	124	50.0
pod	4	60	6.6
total	868	2516	34.5

line	stmt	bran	cond	sub	pod	time	code
1							#
2							# This file is part of WebDyne.
3							#
4							# This software is copyright (c) 2026 by Andrew Speer .
5							#
6							# This is free software; you can redistribute it and/or modify it under
7							# the same terms as the Perl 5 programming language system itself.
8							#
9							# Full license text is available at:
10							#
11							#
12							#
13							package WebDyne;
14
15
16							# Pragma
17							#
18	8			8		323530	use strict qw(vars);
	8					14
	8					438
19	8			8		48	use vars qw($VERSION $AUTHORITY $VERSION_GIT_SHA %CGI_TAG_WEBDYNE @ISA $AUTOLOAD @EXPORT_OK);
	8					16
	8					881
20	8			8		45	use warnings;
	8					13
	8					531
21	7			7		32	no warnings qw(uninitialized redefine once qw);
	7					14
	7					329
22	7			7		2643	use overload;
	7					7487
	7					57
23
24
25							# WebDyne constants, base modules
26							#
27	7			7		1766	use WebDyne::Util;
	7					17
	7					40
28	7			7		3069	use WebDyne::CGI;
	7					19
	7					221
29	7			7		4435	use WebDyne::Constant;
	7					20
	7					43
30	7			7		4635	use WebDyne::HTML::Tiny;
	7					35
	7					280
31
32
33							# External Modules
34							#
35	7			7		3553	use Storable;
	7					22697
	7					606
36	7			7		3928	use HTTP::Status qw(:constants is_success is_error is_redirect);
	7					36018
	7					3688
37	7			7		60	use Fcntl;
	7					79
	7					1577
38	7			7		2927	use Tie::IxHash;
	7					16381
	7					278
39	7			7		47	use Digest::MD5 qw(md5_hex);
	7					13
	7					425
40	7			7		40	use File::Spec::Unix;
	7					13
	7					221
41	7			7		31	use Data::Dumper;
	7					126
	7					485
42							$Data::Dumper::Indent=1;
43							$Data::Dumper::Sortkeys=1;
44	7			7		39	use HTML::Entities qw(decode_entities encode_entities);
	7					12
	7					377
45	7			7		6713	use CGI::Simple;
	7					122113
	7					49
46	7			7		4712	use JSON;
	7					72932
	7					40
47	7			7		1109	use Cwd qw(fastcwd);
	7					12
	7					457
48
49
50							# Inherit from the Compile module, not loaded until needed though.
51							#
52							@ISA=qw(WebDyne::Compile);
53
54
55							# Export a couple of convenience methods for scripts
56							#
57	7			7		39	use Exporter qw(import);
	7					13
	7					1590
58							@EXPORT_OK = qw(html html_sr);
59
60
61							# Version information
62							#
63							$AUTHORITY='cpan:ASPEER';
64							$VERSION='2.075';
65							chomp($VERSION_GIT_SHA=do { local (@ARGV, $/) = ($_=__FILE__.'.sha'); <> if -f $_ });
66
67
68							# Debug load
69							#
70							0 && debug("%s loaded, version $VERSION", __PACKAGE__);
71
72
73							# Shortcut error handler, save using ISA;
74							#
75							require WebDyne::Err;
76							err_html=\&WebDyne::Err::err_html \|\| err_html;
77							err_eval=\&WebDyne::Err::err_eval \|\| err_eval;
78
79
80							# Our webdyne "special" tags
81							#
82							%CGI_TAG_WEBDYNE=map {$_ => 1} (
83
84							'block',
85							'perl',
86							'subst',
87							'dump',
88							'json',
89							'api',
90							'include',
91							'htmx'
92
93							);
94
95
96							# Var to hold package wide hash, for data shared across package
97							#
98							my %Package;
99
100
101							# Do some class wide initialisation
102							#
103							&init_class();
104
105
106							# Eval safe not effective - die if turned on
107							#
108							if (WEBDYNE_EVAL_SAFE) {die "WEBDYNE_EVAL_SAFE disabled in this version\n"}
109
110
111							# All done. Positive return
112							#
113							1;
114
115
116							#==================================================================================================
117
118
119							# Packace init, attempt to load optional Time::HiRes, Devel::Confess modules
120							#
121							BEGIN {
122	7			7		21	eval {require Time::HiRes; Time::HiRes->import('time')};
	7					36
	7					45
123	7					270	eval {require Devel::Confess; Devel::Confess->import(qw(no_warnings))};
	7					3780
	7					50741
124							}
125
126
127
128							# Convenience method for script usage, not used when called from mod_perl or PSGI - they call
129							# handler method below. Return scalar ref for efficiency here
130							#
131							sub html_sr {
132
133
134							# Supplied with class and options hash. Options can be supplied as hash ref
135							# or hash, convert.
136							#
137	12			12	1	98	my ($fn, $opt_hr, @param)=@_;
138	12	50				73	if (ref($fn)) {
		50
139	0					0	$opt_hr=$fn
140							}
141							elsif (ref($opt_hr) ne 'HASH') {
142	12	50				48	$opt_hr={ $opt_hr, @param } if $opt_hr;
143							}
144	12	50				55	$opt_hr->{'filename'}=$fn unless ref($fn);
145
146
147							# Capture handler output
148							#
149	12					21	my $html;
150	12		33			45	my $html_fh=$opt_hr->{'outfile'} \|\| do {
151							require IO::String; IO::String->new($html);
152							};
153	12					797	$opt_hr->{'select'}=$html_fh;
154
155
156							# Need to setup a fake request handler if initiated via script
157							#
158	12					705	require WebDyne::Request::Fake;
159	12		50			58	my $r=$opt_hr->{'r'} \|\| WebDyne::Request::Fake->new(%{$opt_hr}) \|\|
160							return err();
161
162
163							# Get handler
164							#
165	12					33	my $handler=$opt_hr->{'handler'};
166	12	50				31	if ($handler) {
167	0	0				0	eval("require $handler") \|\|
168							return err("unable to load handler $handler, $@");
169							}
170	12		50			53	$handler \|\|= (__PACKAGE__);
171
172
173							# Run
174							#
175	12	50				38	defined($handler->handler(grep {$_} $r, $opt_hr->{'param'})) \|\| return err();
	24					95
176
177
178							# Manual cleanup
179							#
180	12					50	$r->DESTROY();
181
182
183							# Returm
184							#
185	12	50				90	if (ref($html_fh) eq 'IO::String') {
186	12					87	$html_fh->close();
187	12					184	return \$html;
188							}
189							else {
190	0					0	return \undef;
191							}
192
193							}
194
195
196							# Or scalar
197							#
198	12			12	1	121125	sub html { return ${&html_sr(@_)} };
	12					57
199
200
201							# Main handler for mod_perl and PSGI
202							#
203							sub handler : method { # no subsort
204
205
206							# Get self ref/class, request ref
207							#
208	18			18	1	86	my ($self, $r, $param_hr)=@_;
209	18					29	0 && debug("handler called with self $self, r $r, MP2 $MP2");
210
211
212							# Start timer so we can optionally keep stats on how long handler takes to run
213							#
214	18					106	my $time=($self->{'_time'}=time());
215
216
217							# Work out class and correct self ref
218							#
219	18		33			68	my $class=ref($self) \|\| do {
220
221
222							# Need new self ref, as self is actually class. Do inline so quicker than -> new
223							#
224							my %self=(
225
226							_time => $time,
227							_r => $r,
228							%{delete $self->{'_self'}},
229
230							);
231							$self=bless \%self, $self;
232							ref($self);
233
234
235							};
236
237
238							# Setup error handlers
239							#
240							local $SIG{'__DIE__'}=sub {
241	0			0		0	0 && debug('in __DIE__ sig handler, caller %s', join(',', (caller(0))[0..3]));
242
243							# Go back through call stack looking for eval errors
244							#
245	0					0	my $i=0;
246	0					0	my @eval_nest;
247							my $eval_nest;
248	0					0	while (my @caller=caller($i++)) {
249	0	0				0	if ($caller[3] eq '(eval)') {
250	0					0	push @eval_nest, \@caller;
251	0					0	$eval_nest++;
252							}
253							}
254	0					0	0 && debug("eval_nest: $eval_nest, eval_nest_ar: %s", Dumper(\@eval_nest));
255
256
257							# Don't error out if not a WebDyne error (i.e. if eval{} block was in module called from
258							# user code
259							#
260							#if ($eval_nest[0][0]!~/^WebDyne::/) {
261	0	0				0	if ($eval_nest[0][0] !~ /^WebDyne(?:::\|$)/) {
262
263							# Not us, clear eval stack
264							#
265	0					0	0 && debug("eval_nest: $eval_nest[0][0] did not match WebDyne module, clearning eval error");
266	0					0	eval {};
267	0					0	return;
268
269							}
270
271
272							# Updated to NOT throw error if in eval block (i.e. if $@ is set). Stops error handler being called
273							# if non WebDyne module has eval code which triggers non WebDyne AUTOLOAD block. Might need to be more
274							# sophisticated and look at traceback for Autoload::AUTOLOAD but another day
275	0	0				0	return err(@_) unless $@;
276	18					195	};
277							local $SIG{'__WARN__'}=sub {
278	0			0		0	0 && debug('in __WARN__ sig handler, caller %s', join(',', (caller(0))[0..3]));
279	0					0	return err(@_)
280							}
281	18					32	if WEBDYNE_WARNINGS_FATAL;
282
283
284							# Debug
285							#
286	18					28	0 && debug(
287							"in WebDyne::handler. class $class, self $self, r $r (%s), param_hr %s",
288							Dumper($r, $param_hr));
289
290
291							# Skip all processing if header request only
292							#
293	18	50				75	if ($r->header_only()) {return &head_request($r)}
	0					0
294
295
296							# Debug
297							#
298	18					56	0 && debug(
299							"enter handler, r $r, location %s file %s, param %s",
300							$r->location(), $r->filename(), Dumper($param_hr));
301
302
303							# Get full path, mtime of source file, check file exists
304							#
305	18		33			62	my $srce_pn=$r->filename() \|\| do {
306
307							# Couldn't find file in request, decline
308							#
309							0 && debug('could not find file, returning');
310							return $MP2 ? &Apache::DECLINED : $r->status(HTTP_NOT_FOUND);
311							};
312	18		33			580	my $srce_mtime=(-f $srce_pn && (stat(_))[9]) \|\| do {
313
314							# Found file but couldn't stat or similar issue
315							#
316							0 && debug("srce_mtime for file '$srce_pn' not found, could not stat !");
317							return $MP2 ? &Apache::DECLINED : $r->status(HTTP_NOT_FOUND);
318							# return &Apache::DECLINED;
319
320							};
321	18					42	0 && debug("srce_pn $srce_pn, srce_mtime (real) $srce_mtime");
322
323
324							# Used to use inode as unique identifier for file in cache, but that
325							# did not take into account the fact that the same file may have diff
326							# Apache locations (and thus WebDyne::Chain) handlers for the same
327							# physical file. So we now use an md5 hash of handler, location and
328							# file name, but the var name is still "inode";
329							#
330							RENDER_BEGIN:
331							my $srce_inode=(
332	18		50			257	$self->{'_inode'} \|\|= md5_hex(ref($self), $r->location, $srce_pn)
			33
333							\|\|
334							return $self->err_html("could not get md5 for file $srce_pn, $!"));
335	18					37	0 && debug("srce_inode $srce_inode");
336
337
338							# Var to hold pointer to cached metadata area, so we are not constantly
339							# dereferencing $Package{'_cache'}{$srce_inode};
340							#
341							my $cache_inode_hr=(
342	18		50			150	$Package{'_cache'}{$srce_inode} \|\|= {
343
344							data => undef, # holds compiled representation of html/psp file
345							mtime => undef, # last modified time of the Storable disk cache file
346							nrun => undef, # number of times this page run by this mod_perl child
347							lrun => undef, # last run time of this page by this mod_perl child
348
349							# Created if needed
350							#
351							# meta => undef, # page meta data, held in meta section or supplied by add-on modules
352							# eval_cr => undef, # where anonymous sub's representing eval'd perl code within this page are held
353							# perl_init => undef, # flags that perl code in __PERL__ block has been init'd (run once at page load)
354
355							}) \|\| return $self->err_html('unable to initialize cache_inode_hr ref');
356
357
358							# Get "effective" source mtime, as may be a combination of things including
359							# template (eg menu) mtime. Here so can be subclassed by other handler like
360							# menu systems
361							#
362	18					39	0 && debug("about to call source_mtime, self $self");
363							$srce_mtime=${
364	18		33			26	$self->source_mtime($srce_mtime) \|\| return $self->err_html()}
365							\|\| $srce_mtime;
366	18					35	0 && debug("srce_pn $srce_pn, srce_mtime (computed) $srce_mtime");
367
368
369							# Need to stat cache file mtime in case another process has updated it (ie via self->cache_compile(1)) call,
370							# which will make our memory cache stale. Would like to not have to do this stat one day, perhaps via shmem
371							# or similar check
372							#
373							# Only do if cache directory defined
374							#
375	18					35	my ($cache_pn, $cache_mtime);
376	18					32	if (WEBDYNE_CACHE_DN) {
377							0 && debug("webdyne_cache_dn $WEBDYNE_CACHE_DN");
378							$cache_pn=File::Spec->catfile(WEBDYNE_CACHE_DN, $srce_inode);
379							$cache_mtime=((-f $cache_pn) && (stat(_))[9]);
380							0 && debug("webdyne_cache file: $cache_pn, cache_mtime: $cache_mtime");
381							}
382							else {
383	18					30	0 && debug('no webdyne_cache_dn');
384							}
385
386
387							# Test if compile/reload needed
388							#
389	18	100	66			152	if (WEBDYNE_RELOAD \|\| $self->{'_compile'} \|\| ($cache_inode_hr->{'mtime'} < $srce_mtime) \|\| ($cache_mtime > $cache_inode_hr->{'mtime'})) {
			66
390
391
392							# Debug
393							#
394							0 && debug(
395							"compile/reload needed _compile %s, cache_inode_hr mtime %s, srce_mtime $srce_mtime, WEBDYNE::RELOAD $WEBDYNE_RELOAD",
396	8					14	$self->{'_compile'}, $cache_inode_hr->{'mtime'});
397
398
399							# use Module::Reload to reload modules
400							#
401	8					16	if (WEBDYNE_RELOAD) {
402							local $SIG{'__DIE__'};
403							unless ($INC{'Module/Reload.pm'}) {
404							0 && debug('loading Module::Reload');
405							eval {require Module::Reload};
406							return $self->err_html('unable to load Module::Reload - is it installed ?') if $@;
407							}
408							0 && debug('running Module::Reload->check');
409							$Module::Reload::Debug=1;
410							Module::Reload->check();
411
412							#delete $Package{'_cache'}{$srce_inode};
413							}
414
415
416							# Null out cache_inode to clear any flags
417							#
418	8					12	foreach my $key (keys %{$cache_inode_hr}) {
	8					35
419	32					39	0 && debug("nulling out cache_inode_hr key: $key");
420	32					62	$cache_inode_hr->{$key}=undef;
421							}
422
423
424							# Try to clear/reset package name space if possible
425							#
426							eval {
427	8					68	require Symbol;
428	8					50	&Symbol::delete_package("WebDyne::${srce_inode}");
429	8	50				1820	} \|\| do {
430	8	50				345	eval {} if $@; #clear $@ after error above
431	8					15	my $stash_hr=*{"WebDyne::${srce_inode}::"}{HASH};
	8					57
432	8					17	foreach (keys %{$stash_hr}) {
	8					23
433	0					0	undef *{"WebDyne::${srce_inode}::${_}"};
	0					0
434							}
435	8					15	%{$stash_hr}=();
	8					17
436	8					26	delete *WebDyne::{'HASH'}->{$srce_inode};
437							};
438
439
440							# Debug
441							#
442	8					19	0 && debug("srce_pn $srce_pn, cache_pn $cache_pn, mtime $cache_mtime");
443
444
445	8					16	my $container_ar;
446	8	50	33			85	if ($self->{'_compile'} \|\| ($cache_mtime < $srce_mtime)) {
447
448
449							# Debug
450							#
451	8					15	0 && debug("compiling srce: $srce_pn, dest $cache_pn");
452
453
454							# Recompile from source
455							#
456	8	50	0			42	eval {require WebDyne::Compile}
	8					2225
457							\|\| return $self->err_html(
458							errsubst('unable to load WebDyne:Compile, %s', $@ \|\| 'undefined error'));
459
460
461							# Source newer than compiled version, must recompile file
462							#
463	8		50			103	$container_ar=$self->compile(
464							{
465
466							srce => $srce_pn,
467							dest => $cache_pn,
468
469							}) \|\| return $self->err_html();
470
471
472							# Check for any unhandled errors during compile
473							#
474	8	50				51	errstr() && return $self->err_html();
475
476
477							# Update mtime flag, or use current time if we were not able to read
478							# cache file (probably because temp dir was not writable - which would
479							# generated a warning in the logs from the Compile module, so no point
480							# making a fuss about it here anymore.
481							#
482	8	50				27	$cache_mtime=(stat($cache_pn))[9] if $cache_pn; # \|\|
483							#return $self->err_html("could not stat cache file '$cache_pn'");
484	8		33			68	$cache_inode_hr->{'mtime'}=$cache_mtime \|\| time();
485
486
487							}
488							else {
489
490							# Debug
491							#
492	0					0	0 && debug("loading from disk cache");
493
494
495							# Load from storeable file
496							#
497	0		0			0	$container_ar=Storable::lock_retrieve($cache_pn) \|\|
498							return $self->err_html("Storable error when retreiveing cached file '$cache_pn', $!");
499
500
501							# Update mtime flag
502							#
503	0					0	$cache_inode_hr->{'mtime'}=$cache_mtime;
504
505
506							# Re-run perl-init for this node. Not done above because handled in compile if needed
507							#
508	0	0				0	if (my $meta_hr=$container_ar->[0]) {
509	0	0				0	if (my $perl_ar=$meta_hr->{'perl'}) {
510	0		0			0	my $perl_debug_ar=$meta_hr->{'perl_debug'} \|\|
511							return err('unable to load perl_debug array reference');
512	0	0				0	$self->perl_init($perl_ar, $perl_debug_ar) \|\| return $self->err_html();
513							}
514							}
515							}
516
517
518							# Done, install into memory cache
519							#
520	8	100	66			65	if (my $meta_hr=$container_ar->[0] and $cache_inode_hr->{'meta'}) {
		50
521
522							# Need to merge meta info
523							#
524	1		33			3	foreach (keys %{$meta_hr}) {$cache_inode_hr->{'meta'}{$_} \|\|= $meta_hr->{$_}}
	1					4
	6					18
525
526							}
527							elsif ($meta_hr) {
528
529							# No merge - just use from container
530							#
531	7					38	$cache_inode_hr->{'meta'}=$meta_hr;
532
533							}
534	8					33	$cache_inode_hr->{'data'}=$container_ar->[1];
535
536							# Corner case. Delete _CGI if WEBDYNE_CGI_EXPAND_PARAM set to force re-read of
537							# CGI params in case was set in section - which means would not be seen
538							# early enough. Will only happen after first compile, so no major performance
539							# impact on CGI object recreation
540							#
541							# Update: Re-init rather than delete or WebDyne::State worn't work
542							#
543							# delete $self->{'_CGI'} if $WEBDYNE_CGI_PARAM_EXPAND;
544							#
545
546							# More problems with this. Caused CGI params to disappear when cache subroutine from WebDyne::Cache
547							# triggered loop. Do I need to do it anymore ? Commenting out but retaining for ref
548							#
549							##if ((my $cgi_or=$self->{'_CGI'}) && WEBDYNE_CGI_PARAM_EXPAND) {
550							## $cgi_or->delete_all(); # Added this after cache code issues so don't get two instances of param. Keep and eye for problems with WebDyne::State
551							## $cgi_or->_initialize();
552							##}
553
554
555							}
556							else {
557
558	10					17	0 && debug('no compile or disk cache fetch needed - getting from memory cache');
559
560							}
561
562
563							# Separate meta and actual data into separate vars for ease of use
564							#
565	18					39	my ($meta_hr, $data_ar)=@{$cache_inode_hr}{qw(meta data)};
	18					63
566	18					28	0 && debug('meta_hr %s, ', Dumper($meta_hr));
567
568
569							# Custom handler ?
570							#
571	18	50	33			122	if (my $handler_ar=$meta_hr->{'handler'} \|\| $r->dir_config('WebDyneHandler')) {
572	0					0	0 && debug('handler_ar: %s, dir_config: %s', Dumper(\$handler_ar, $r->dir_config('WebDyneHandler')));
573	0	0				0	my ($handler, $handler_param_hr)=ref($handler_ar) ? @{$handler_ar} : $handler_ar;
	0					0
574	0	0				0	if (ref($self) ne $handler) {
575	0					0	0 && debug("passing to custom handler '$handler', param %s", Dumper($handler_param_hr));
576	0	0				0	unless ($Package{'_handler_load'}{$handler}) {
577	0					0	0 && debug("need to load handler '$handler' - trying");
578	0					0	(my $handler_fn=$handler)=~s/::/\//g;
579	0					0	$handler_fn.='.pm';
580	0	0				0	eval {require $handler_fn} \|\|
	0					0
581							return $self->err_html("unable to load custom handler '$handler', $@");
582	0	0				0	UNIVERSAL::can($handler, 'handler') \|\|
583							return $self->err_html("custom handler '$handler' does not seem to have a 'handler' method to call");
584	0					0	0 && debug('loaded OK');
585	0					0	$Package{'_handler_load'}{$handler}++;
586							}
587	0					0	my %handler_param_hr=(%{$param_hr}, %{$handler_param_hr}, meta => $meta_hr);
	0					0
	0					0
588	0					0	bless $self, $handler;
589
590							# Force recalc of inode in next handler so recompile done
591	0					0	delete $self->{'_inode'};
592
593							# Add meta-data. Something inefficient here, why supplying as handler param and
594							# self attrib ? If don't do it Fake/FastCGI request handler breaks but Apache does
595							# not ?
596	0					0	$self->{'_meta_hr'}=$meta_hr;
597	0					0	return &{"${handler}::handler"}($self, $r, \%handler_param_hr);
	0					0
598							}
599							}
600
601
602							# Contain cache code ?
603							#
604	18	50	33			139	if ((my $cache=($self->{'_cache'} \|\| $meta_hr->{'cache'})) && !$self->{'_cache_run_fg'}++) {
			33
605	0					0	0 && debug("found cache routine $cache, adding to inode $srce_inode");
606	0					0	my $cache_inode;
607	0					0	my $eval_cr=$Package{'_eval_cr'}{'!'};
608	0	0				0	if (ref($cache) eq 'CODE') {
609	0					0	0 && debug('CODE cache ref type');
610	0					0	my %param=(
611							cache_cr => $cache,
612							srce_inode => $srce_inode
613							);
614
615							# Use to take return of cache code as inode but not obvious. Now force user to run $self->inode() in cache
616							# code to set. Keep here as reminder though.
617							#
618							#$cache_inode=${
619
620							# OK - what does this do ? It calls the cache code ref in the document via the eval_cr code execution
621							# routine which is supplied as follows
622							#
623							# $_[0] = self (instance) ref
624							# $_[1] = r (request ref)
625							# $_[2] = CGI (CGI ref)
626							# $_[3] = \%param above
627							#
628							# And we are executing code '$_[3]->{'cache_cr'}->($_[0], $_[3]->{'srce_inode'}', so
629							# $cache->($self, $srce_inode)
630							#
631							# Change mind - back to not supplying r, CGI as standard. User can request
632							#
633							##$eval_cr->($self, undef, \%param, q[$_[3]->{'cache_cr'}->($_[0], $_[3]->{'srce_inode'})], 0) \|\|
634							#
635							# Before we added r,CGI as params for eval_cr it looked like this
636							#
637							#$eval_cr->($self, undef, \%param, q[$_[1]->{'cache_cr'}->($_[0], $_[1]->{'srce_inode'})], 0) \|\|
638	0	0	0			0	$eval_cr->($self, undef, \%param, q[$_[1]->{'cache_cr'}->($_[0], $_[1]->{'srce_inode'})], 0) \|\|
639							return $self->err_html(
640							errsubst(
641							'error in cache code: %s', errstr() \|\| $@ \|\| 'no inode returned'
642							));
643							#}
644							}
645							else {
646
647							# See above. Same rationale
648							#
649							#$cache_inode=${
650	0					0	0 && debug('non-CODE cache type');
651	0	0	0			0	$eval_cr->($self, undef, $srce_inode, $cache, 0) \|\|
652							return $self->err_html(
653							errsubst(
654							'error in cache code: %s', errstr() \|\| $@ \|\| 'no inode returned'
655							));
656							#}
657							}
658							#$cache_inode=$cache_inode ? md5_hex($srce_inode, $cache_inode) : $self->{'_inode'};
659	0					0	$cache_inode=$self->{'_inode'};
660
661							# Will probably make inodes with algorithm below some day so we can implement a "maxfiles type limit on
662							# the number of cache files generated. Not today though ..
663							#
664							#$cache_inode=$cache_inode ? $srce_inode .'_'. md5_hex($cache_inode) : $self->{'_inode'};
665	0					0	0 && debug("cache inode $cache_inode, compile %s", $self->{'_compile'});
666
667	0	0	0			0	if (($cache_inode ne $srce_inode) \|\| $self->{'_compile'}) {
668
669							# Using a cache file, different inode.
670							#
671	0					0	0 && debug("goto RENDER_BEGIN, inode node was $srce_inode, now $cache_inode, _compile: %s", $self->{'_compile'} \|\| 0 );
672	0					0	goto RENDER_BEGIN;
673							#return &handler($self,$r,$param_hr); #should work instead of goto for pendants
674
675							}
676							else {
677
678							# Same inode, nothing to do.
679							#
680	0					0	0 && debug('inode not changed, proceeding');
681
682							}
683
684							}
685							else {
686
687							# No cache code to run
688							#
689	18					28	0 && debug('not running cache code');
690
691							}
692
693
694							# Is it plain HTML which can be/is pre-rendered and stored on disk ? Note to self, leave here - should
695							# run after any cache code is run, as that may change inode.
696							#
697	18					29	my $html_sr;
698	18	100	100			173	if ($self->{'_static'} \|\| ($meta_hr && ($meta_hr->{'html'} \|\| $meta_hr->{'static'}))) {
			66
			66
699
700
701							# It's flagged static, passed first hurdle. We might need to save away - but only if we're not a
702							# child handler. $r->main() gives undef if we are the main request handler.
703							#
704							# Remove test for main child handler but keep as reminder
705							#
706							#if (! $r->main()) {
707
708							# We are the main request handler. So process
709							#
710	14					23	0 && debug('static flag detected, in main handler');
711	14	50	33			73	if ($cache_pn && (-f (my $fn="${cache_pn}.html")) && ((stat(_))[9] >= $srce_mtime) && !$self->{'_compile'}) {
		50	33
			0
712
713							# Cache file exists, and is not stale, and user/cache code does not want a recompile. Tell Apache or FCGI
714							# to serve it up directly.
715							#
716	0					0	0 && debug("returning pre-rendered file ${cache_pn}.html");
717	0	0	0			0	unless($MOD_PERL && !$MP2) {
718							#if ($MP2 \|\| $ENV{'FCGI_ROLE'} \|\| $ENV{'psgi.version'}) {
719
720							# Do this way for mod_perl2, FCGI. Note to self need r->output_filter or
721							# Apache 2 seems to add junk characters at end of output
722							#
723	0					0	0 && debug('using MP2 or FCGI_ROLE path');
724	0					0	my $r_child=$r->lookup_file($fn, $r->output_filters);
725	0					0	0 && debug("r_child: $r_child");
726	0					0	$r_child->handler('default-handler');
727	0					0	$r_child->content_type(WEBDYNE_CONTENT_TYPE_HTML);
728
729							# Apache bug ? Need to set content type on r also
730	0					0	$r->content_type(WEBDYNE_CONTENT_TYPE_HTML);
731	0					0	0 && debug("set content type to: $WEBDYNE_CONTENT_TYPE_HTML, running");
732	0					0	return $r_child->run($self);
733
734							}
735							else {
736
737							# This way for older versions of Apache, other request handlers
738							#
739	0					0	0 && debug('using legacy path');
740	0					0	$r->filename($fn);
741	0					0	$r->handler('default-handler');
742	0					0	$r->content_type(WEBDYNE_CONTENT_TYPE_HTML);
743	0					0	return &Apache::DECLINED;
744							}
745							}
746							elsif ($cache_pn) {
747
748							# Cache file defined, but out of date of non-existant. Register callback handler to write HTML output
749							# after render complete
750							#
751	0					0	0 && debug("storing inode: %s to disk file: ${cache_pn}.html, cache html %s", $self->{'_inode'}, \$data_ar->[0]);
752							my $cr=sub {
753							&cache_html(
754	0	0	0	0		0	"${cache_pn}.html", ($meta_hr->{'static'} \|\| $self->{'_static'}) ? $html_sr : \$data_ar->[0])
755	0					0	};
756	0	0				0	$MP2 ? $r->pool->cleanup_register($cr) : $r->register_cleanup($cr);
757							}
758							else {
759
760							# No cache directory, store in memory cache. Each apache process will get a different version, but will
761							# at least still be only compiled once for each version.
762							#
763	14					20	0 && debug('storing to memory cache html %s', \$data_ar->[0]);
764							my $cr=sub {
765							$cache_inode_hr->{'data'}=[
766	14	100	66	14		73	($meta_hr->{'static'} \|\| $self->{'_static'}) ? ${$html_sr} : $data_ar->[0]]
	12					58
767	14					91	};
768	14	50				79	$MP2 ? $r->pool->cleanup_register($cr) : $r->register_cleanup($cr);
769							}
770
771							#}
772							#else {
773							# debug('in child handler, not saving');
774							#}
775
776							}
777							else {
778
779	4					8	0 && debug('not static code, not saving to cache or serving');
780
781							}
782
783
784							# Debug
785							#
786	18					58	0 && debug('about to render');
787
788
789							# Set default content type to text/html, can be overridden by render code if needed
790							#
791	18					96	$r->content_type(WEBDYNE_CONTENT_TYPE_HTML);
792
793
794							# Redirect 'print' function to our own routine for later output
795							#
796	18		33			133	my $select=($self->{'_select'} \|\|= CORE::select());
797	18					34	0 && debug("select handle is currently $select, changing to *WEBDYNE");
798	18	50				167	tie(*WEBDYNE, 'WebDyne::TieHandle', $self) \|\|
799							return $self->err_html("unable to tie output to 'WebDyne::TieHandle', $!");
800	18	50				76	CORE::select WEBDYNE if $select;
801
802
803							# Get the actual html. The main event - convert data_ar to html
804							#
805	18		33			77	$html_sr=$self->render_data_ar(data => $data_ar, param => $param_hr) \|\| do {
806
807
808							# Our render routine returned an error. Debug
809							#
810							RENDER_ERROR:
811							0 && debug("render error $r, select $select");
812
813
814							# Return error
815							#
816							0 && debug("selecting back to $select for error");
817							CORE::select $select if $select;
818							untie *WEBDYNE;
819							return $self->err_html();
820
821
822							};
823
824
825							# Done with STDOUT redirect
826							#
827	16					67	0 && debug("selecting back to $select");
828	16	50				97	CORE::select $select if $select;
829	16					74	untie *WEBDYNE;
830
831
832							# Check for any unhandled errors during render - render may have returned OK, but
833							# maybe an error occurred along the way that was not passed back ..
834							#
835	16					56	0 && debug('errstr after render %s', errstr());
836	16	50				63	errstr() && return $self->err_html();
837	16	50				67	&CGI::Simple::cgi_error() && return $self->err_html(&CGI::Simple::cgi_error());
838
839
840							# Check for any blocks that user wanted rendered but were
841							# not present anywhere
842							#
843							#if ($WEBDYNE_DELAYED_BLOCK_RENDER && (my $block_param_hr=delete $self->{'_block_param'})) {
844	16	50				171	if (my $block_param_hr=delete $self->{'_block_param'}) {
845	0					0	my @block_error;
846	0					0	foreach my $block_name (keys %{$block_param_hr}) {
	0					0
847	0	0				0	unless (exists $self->{'_block_render'}{$block_name}) {
848	0					0	push @block_error, $block_name;
849							}
850							}
851	0	0				0	if (@block_error) {
852	0					0	0 && debug('found un-rendered blocks %s', Dumper(\@block_error));
853							return $self->err_html(
854	0					0	err('unable to locate block(s) %s for render', join(', ', map {"'$_'"} @block_error)))
	0					0
855							}
856							}
857
858
859							# If no error, status must be ok unless otherwise set
860							#
861	16	50				71	$r->status(HTTP_OK) unless $r->status();
862	16					44	0 && debug('r status set, %s', $r->status());
863
864
865							# Tidy ? Run under eval in case module not installed/working, considerd non-fatal
866							#
867	16					32	if (WEBDYNE_HTML_TIDY) {
868							eval {
869							require HTML::Tidy5;
870							my $html=HTML::Tidy5->new($WEBDYNE_HTML_TIDY_CONFIG_HR)->clean(${$html_sr});
871							$html_sr=\$html;
872							};
873							$@ && eval {};
874							}
875
876
877							# Formulate header, calc length of return.
878							#
879							# Modify to remove error checking - WebDyne::FakeRequest does not supply
880							# hash ref, so error generated. No real need to check
881							#
882	16					55	my $header_out_hr=$r->headers_out(); # \|\| return err();
883							my %header_out=(
884
885	16					33	'Content-Length' => length ${$html_sr},
886							#($meta_hr->{'no_cache'} \|\| $WEBDYNE_NO_CACHE) && (
887							# 'Cache-Control' => 'no-cache',
888							# 'Pragma' => 'no-cache',
889							# 'Expires' => '-5'
890							# )
891	16					33	%{$WEBDYNE_HTTP_HEADER}
	16					167
892
893							);
894	16					70	foreach (keys %header_out) {$header_out_hr->{$_}=$header_out{$_}}
	112					271
895
896
897							# Debug
898							#
899	16					34	0 && debug("sending header: $r");
900
901
902							# Send header
903							#
904	16	50				103	$r->send_http_header() if !$MP2;
905
906
907							# Print. Commented out version only seems to work in Apache 1/mod_perl1
908							#
909							#$r->print($html_sr);
910	16	50				84	$MP2 ? $r->print(${$html_sr}) : $r->print($html_sr);
	0					0
911
912
913							# Work out the form render time, log
914							#
915	18					825	RENDER_COMPLETE:
916							my $time_render=sprintf('%0.4f', time()-$time);
917	18					45	0 && debug("form $srce_pn render time $time_render");
918
919
920							# Do we need to do house cleaning on cache after this run ? If so
921							# add a perl handler to do it after we finish
922							#
923	18	50	33			80	if (
			33
924							WEBDYNE_CACHE_CHECK_FREQ
925							&&
926							($r eq ($r->main() \|\| $r)) &&
927							!((my $nrun=++$Package{'_nrun'}) % WEBDYNE_CACHE_CHECK_FREQ)
928							) {
929
930
931							# Debug
932							#
933	0					0	0 && debug("run $nrun times, scheduling cache clean");
934
935
936							# Yes, we need to clean cache after finished
937							#
938	0			0		0	my $cr=sub {&cache_clean($Package{'_cache'})};
	0					0
939	0	0				0	$MP2 ? $r->pool->cleanup_register($cr) : $r->register_cleanup($cr);
940
941
942							# Used to be sub { $self->cache_clean() }, but for some reason this
943							# made httpd peg at 100% CPU usage after cleanup. Removing $self ref
944							# fixed.
945							#
946
947
948							}
949							elsif (WEBDYNE_CACHE_CHECK_FREQ) {
950
951							# Only bother to update counters if we are checking cache periodically
952							#
953
954
955							# Update cache script frequency used, time used indicators, nrun=number
956							# of runs, lrun=last run time
957							#
958	18					58	$cache_inode_hr->{'nrun'}++;
959	18					57	$cache_inode_hr->{'lrun'}=time();
960
961							}
962							else {
963
964
965							# Debug
966							#
967							0 && debug("run $nrun times, no cache check needed");
968
969							}
970
971
972							# Debug exit
973							#
974	18					30	0 && debug("handler $r exit status %s, leaving with Apache::OK", $r->status); #, Dumper($self));
975
976
977							# Complete
978							#
979	18	50				392	HANDLER_COMPLETE:
980							return $MP2 ? &Apache::OK : HTTP_OK;
981
982
983							}
984
985
986							sub init_class {
987
988
989							# Try to load correct modules depending on Apache ver, taking special care
990							# with constants. This mess will disappear if we only support MP2
991							#
992	7	50		7	0	64	if ($MP2) {
		50
993
994	0					0	local $SIG{'__DIE__'};
995							eval {
996							#require Apache2;
997	0					0	require Apache::Log;
998	0					0	require Apache::Response;
999	0					0	require Apache::SubRequest;
1000	0					0	require Apache::Const; Apache::Const->import(-compile => qw(OK DECLINED));
	0					0
1001	0					0	require APR::Table;
1002	0					0	require APR::Pool;
1003	0	0				0	} \|\| eval {
1004	0					0	require Apache2::Log;
1005	0					0	require Apache2::Response;
1006	0					0	require Apache2::SubRequest;
1007	0					0	require Apache2::Const; Apache2::Const->import(-compile => qw(OK DECLINED));
	0					0
1008	0					0	require Apache2::RequestRec;
1009	0					0	require Apache2::RequestUtil;
1010	0					0	require Apache2::RequestIO;
1011	0					0	require APR::Table;
1012	0					0	require APR::Pool;
1013							};
1014	0	0				0	eval {} if $@;
1015	0	0				0	unless (UNIVERSAL::can('Apache', 'OK')) {
1016	0	0				0	if (UNIVERSAL::can('Apache2::Const', 'OK')) {
		0
1017	0					0	*Apache::OK=\&Apache2::Const::OK;
1018	0					0	*Apache::DECLINED=\&Apache2::Const::DECLINED;
1019							}
1020							elsif (UNIVERSAL::can('Apache::Const', 'OK')) {
1021	0					0	*Apache::OK=\&Apache::Const::OK;
1022	0					0	*Apache::DECLINED=\&Apache::Const::DECLINED;
1023							}
1024							else {
1025	0			0		0	*Apache::OK=sub {0}
1026	0	0				0	unless defined &Apache::OK;
1027	0			0		0	*Apache::DECLINED=sub {-1}
1028	0	0				0	unless defined &Apache::DECLINED;
1029							}
1030							}
1031							}
1032							elsif ($ENV{'MOD_PERL'}) {
1033
1034	0					0	local $SIG{'__DIE__'};
1035							eval {
1036	0					0	require Apache::Constants; Apache::Constants->import(qw(OK DECLINED));
	0					0
1037	0					0	*Apache::OK=\&Apache::Constants::OK;
1038	0					0	*Apache::DECLINED=\&Apache::Constants::DECLINED;
1039	0	0				0	} \|\| do {
1040	0			0		0	*Apache::OK=sub {0}
1041	0					0	};
1042	0	0				0	eval {} if $@;
1043							}
1044							else {
1045
1046	7			0		42	*Apache::OK=sub {0};
	0					0
1047	7			0		32	*Apache::DECLINED=sub {-1};
	0					0
1048
1049							}
1050
1051
1052							# If set, delete all old cache files at startup
1053							#
1054	7	50				86	if (WEBDYNE_STARTUP_CACHE_FLUSH && (-d WEBDYNE_CACHE_DN)) {
1055	0					0	my @file_cn=glob(File::Spec->catfile(WEBDYNE_CACHE_DN, '*'));
1056	0					0	foreach my $fn (grep {/\w{32}(\.html)?$/} @file_cn) {
	0					0
1057	0					0	unlink $fn; #don't error here if problems, user will never see it
1058							}
1059							}
1060
1061
1062							# Make all errors non-fatal
1063							#
1064	7					38	errnofatal(1);
1065
1066
1067							# Alias request method to just 'r' also
1068							#
1069	7		33			35	WebDyne::r=\&WebDyne::request \|\| WebDyne::r;
1070
1071
1072							# Eval routine for eval'ing perl code in a non-safe way (ie hostile
1073							# code could probably easily subvert us, as all operations are
1074							# allowed, including redefining our subroutines etc).
1075							#
1076							my $eval_perl_cr=sub {
1077
1078
1079							# Get self ref
1080							#
1081	9			9		29	my ($self, $data_ar, $eval_param_hr, $eval_text, $index, $tag_fg)=@_;
1082	9					82	$eval_text=decode_entities($eval_text);
1083
1084
1085							# Debug
1086							#
1087							#my $inode=$self->{'_inode'} \|\| 'ANON'; # Was ANON but caused nasty test errors because of memory collisions after many iterations Anon used when no inode present, eg wdcompile
1088	9		33			35	my $inode=$self->{'_inode'} \|\| $self->inode();
1089	9					19	my $html_line_no=$data_ar->[WEBDYNE_NODE_LINE_IX];
1090
1091
1092							# Get CGI vars
1093							#
1094	9		66			70	my $cgi_or=$self->{'_CGI'} \|\| $self->CGI();
1095							my $param_hr=(
1096	9		66			50	$self->{'_eval_cgi_hr'} \|\|= do {
1097	7					29	$cgi_or->Vars();
1098
1099							}
1100							);
1101
1102
1103							# Only eval subroutine if we have not done already, if need to eval store in
1104							# cache so only done once.
1105							#
1106	9		66			413	my $eval_cr=$Package{'_cache'}{$inode}{'eval_cr'}{$data_ar}{$index} \|\|= do {
1107
1108							# Why did I do this ? No vars to perl_init so nothing created ?
1109							#
1110							#$Package{'_cache'}{$inode}{'perl_init'}{+undef} \|\|= $self->perl_init();
1111	7			7		31365	no strict;
	7					17
	7					207
1112	7			7		36	no integer;
	7					15
	7					58
1113	8					14	0 && debug("calling eval sub: $eval_text");
1114
1115							# Get code ref. Do this way so run in sub with no access to vars in this scope
1116							#
1117	8					34	my $sub_cr=&eval_cr($inode, \$eval_text, $html_line_no);
1118	8	50				173	if ($@) {
		50
		50
1119	0					0	my $err=$@; eval {};
	0					0
1120
1121							#return err("eval of code returned error: $err");
1122	0					0	return $self->err_eval("eval of code returned error: $err", \$eval_text, $inode);
1123							}
1124							elsif (!defined($sub_cr)) {
1125	0					0	return err("eval of code did not return a true value");
1126							}
1127							elsif (!(ref($sub_cr) eq 'CODE')) {
1128	0					0	return err("eval of code did not return a code ref");
1129							}
1130
1131
1132							# Store code away for error handling. Keep this and next bit to jog memory
1133							#
1134							#$Package{'_cache'}{$inode}{'eval_code'}{$data_ar}{$index}=$eval;
1135
1136
1137							# Old way we did it code
1138							#
1139							#eval("package WebDyne::$_[0]; $WebDyne::WEBDYNE_EVAL_USE_STRICT;\n" . "#line $_[2]\n" . "sub{${$_[1]}\n}");
1140							#&eval_cr($inode, \$eval_text, $html_line_no) \|\| return
1141							# $self->err_eval("$@", \$eval_text);
1142
1143
1144							# Done
1145							#
1146	8					40	$sub_cr;
1147
1148							};
1149
1150							#debug("eval done, eval_cr $eval_cr");
1151
1152
1153							# Run eval
1154							#
1155	9					19	my @eval;
1156	9					18	eval {
1157
1158							# The following line puts all CGI params in %_ during the eval so they are easy to
1159							# get to ..
1160	9					25	local *_=$param_hr;
1161	9					13	0 && debug("eval call starting, tag_fg: $tag_fg");
1162
1163							# Note change here. Now supplying request handler, CGI instanced as standard params to all code calls
1164							#
1165							#@eval=$tag_fg ? $eval_cr->($self, $eval_param_hr) : scalar $eval_cr->($self, $eval_param_hr);[B
1166							#
1167							# Change of mind again. Don't supply r, CGI as standard, let user call for if wanted. Back to original code
1168							#
1169							#@eval=$tag_fg ? $eval_cr->($self, $eval_param_hr) : scalar $eval_cr->($self, $self->{'_r'}, $cgi_or, $eval_param_hr);
1170	9	100				135	@eval=$tag_fg ? $eval_cr->($self, $eval_param_hr) : scalar $eval_cr->($self, $eval_param_hr);
1171	9					396	0 && debug("eval call complete, $@, %s", Dumper(\@eval));
1172
1173							};
1174	9	50	33			120	if (!@eval \|\| $@ \|\| !$eval[0]) {
		50	33
1175
1176							# An error occurred - handle it and return.
1177							#
1178	0	0	0			0	if (my $err=(errstr() \|\| $@)) {
1179
1180							# Eval error or err() called during routine.
1181							#
1182	0					0	return $self->err_eval($err, \$eval_text, $inode);
1183
1184							}
1185							else {
1186
1187							# Some other problem
1188							#
1189							#return err ('code did not return a true value: %s, %s', $eval_text, Dumper(\@eval));
1190
1191							}
1192
1193							}
1194							elsif ($eval[0] eq $self) {
1195
1196
1197							# $self fell through, probably means no explicit return was done, e.g perl code was sub foo {}
1198							#
1199	0					0	undef @eval;
1200
1201							}
1202
1203
1204							# Quick sanity check on return
1205							#
1206	9	100				19	if (grep {ref($_) && (ref($_) !~ /(?:SCALAR\|ARRAY\|HASH\|JSON)/)} @eval) {
	11	50				55
1207
1208							# Whatever it is we can't render it unless SCALAR, ARRAY or HASH
1209							#
1210	0					0	return err('return from eval of ref type \'%s\' not supported', join(',', grep {$_} map {ref($_)} @eval));
	0					0
	0					0
1211
1212							}
1213
1214
1215							# Done
1216							#
1217	9					63	\@eval;
1218
1219	7					74	};
1220
1221
1222							# The code ref for the eval statement if using Safe module. NOTE: old and unmaintained.
1223							#
1224							my $eval_safe_cr=sub {
1225
1226
1227							# Get self ref
1228							#
1229	0			0		0	my ($self, $data_ar, $eval_param_hr, $eval_text, $index)=@_;
1230
1231
1232							# Inode
1233							#
1234							#my $inode=$self->{'_inode'} \|\| 'ANON' # Was ANON - see above Anon used when no inode present, eg wdcompile
1235	0		0			0	my $inode=$self->{'_inode'} \|\| $self->inode();
1236
1237							# Get CGI vars
1238							#
1239	0		0			0	my $cgi_or=$self->{'_CGI'} \|\| $self->CGI();
1240							my $param_hr=(
1241	0		0			0	$self->{'_eval_cgi_hr'} \|\|= do {
1242
1243	0					0	$cgi_or->Vars();
1244
1245							}
1246							);
1247
1248							# Init Safe mode environment space
1249							#
1250	0		0			0	my $safe_or=$self->{'_eval_safe'} \|\| do {
1251							0 && debug('safe init (eval_init)');
1252							require Safe;
1253							require Opcode;
1254
1255							# Used to use Safe->new($inode), but bug in Safe (actually Opcode) is Safe root namespace too long
1256							#
1257							Safe->new();
1258							};
1259	0		0			0	$self->{'_eval_safe'} \|\|= do {
1260	0					0	$safe_or->permit_only(@{$WEBDYNE_EVAL_SAFE_OPCODE_AR});
	0					0
1261	0					0	$safe_or;
1262							};
1263
1264
1265							# Only eval subroutine if we have not done already, if need to eval store in
1266							# cache so only done once
1267							#
1268	0					0	local *_=$param_hr;
1269	0					0	${$safe_or->varglob('_self')}=$self;
	0					0
1270	0					0	${$safe_or->varglob('_eval_param_hr')}=$eval_param_hr;
	0					0
1271							#${$safe_or->varglob('_r')}=$self->{'_r'};
1272							#${$safe_or->varglob('_CGI')}=$cgi_or;
1273							#my $html_sr=$safe_or->reval("sub{$eval_text}->(\$::_self, \$::_r, \$::_CGI, \$::_eval_param_hr)", $WebDyne::WEBDYNE_EVAL_USE_STRICT) \|\|
1274							#
1275							# Change mind, remove r and CGI as supplied params, user can request if wanted.
1276							#
1277	0		0			0	my $html_sr=$safe_or->reval("sub{$eval_text}->(\$::_self, \$::_eval_param_hr)", $WebDyne::WEBDYNE_EVAL_USE_STRICT) \|\|
1278							return errstr() ? err() : err($@ \|\| 'undefined return from Safe->reval()');
1279
1280
1281							# Run through the same sequence as non-safe routine
1282							#
1283	0	0	0			0	if (!defined($html_sr) \|\| $@) {
1284
1285
1286							# An error occurred - handle it and return.
1287							#
1288	0	0	0			0	if (my $err=(errstr() \|\| $@)) {
1289
1290							# Eval error or err() called during routine.
1291							#
1292	0					0	return $self->err_eval($err, \$eval_text, $inode);
1293
1294							}
1295							else {
1296
1297							# Some other problem
1298							#
1299	0					0	return err('code did not return a true value: %s', $eval_text);
1300							}
1301
1302
1303							}
1304
1305
1306							# Array returned ? Convert if so
1307							#
1308	0	0				0	(ref($html_sr) eq 'ARRAY') && do {
1309	0	0				0	$html_sr=\join(undef, map {ref($_) ? ${$_} : $_} @{$html_sr})
	0					0
	0					0
	0					0
1310							};
1311
1312
1313							# Any 'printed data ? Prepend to output. Used to do $self->{'_print_ar'}{$data_ar} but changed to
1314							# just $self->{'_print_ar'}. See code history for background
1315							#
1316	0	0				0	if (my $print_ar=delete $self->{'_print_ar'}) {
1317	0					0	0 && debug("print_ar: $print_ar %s", Dumper($print_ar));
1318	0					0	foreach my $item (reverse @{$print_ar}) {
	0					0
1319	0					0	0 && debug("prepending printed data %s for data_ar: $data_ar, %s", Dumper($item, $data_ar));
1320	0	0				0	my $print_html=(ref($_) eq 'SCALAR') ? ${$_} : $_;
	0					0
1321	0	0				0	$html_sr=ref($html_sr) ? \($print_html . ${$html_sr}) : ($print_html . $html_sr);
	0					0
1322							}
1323
1324							}
1325							else {
1326	0					0	0 && debug('no printed data detected');
1327							}
1328
1329
1330							# Make sure we return a ref
1331							#
1332	0	0				0	return ref($html_sr) ? $html_sr : \$html_sr;
1333
1334
1335	7					66	};
1336
1337
1338							# Hash eval routine, works similar to the above, but returns a hash ref
1339							#
1340							my $eval_hash_cr=sub {
1341
1342
1343							# Run eval and turn into tied hash
1344							#
1345	2			2		4	0 && debug('eval_hash_cr, %s', Dumper(\@_));
1346	2	50				4	tie(my %hr, 'Tie::IxHash', @{$eval_perl_cr->(@_) \|\| return err()});
	2					10
1347	2					118	return \%hr;
1348
1349
1350	7					32	};
1351
1352
1353							# Array eval routine, works similar to the above, but returns an array ref
1354							#
1355							my $eval_array_cr=sub {
1356
1357
1358							# Run eval and return default - which is an array ref
1359							#
1360	0			0		0	0 && debug('eval_array_cr, %s', Dumper(\@_));
1361	0		0			0	return $eval_perl_cr->(@_) \|\| err();
1362
1363	7					23	};
1364
1365
1366							# Code ref eval routine
1367							#
1368							my $eval_code_cr=sub {
1369
1370
1371							# Need to eval some code. Dispatch to perl code ref
1372							#
1373	7			7		23	my ($self, $data_ar, $eval_param_hr, $eval_text, $index, $tag_fg)=@_;
1374	7					11	0 && debug("eval code start $eval_text");
1375	7		50			25	my $html_ar=$eval_perl_cr->(@_) \|\| return err();
1376	7					12	0 && debug("eval code finish %s, %s", Dumper($html_ar, $eval_param_hr));
1377
1378
1379							# We only accept first item of any array ref returned (which might be an array ref itself)
1380							#
1381	7					20	my $html_sr=$html_ar->[0];
1382
1383
1384							# If array ref returned and not rendering a tag convert to string. If in tag CGI.pm can
1385							# use array ref so leave alone
1386							#
1387	7	50	33			30	if ((ref($html_sr) eq 'ARRAY') && !$tag_fg) {
1388	0		0			0	$html_sr=\join(undef, map {(ref($_) eq 'SCALAR') ? ${$_} : $_} @{$html_sr}) \|\|
1389							return err('unable to generate scalar from %s', Dumper($html_sr));
1390							}
1391
1392
1393							# Any 'printed data ? Prepend to output. Used to do $self->{'_print_ar'}{$data_ar} but changed to
1394							# just $self->{'_print_ar'}. See code history for background
1395							#
1396	7	50				26	if (my $print_ar=delete $self->{'_print_ar'}) {
1397	0					0	0 && debug("print_ar: $print_ar %s", Dumper($print_ar));
1398	0					0	foreach my $item (reverse @{$print_ar}) {
	0					0
1399	0					0	0 && debug("prepending printed data %s for data_ar: $data_ar, %s", Dumper($item, $data_ar));
1400	0	0				0	my $print_html=(ref($item) eq 'SCALAR') ? ${$item} : $item;
	0					0
1401	0	0				0	$html_sr=ref($html_sr) ? \($print_html . ${$html_sr}) : ($print_html . $html_sr);
	0					0
1402							}
1403							}
1404							else {
1405	7					12	0 && debug('no printed data detected');
1406							}
1407
1408
1409							# Make sure we return a ref
1410							#
1411	7	100				39	return ref($html_sr) ? $html_sr : \$html_sr;
1412
1413	7					34	};
1414
1415
1416							# Scalar (${foo}) routine
1417							#
1418							my $eval_scalar_cr=sub {
1419
1420	0			0		0	my $value=$_[2]->{$_[3]};
1421	0	0				0	unless ($value) {
1422	0	0	0			0	if (!exists($_[2]->{$_[3]}) && WEBDYNE_STRICT_VARS) {
1423	0					0	return err("no '$_[3]' parameter value supplied, parameters are: %s", join(',', map {"'$_'"} keys %{$_[2]}))
	0					0
	0					0
1424							}
1425							}
1426
1427							# Get rid of any overloading
1428	0	0	0			0	if (ref($value) && overload::Overloaded($value)) {$value="$value"}
	0					0
1429	0	0				0	return ref($value) ? $value : \$value
1430
1431	7					62	};
1432
1433
1434							# Init anon text and attr evaluation subroutines, store in class space
1435							# for quick retrieval when needed, save redefining all the time
1436							#
1437							my %eval_cr=(
1438
1439							'$' => $eval_scalar_cr,
1440							'@' => $eval_array_cr,
1441							'%' => $eval_hash_cr,
1442							'!' => $eval_code_cr,
1443	0			0		0	'+' => sub {return \($_[0]->CGI()->param($_[3]))},
1444	0			0		0	'*' => sub {return \$ENV{$_[3]}},
1445							'^' => sub {
1446	0			0		0	my $m=$_[3]; my $r=$_[0]->{'_r'};
	0					0
1447	0	0				0	UNIVERSAL::can($r, $m) ? \$r->$m : err("unknown request method '$m'")
1448							}
1449
1450	7					88	);
1451
1452
1453							# Store in class name space
1454							#
1455	7					173	$Package{'_eval_cr'}=\%eval_cr;
1456
1457							}
1458
1459
1460							sub cache_clean {
1461
1462
1463							# Get cache_hr, only param supplied
1464							#
1465	0			0	0	0	my $cache_hr=shift();
1466	0					0	0 && debug('in cache_clean');
1467
1468
1469							# Values we want, either last run time (lrun) or number of times run
1470							# (nrun)
1471							#
1472	0					0	my $clean_method=WEBDYNE_CACHE_CLEAN_METHOD ? 'nrun' : 'lrun';
1473
1474
1475							# Sort into array of inode values, sorted descending by clean attr
1476							#
1477	0					0	my @cache=sort {$cache_hr->{$b}{$clean_method} <=> $cache_hr->{$a}{$clean_method}}
1478	0					0	keys %{$cache_hr};
	0					0
1479	0					0	0 && debug('cache clean array %s', Dumper(\@cache));
1480
1481
1482							# If > high watermark entries, we need to clean
1483							#
1484	0	0				0	if (@cache > WEBDYNE_CACHE_HIGH_WATER) {
1485
1486
1487							# Yes, clean
1488							#
1489	0					0	0 && debug('cleaning cache');
1490
1491
1492							# Delete excess entries
1493							#
1494	0					0	my @clean=map {delete $cache_hr->{$_}} @cache[WEBDYNE_CACHE_LOW_WATER..$#cache];
	0					0
1495
1496
1497							# Debug
1498							#
1499	0					0	0 && debug('removed %s entries from cache', scalar @clean);
1500
1501							}
1502							else {
1503
1504							# Nothing to do
1505							#
1506	0					0	0 && debug(
1507							'no cleanup needed, cache size %s less than high watermark %s',
1508							scalar @cache, WEBDYNE_CACHE_HIGH_WATER
1509							);
1510
1511							}
1512
1513
1514							# Done
1515							#
1516	0					0	return \undef;
1517
1518							}
1519
1520
1521							sub head_request {
1522
1523
1524							# Head request only
1525							#
1526	0			0	0	0	my $r=shift();
1527
1528
1529							# Clear any handlers
1530							#
1531	0					0	$r->set_handlers(PerlHandler => undef);
1532
1533
1534							# Send the request
1535							#
1536	0	0				0	$r->send_http_header() if !$MP2;
1537
1538
1539							# Done
1540							#
1541	0					0	return &Apache::OK;
1542
1543							}
1544
1545
1546							sub render_reset {
1547
1548	0			0	0	0	my ($self, $data_ar)=@_;
1549	0	0				0	$data_ar ? $self->{'_perl'}[0]=$data_ar : delete $self->{'_perl'};
1550
1551							}
1552
1553
1554							sub render {
1555
1556
1557							# Convert data array structure into HTML
1558							#
1559	0			0	0	0	my ($self, $param_hr)=@_;
1560
1561
1562							# If not supplied param as hash ref assume all vars are params to be subs't when
1563							# rendering this data block
1564							#
1565	0	0				0	my %param=(ref($param_hr) eq 'HASH') ? %{$param_hr} : @_[1..$#_];
	0					0
1566
1567
1568							# Get node array ref
1569							#
1570	0		0			0	my $data_ar=$self->{'_perl'}[0][WEBDYNE_NODE_CHLD_IX] \|\|
1571							return err('unable to get HTML data array');
1572
1573
1574							# Any data params for this render ? Add them to parent data as additive
1575							#
1576	0					0	foreach my $perl_data_hr (@{$self->{'_perl_data'}}) {
	0					0
1577	0	0				0	map { $param{$_}=$perl_data_hr->{$_} unless exists $param{$_} } keys %{$perl_data_hr}
	0					0
	0					0
1578							}
1579
1580
1581							# Call render_node
1582							#
1583	0		0			0	return $self->render_data_ar( data=>$data_ar, param=>\%param) \|\|
1584							err();
1585
1586
1587							}
1588
1589
1590							sub render_data_ar {
1591
1592
1593							# Convert data array structure into HTML
1594							#
1595	19			19	0	81	my ($self, %param)=@_;
1596	19					32	0 && debug($self);
1597
1598
1599							# Get node array ref
1600							#
1601	19		50			67	my $data_ar=$param{'data'} \|\|
1602							return err('unable to get HTML data array');
1603
1604
1605							# Debug
1606							#
1607	19					31	0 && debug("render data_ar $data_ar");
1608
1609
1610							# Get HTML::Tiny object
1611							#
1612	19		50			113	my $html_or=$self->{'_html_tiny_or'} \|\| $self->html_tiny() \|\|
1613							return err("unable to get HTML::Tiny object from self ref");
1614	19					33	0 && debug("html_or: $html_or");
1615
1616
1617							# Stub out entity_encode - we don't want attributes escaped
1618							#
1619	0			0		0	local *HTML::Tiny::entity_encode=sub {$_[1]}
1620							unless
1621	19					184	WEBDYNE_CGI_AUTOESCAPE;
1622
1623
1624							# Recursive anon sub to do the render, init and store in class space
1625							# if not already done, saves a small amount of time if doing many
1626							# iterations
1627							#
1628	19		100			88	my $render_cr=$Package{'_render_cr'} \|\|= \&render_cr;
1629
1630
1631							# At the top level the array may have completly text nodes, and no children, so
1632							# need to take care to only render children if present.
1633							#
1634	19					35	my @html;
1635	19					36	foreach my $node_data_ar (@{$data_ar}) {
	19					51
1636
1637
1638							# Is this a sub node, or only text (ref means sub-node)
1639							#
1640	34	100				90	if (ref($node_data_ar)) {
1641
1642
1643							# Sub node, we call call render routine
1644							#
1645	9					14	0 && debug('recursive render node_data_ar: %s', Dumper($node_data_ar));
1646							push @html,
1647							#${$render_cr->($render_cr, $self, $cgi_or, $node_data_ar, \%param_data) \|\| return err()};
1648	9	50				16	${$render_cr->($render_cr, $self, $html_or, $node_data_ar, $param{'param'}) \|\| return err()};
	9					34
1649
1650
1651							}
1652							else {
1653
1654
1655							# Text only, do not render just push onto return array
1656							#
1657	25					57	0 && debug('add text only node_data_ar: %s', \$node_data_ar);
1658	25					75	push @html, $node_data_ar;
1659
1660							}
1661							}
1662
1663
1664							# Return scalar ref of completed HTML string
1665							#
1666	17					45	0 && debug('render exit, html %s', Dumper(\@html));
1667	17					227	return \join(undef, @html);
1668
1669
1670							}
1671
1672
1673							sub render_cr {
1674
1675
1676							# Code ref used recursively by render() above
1677							#
1678
1679							# Get self ref, node array etc
1680							#
1681	9			9	0	27	my ($render_cr, $self, $html_or, $data_ar, $param_data_hr)=@_;
1682	9					15	0 && debug("render_cr: $render_cr, self:$self, data_ar:$data_ar, param_data_hr:$param_data_hr (%s), caller:%s", Dumper($param_data_hr), Dumper([caller()]));
1683
1684
1685							# Get tag
1686							#
1687							my ($html_tag, $html_line_no)=
1688	9					21	@{$data_ar}[WEBDYNE_NODE_NAME_IX, WEBDYNE_NODE_LINE_IX];
	9					32
1689	9					16	my $html_chld;
1690
1691
1692							# Save current data block away for reference by error handler if something goes
1693							# wrong
1694							#
1695	9					36	push @{$self->{'_data_ar_err'}},$data_ar;
	9					27
1696
1697
1698							# Debug
1699							#
1700	9					14	0 && debug("render tag $html_tag, line $html_line_no");
1701
1702
1703							# Get attr hash ref
1704							#
1705	9					19	my $attr_hr=$data_ar->[WEBDYNE_NODE_ATTR_IX];
1706
1707
1708							# If subst flag present, means we need to process attr values
1709							#
1710	9	100				32	if ($data_ar->[WEBDYNE_NODE_SBST_IX]) {
1711	1		50			6	$attr_hr=$self->subst_attr($data_ar, $attr_hr, $param_data_hr) \|\|
1712							return err();
1713							}
1714	9					15	0 && debug("attr_hr: $attr_hr (%s)", Dumper($attr_hr));
1715
1716
1717							# If param present, use for sub-render. Commented out was when render was co-mingled, not needed now separated to render_data_ar(), render() methods
1718							#
1719							#if (!exists($param_data_hr->{'param'})) {
1720							## if ($attr_hr->{'param'}) {
1721							## my %param_data=(%{$param_data_hr}, %{$attr_hr->{'param'}});
1722							## $param_data_hr=\%param_data;
1723							## }
1724							#}
1725							#elsif ($attr_hr->{'param'}) {
1726							# $param_data_hr=$attr_hr->{'param'}
1727							#}
1728
1729	9	50				34	if (exists ($attr_hr->{'param'})) {
1730	0	0				0	if (ref($attr_hr->{'param'}) eq 'HASH') {
		0
1731	0					0	my %param_data=(%{$param_data_hr}, %{$attr_hr->{'param'}});
	0					0
	0					0
1732	0					0	$param_data_hr=\%param_data;
1733							}
1734							elsif (ref($attr_hr->{'param'})) {
1735	0					0	return err("perl param attribute is %s ref, must be HASH ref or plain scalar", ref($attr_hr->{'param'}));
1736							}
1737							}
1738
1739
1740	9					14	0 && debug('result: %s', Dumper($param_data_hr));
1741
1742
1743							# Was this, but it didn't allow nested param
1744							#
1745							#$attr_hr->{'param'} && ($param_data_hr=$attr_hr->{'param'});
1746	9					14	unshift @{$self->{'_perl_data'}}, $param_data_hr;
	9					37
1747
1748
1749							# Process sub nodes to get child html data, only if not a perl tag or block tag
1750							# though - they will choose when to render sub data. Subst is OK
1751							#
1752	9	100	66			73	if (!$CGI_TAG_WEBDYNE{$html_tag} \|\| ($html_tag eq 'subst')) {
1753
1754
1755							# Not a perl tag, recurse through children and render them, building
1756							# up HTML from inside out
1757							#
1758	1	50				6	my @data_child_ar=$data_ar->[WEBDYNE_NODE_CHLD_IX] ? @{$data_ar->[WEBDYNE_NODE_CHLD_IX]} : undef;
	0					0
1759	1					4	foreach my $data_chld_ar (@data_child_ar) {
1760
1761
1762							# Debug
1763							#
1764	1					2	0 && debug('data_chld_ar %s', Dumper($data_chld_ar));
1765
1766
1767							# Only recurse on children which are are refs, as these are sub nodes. A
1768							# child that is not a ref is merely HTML text
1769							#
1770	1	50				4	if (ref($data_chld_ar)) {
1771
1772
1773							# It is a sub node, render recursively
1774							#
1775							$html_chld.=${
1776	0					0	(
1777	0	0				0	$render_cr->($render_cr, $self, $html_or, $data_chld_ar, $param_data_hr)
1778							\|\|
1779							return err())};
1780
1781							#$html_chld.="\n";
1782
1783							}
1784							else {
1785
1786
1787							# Text node only, add text to child html string
1788							#
1789	1					4	$html_chld.=$data_chld_ar;
1790
1791							}
1792
1793							}
1794
1795							}
1796							else {
1797
1798	8					12	0 && debug("skip child render, under $html_tag tag");
1799
1800							}
1801
1802
1803							# Debug
1804							#
1805	9					15	0 && debug("html_chld $html_chld");
1806	9					19	my $html;
1807
1808
1809							# Render our node now, trying to use most efficient/appropriated method depending on a number
1810							# of factors
1811							#
1812	9	100				29	if ($CGI_TAG_WEBDYNE{$html_tag}) {
		50
		0
1813
1814
1815							# Special WebDyne tag, render using our self ref, not CGI object
1816							#
1817	8					14	0 && debug("rendering webdyne tag $html_tag");
1818	8	50				29	$html=${ $self->$html_tag($data_ar, $attr_hr, $param_data_hr, $html_chld) \|\|
	8					43
1819							return err() };
1820
1821
1822
1823							}
1824							elsif ($attr_hr) {
1825
1826
1827							# Normal CGI tag, with attributes and perhaps child text
1828							#
1829	1					2	0 && debug("rendering normal HTML tag: $html_tag with attr: %s", Dumper($attr_hr));
1830	1		50			5	$html=$html_or->$html_tag(grep {$_} $attr_hr \|\| {}, $html_chld) \|\|
1831							return err( "CGI tag '<$html_tag>' did not return any text" );
1832
1833
1834							}
1835							elsif ($html_chld) {
1836
1837
1838							# Normal CGI tag, no attributes but with child text
1839							#
1840	0					0	0 && debug("rendering normal HTML tag: $html_tag, no attributes but with child text");
1841	0		0			0	$html=$html_or->$html_tag($html_chld) \|\|
1842							return err("CGI tag '<$html_tag>' did not return any text");
1843
1844
1845							}
1846							else {
1847
1848
1849							# Empty CGI object, eg
1850							#
1851	0					0	0 && debug("rendering empty HTML tag: $html_tag");
1852	0		0			0	$html=$html_or->$html_tag() \|\|
1853							return err("CGI tag '<$html_tag>' did not return any text");
1854
1855							}
1856
1857
1858							# No errors, pop error handler stack
1859							#
1860	7					16	pop @{$self->{'_data_ar_err'}};
	7					20
1861	7					12	shift @{$self->{'_perl_data'}};
	7					16
1862
1863
1864							# Return
1865							#
1866	7					51	return \$html;
1867
1868
1869							}
1870
1871
1872
1873							sub redirect {
1874
1875
1876							# Redirect render to different location
1877							#
1878	2			2	0	11	my ($self, $param_hr)=@_;
1879
1880
1881							# If not supplied param as hash ref assume all vars are params to be subs't when
1882							# rendering this data block
1883							#
1884	2	50	33			27	ref($param_hr) \|\| ($param_hr={@_[1..$#_]}) if $param_hr;
1885
1886
1887							# Debug
1888							#
1889	2					5	0 && debug('in redirect, param %s', Dumper($param_hr));
1890
1891
1892							# Restore select handler before anything else so all output goes
1893							# to main::STDOUT;
1894							#
1895	2	50				8	if (my $select=$self->{'_select'}) {
1896	2					3	0 && debug("restoring select handle to $select");
1897	2					13	CORE::select $select;
1898							}
1899
1900
1901							# If redirecting to a different uri, run its handler
1902							#
1903	2	50	33			18	if ($param_hr->{'uri'} \|\| $param_hr->{'file'} \|\| $param_hr->{'location'}) {
			33
1904
1905
1906							# Get HTML from subrequest
1907							#
1908	0		0			0	my $status=$self->subrequest($param_hr) \|\|
1909							return err();
1910	0					0	0 && debug("redirect status was $status");
1911
1912
1913							# GOTOs considered harmful - except here ! Speed things up significantly, removes uneeded checks
1914							# for redirects in render code etc.
1915							#
1916	0		0			0	my $r=$self->r() \|\| return err();
1917	0					0	$r->status($status);
1918	0	0	0			0	if (my $errstr=errstr()) {
		0	0
		0
1919	0					0	0 && debug("error in subrequest: $errstr");
1920	0					0	return errsubst("error in subrequest: $errstr")
1921							}
1922							elsif (is_error($status)) {
1923	0					0	0 && debug("sending error response status $status with r $r");
1924	0					0	$r->send_error_response(&Apache::OK)
1925							}
1926							elsif (($status != &Apache::OK) && !is_success($status) && !is_redirect($status)) {
1927	0					0	return err("unknown status code '$status' returned from subrequest");
1928							}
1929							else {
1930	0					0	0 && debug("status $status OK");
1931							}
1932	0					0	goto HANDLER_COMPLETE;
1933
1934
1935							}
1936							else {
1937
1938
1939							# html/text/json must be a param
1940							#
1941	2		50			9	my $html_sr=$param_hr->{'html'} \|\| $param_hr->{'text'} \|\| $param_hr->{'json'} \|\|
1942							return err('no data supplied to redirect method');
1943
1944
1945							# Set content type
1946							#
1947	2		50			11	my $r=$self->r() \|\| return err();
1948	2	100				17	if ($param_hr->{'html'}) {
		50
		50
1949	1					6	$r->content_type(WEBDYNE_CONTENT_TYPE_HTML)
1950							}
1951							elsif ($param_hr->{'text'}) {
1952	0					0	$r->content_type(WEBDYNE_CONTENT_TYPE_TEXT)
1953							}
1954							elsif ($param_hr->{'json'}) {
1955	1					6	$r->content_type(WEBDYNE_CONTENT_TYPE_JSON)
1956							}
1957
1958
1959							# And length
1960							#
1961	2		50			9	my $headers_out_hr=$r->headers_out \|\| return err();
1962	2	100				8	$headers_out_hr->{'Content-Length'}=length(ref($html_sr) ? ${$html_sr} : $html_sr);
	1					3
1963
1964
1965							# Set status, send header
1966							#
1967	2					15	$r->status(HTTP_OK);
1968	2	50				28	$r->send_http_header() if !$MP2;
1969
1970
1971							# Print directly and shorcut return from render routine with non-harmful GOTO ! Should
1972							# always be SR, but be generous.
1973							#
1974	2	100				8	$r->print(ref($html_sr) ? ${$html_sr} : $html_sr);
	1					5
1975	2					200	goto RENDER_COMPLETE;
1976
1977
1978							}
1979
1980
1981							}
1982
1983
1984							sub subrequest {
1985
1986
1987							# Redirect render to different location
1988							#
1989	0			0	0	0	my ($self, $param_hr)=@_;
1990
1991
1992							# Debug
1993							#
1994	0					0	0 && debug('in subrequest %s', Dumper($param_hr));
1995
1996
1997							# Get request object, var for subrequest object
1998							#
1999	0	0				0	my ($r, $cgi_or)=map {$self->$_() \|\| return err("unable to run '$_' method")} qw(request CGI);
	0					0
2000	0					0	my $r_child;
2001
2002
2003							# Run taks appropriate for subrequest - location redirects with 302, uri does sinternal redirect,
2004							# and file sends content of file.
2005							#
2006	0	0				0	if (my $location=$param_hr->{'location'}) {
2007
2008
2009							# Does the request handler take care of it ?
2010							#
2011	0	0				0	if (UNIVERSAL::can($r, 'redirect')) {
2012
2013
2014							# Let the request handler take care of it
2015							#
2016	0					0	0 && debug('handler does redirect, handing off');
2017	0					0	$r->redirect($location); # no return value
2018	0					0	return HTTP_FOUND;
2019
2020							}
2021							else {
2022
2023
2024							# Must do it ourselves
2025							#
2026	0					0	0 && debug('doing redirect ourselves');
2027	0		0			0	my $headers_out_hr=$r->headers_out \|\| return err();
2028	0					0	$headers_out_hr->{'Location'}=$location;
2029	0					0	$r->status(HTTP_FOUND);
2030	0	0				0	$r->send_http_header if !$MP2;
2031	0					0	return HTTP_FOUND;
2032
2033							}
2034							}
2035	0	0				0	if (my $uri=$param_hr->{'uri'}) {
		0
2036
2037							# Handle internally if possible
2038							#
2039	0	0				0	if (UNIVERSAL::can($r, 'internal_redirect')) {
2040
2041
2042							# Let the request handler take care of it
2043							#
2044	0					0	0 && debug('handler does internal_redirect, handing off');
2045	0					0	$r->internal_redirect($uri); # no return value
2046	0					0	return $r->status;
2047
2048							}
2049							else {
2050
2051							# Must do it ourselves
2052							#
2053	0		0			0	$r_child=$r->lookup_uri($uri) \|\|
2054							return err('undefined lookup_uri error');
2055	0					0	0 && debug('r_child handler %s', $r->handler());
2056	0					0	$r->headers_out($r_child->headers_out());
2057	0					0	$r->uri($uri);
2058
2059							}
2060
2061
2062							}
2063							elsif (my $file=$param_hr->{'file'}) {
2064
2065							# Get cwd, make request absolute rel to cwd if no dir given.
2066							#
2067	0					0	my $dn=(File::Spec->splitpath($r->filename()))[1];
2068	0					0	my $file_pn=File::Spec->rel2abs($file, $dn);
2069
2070
2071							# Get a new request object
2072							#
2073	0		0			0	$r_child=$r->lookup_file($file_pn) \|\|
2074							return err('undefined lookup_file error');
2075	0					0	$r->headers_out($r_child->headers_out());
2076
2077							}
2078							else {
2079
2080
2081							# Must be one or other
2082							#
2083	0					0	return err('must specify file, uri or locations for subrequest');
2084
2085							}
2086
2087
2088							# Save child object, else cleanup handlers will be run when
2089							# we exit and r_child is destroyed, but before r (main) is
2090							# complete.
2091							#
2092							# UPDATE no longer needed, leave here as reminder though ..
2093							#
2094							#push @{$self->{'_r_child'}},$r_child;
2095
2096
2097							# Safty check after calling getting r_child - should always be
2098							# OK, but do sanity check.
2099							#
2100	0					0	my $status=$r_child->status();
2101	0					0	0 && debug("r_child status return: $status");
2102	0	0	0			0	if (($status && !is_success($status)) \|\| (my $errstr=errstr())) {
			0
2103	0	0				0	if ($errstr) {
2104							return errsubst(
2105							"error in status phase of subrequest to '%s': $errstr",
2106	0		0			0	$r_child->uri() \|\| $param_hr->{'file'}
2107							)
2108							}
2109							else {
2110							return err(
2111							"error in status phase of subrequest to '%s', return status was $status",
2112	0		0			0	$r_child->uri() \|\| $param_hr->{'file'}
2113							)
2114							}
2115							}
2116
2117
2118							# Debug
2119							#
2120	0					0	0 && debug('cgi param %s', Dumper($param_hr->{'param'}));
2121
2122
2123							# Set up CGI with any new params
2124							#
2125	0					0	while (my ($param, $value)=each %{$param_hr->{'param'}}) {
	0					0
2126
2127
2128							# Add to CGI
2129							#
2130	0					0	$cgi_or->param($param, $value);
2131	0					0	0 && debug("set cgi param $param, value $value");
2132
2133
2134							}
2135
2136
2137							# Debug
2138							#
2139	0					0	0 && debug("about to call child handler with params self $self %s", Dumper($param_hr->{'param'}));
2140
2141
2142							# Change of plan - used to check result, but now pass back whatever the child returns - we
2143							# will let Apache handle any errors internally
2144							#
2145	0	0				0	defined($status=(ref($r_child)=~/^WebDyne::/) ? $r_child->run($self) : $r_child->run()) \|\|
		0
2146							return err();
2147	0					0	0 && debug("r_child run return status $status, rc_child status %s", $r_child->status());
2148	0		0			0	return $status \|\| $r_child->status();
2149
2150
2151							}
2152
2153
2154							sub eof {
2155
2156	0			0	0	0	goto HANDLER_COMPLETE;
2157
2158							}
2159
2160
2161							sub erase_block {
2162
2163							# Erase a block section so not rendered if encountered again
2164							#
2165	0			0	0	0	my ($self, $param_hr)=@_;
2166
2167
2168							# Has user only given name as param
2169							#
2170	0	0				0	ref($param_hr) \|\| ($param_hr={name => $param_hr, param => {@_[2..$#_]}});
2171
2172
2173							# Get block name
2174							#
2175	0		0			0	my $name=$param_hr->{'name'} \|\| $param_hr->{'block'} \|\|
2176							return err('no block name specified');
2177	0					0	0 && debug("in erase_block, name $name");
2178	0					0	delete $self->{'_block_param'}{$name};
2179	0					0	delete $self->{'_block_render'}{$name}
2180
2181							}
2182
2183
2184							sub unrender_block {
2185
2186							# Synonym for erase_block
2187							#
2188	0			0	0	0	return shift()->erase_block(@_);
2189
2190							}
2191
2192
2193							sub render_block {
2194
2195
2196							# Render a section of HTML
2197							#
2198	0			0	0	0	my ($self, $param_hr)=@_;
2199
2200
2201							# Has user only given name as param
2202							#
2203	0	0				0	ref($param_hr) \|\| ($param_hr={name => $param_hr, param => {@_[2..$#_]}});
2204
2205
2206							# Get block name
2207							#
2208	0		0			0	my $name=$param_hr->{'name'} \|\| $param_hr->{'block'} \|\|
2209							return err('no block name specified');
2210	0					0	0 && debug("in render_block, name $name");
2211
2212
2213							# Get current data block
2214							#
2215							#my $data_ar=$self->{'_perl'}[0] \|\|
2216							#return err("unable to get current data node");
2217	0		0			0	my $data_ar=$self->{'_perl'}[0] \|\| do {
2218
2219							#if ($WEBDYNE_DELAYED_BLOCK_RENDER) {
2220							push @{$self->{'_block_param'}{$name} \|\|= []}, $param_hr->{'param'}; # if $WEBDYNE_DELAYED_BLOCK_RENDER;
2221							return \undef;
2222
2223							#}
2224							#else {
2225							# return err("unable to get current data node")
2226							#}
2227							};
2228
2229
2230							# Find block name
2231							#
2232	0					0	my @data_block_ar;
2233
2234
2235							# Debug
2236							#
2237	0					0	0 && debug("render_block self $self, name $name, data_ar $data_ar, %s", Dumper($data_ar));
2238
2239
2240							# Have we seen this search befor ?
2241							#
2242	0	0				0	unless (exists($self->{'_block_cache'}{$name})) {
2243
2244
2245							# No, search for block
2246							#
2247	0					0	0 && debug("searching for node $name in data_ar");
2248
2249
2250							# Do it
2251							#
2252	0		0			0	my $data_block_all_ar=$self->find_node(
2253							{
2254
2255							data_ar => $data_ar,
2256							tag => 'block',
2257							all_fg => 1,
2258
2259							}) \|\| return err();
2260
2261
2262							# Debug
2263							#
2264	0					0	0 && debug('find_node returned %s', join('*', @{$data_block_all_ar}));
2265
2266
2267							# Go through each block found and svae in block_cache
2268							#
2269	0					0	foreach my $data_block_ar (@{$data_block_all_ar}) {
	0					0
2270
2271
2272							# Get block name
2273							#
2274	0					0	my $name=$data_block_ar->[WEBDYNE_NODE_ATTR_IX]->{'name'};
2275	0					0	0 && debug("looking at block $data_block_ar, name $name");
2276
2277
2278							# Save
2279							#
2280							#$self->{'_block_cache'}{$name}=$data_block_ar;
2281	0		0			0	push @{$self->{'_block_cache'}{$name} \|\|= []}, $data_block_ar;
	0					0
2282
2283
2284							}
2285
2286
2287							# Done, store
2288							#
2289	0					0	@data_block_ar=@{$self->{'_block_cache'}{$name}};
	0					0
2290
2291
2292							}
2293							else {
2294
2295
2296							# Yes, set data_block_ar to whatever we saw before, even if it is
2297							# undef
2298							#
2299	0					0	@data_block_ar=@{$self->{'_block_cache'}{$name}};
	0					0
2300
2301
2302							# Debug
2303							#
2304	0					0	0 && debug("retrieved data_block_ar @data_block_ar for node $name from cache");
2305
2306
2307							}
2308
2309
2310							# Debug
2311							#
2312							#debug("set block node to $data_block_ar %s", Dumper($data_block_ar));
2313
2314
2315							# Store params for later block render (outside perl block) if needed
2316							#
2317	0		0			0	push @{$self->{'_block_param'}{$name} \|\|= []}, $param_hr->{'param'}; # if $WEBDYNE_DELAYED_BLOCK_RENDER;
	0					0
2318
2319
2320							# No data_block_ar ? Could not find block - remove this line if global block
2321							# rendering is desired (ie blocks may lay outside perl code calling render_bloc())
2322							#
2323	0	0				0	unless (@data_block_ar) {
2324
2325							#if ($WEBDYNE_DELAYED_BLOCK_RENDER) {
2326	0					0	return \undef;
2327
2328							#}
2329							#else {
2330							# return err("could not find block '$name' to render") unless $WEBDYNE_DELAYED_BLOCK_RENDER;
2331							#}
2332							}
2333
2334
2335							# Now, was it set to something ?
2336							#
2337	0					0	my @html_sr;
2338	0					0	foreach my $data_block_ar (@data_block_ar) {
2339
2340
2341							# Debug
2342							#
2343	0					0	0 && debug("rendering block name $name, data $data_ar with param %s", Dumper($param_hr->{'param'}));
2344
2345
2346							# Yes, Get HTML for block immedialtly
2347							#
2348							my $html_sr=$self->render_data_ar(
2349							data => $data_block_ar->[WEBDYNE_NODE_CHLD_IX],
2350	0		0			0	param => $param_hr->{'param'},
2351							) \|\| return err();
2352
2353
2354							# Debug
2355							#
2356	0					0	0 && debug("block $name rendered HTML $html_sr %s, pushing onto name $name, data_ar $data_block_ar", ${$html_sr});
2357
2358
2359							# Store away for this block
2360							#
2361	0		0			0	push @{$self->{'_block_render'}{$name}{$data_block_ar} \|\|= []}, $html_sr;
	0					0
2362
2363
2364							# Store
2365							#
2366	0					0	push @html_sr, $html_sr;
2367
2368
2369							}
2370	0	0				0	if (@html_sr) {
2371
2372
2373							# Return scalar or array ref, depending on number of elements
2374							#
2375							#debug('returning %s', Dumper(\@html_sr));
2376	0	0				0	return $#html_sr ? $html_sr[0] : \@html_sr;
2377
2378							}
2379							else {
2380
2381
2382							# No, could not find block below us, store param away for later
2383							# render. NOTE now done for all blocks so work both in and out of
2384							# section. Moved this code above
2385							#
2386							#push @{$self->{'_block_param'}{$name} \|\|=[]},$param_hr->{'param'};
2387
2388
2389							# Debug
2390							#
2391	0					0	0 && debug("block $name not found in tree, storing params for later render");
2392
2393
2394							# Done, return undef at this stage
2395							#
2396	0					0	return \undef;
2397
2398							}
2399
2400
2401							}
2402
2403
2404							sub block {
2405
2406
2407							# Called when we encounter a tag
2408							#
2409	0			0	0	0	my ($self, $data_ar, $attr_hr, $param_data_hr, $text)=@_;
2410	0					0	0 && debug("in block code, data_ar $data_ar");
2411
2412
2413							# Get block name
2414							#
2415	0		0			0	my $name=$attr_hr->{'name'} \|\|
2416							return err('no block name specified');
2417	0					0	0 && debug("in block, looking for name $name, attr given %s", Dumper($attr_hr));
2418
2419
2420							# Only render if registered, do once for every time spec'd
2421							#
2422	0	0				0	if (exists($self->{'_block_render'}{$name}{$data_ar})) {
		0
		0
2423
2424
2425							# The block name has been pre-rendered - return it
2426							#
2427	0					0	0 && debug("found pre-rendered block $name");
2428
2429
2430							# Var to hold render result
2431							#
2432	0					0	my $html_ar=delete $self->{'_block_render'}{$name}{$data_ar};
2433
2434
2435							# Return result as a single scalar ref
2436							#
2437	0					0	return \join(undef, map {${$_}} @{$html_ar});
	0					0
	0					0
	0					0
2438
2439
2440							}
2441							elsif (exists($self->{'_block_param'}{$name})) {
2442
2443
2444							# The block params have been registered, but the block itself was
2445							# not yet rendered. Do it now
2446							#
2447	0					0	0 && debug("found block param for $name in register");
2448
2449
2450							# Var to hold render result
2451							#
2452	0					0	my @html_sr;
2453
2454
2455							# Render the block for as many times as it has parameters associated
2456							# with it, eg user may have called ->render_block several times in
2457							# their code
2458							#
2459	0					0	foreach my $param_data_block_hr (@{$self->{'_block_param'}{$name}}) {
	0					0
2460
2461
2462							# If no explicit data hash, use parent hash - not sure how useful
2463							# this really is
2464							#
2465	0		0			0	$param_data_block_hr \|\|= $param_data_hr;
2466
2467
2468							# Debug
2469							#
2470	0					0	0 && debug("about to render block $name, param %s", Dumper($param_data_block_hr));
2471
2472
2473							# Render it
2474							#
2475	0		0			0	push @html_sr, $self->render_data_ar(
2476							data => $data_ar->[WEBDYNE_NODE_CHLD_IX],
2477							param => $param_data_block_hr
2478							) \|\| return err();
2479
2480							}
2481
2482
2483							# Return result as a single scalar ref
2484							#
2485	0					0	return \join(undef, map {${$_}} @html_sr);
	0					0
	0					0
2486
2487							}
2488							elsif ($attr_hr->{'display'}) {
2489
2490
2491							# User wants block displayed normally
2492							#
2493	0		0			0	return $self->render_data_ar(
2494							data => $data_ar->[WEBDYNE_NODE_CHLD_IX],
2495							param => $param_data_hr
2496							) \|\| err();
2497
2498							}
2499							else {
2500
2501
2502							# Block name not registered, therefore do not render - return
2503							# blank
2504							#
2505	0					0	return \undef;
2506
2507							}
2508
2509
2510							}
2511
2512
2513							sub json {
2514
2515
2516							# Called when we encounter a tag
2517							#
2518	0			0	0	0	my ($self, $data_ar, $attr_hr, $param_data_hr, $text)=@_;
2519	0					0	0 && debug("$self rendering json tag in block $data_ar, attr %s", $attr_hr);
2520
2521
2522							# Check we have a handler
2523							#
2524	0	0	0			0	$attr_hr->{'handler'} \|\| $attr_hr->{'perl'} \|\|
2525							return err('no json tag perl handler supplied');
2526
2527
2528							# Run the code in perl routine specifying it is JSON, get return ref of
2529							# some kind
2530							#
2531	0	0				0	defined(my $json_xr=$self->perl(undef, {json => 1, %{$attr_hr}})) \|\|
	0					0
2532							return err();
2533	0	0				0	if (ref($json_xr) eq 'SCALAR') {
2534	0					0	$json_xr=${$json_xr}
	0					0
2535							}
2536	0					0	0 && debug("json_xr %s", Dumper($json_xr));
2537
2538
2539							# Convert to JSON
2540							#
2541	0		0			0	my $json_or=JSON->new() \|\|
2542							return err('unable to create new JSON object');
2543	0					0	0 && debug("json_or: $json_or");
2544	0	0				0	$json_or->canonical(defined($attr_hr->{'canonical'}) ? ($attr_hr->{'canonical'} ? 1 : 0) : WEBDYNE_JSON_CANONICAL);
		0
2545	0	0				0	$json_or->pretty(defined($attr_hr->{'pretty'}) ? ($attr_hr->{'pretty'} ? 1 : 0) : WEBDYNE_JSON_PRETTY);
		0
2546	0		0			0	my $json=eval {$json_or->encode($json_xr)} \|\|
2547							return err('error %s on json_encode of %s', $@, Dumper($json_xr));
2548	0					0	0 && debug("json %s", Dumper($json));
2549
2550
2551							# Get new WebDyne::HTML::Tiny object ready to encode result into