File Coverage

blib/lib/WebDyne/Constant.pm
Criterion Covered Total %
statement 44 81 54.3
branch 9 26 34.6
condition 1 6 16.6
subroutine 10 11 90.9
pod 0 4 0.0
total 64 128 50.0


line stmt bran cond sub pod time code
1             #
2             # This file is part of WebDyne.
3             #
4             # This software is Copyright (c) 2017 by Andrew Speer .
5             #
6             # This is free software, licensed under:
7             #
8             # The GNU General Public License, Version 2, June 1991
9             #
10             # Full license text is available at:
11             #
12             #
13             #
14             package WebDyne::Constant;
15              
16              
17             # Pragma
18             #
19 2     2   11 use strict qw(vars);
  2         4  
  2         62  
20 2     2   9 use vars qw($VERSION @ISA %EXPORT_TAGS @EXPORT_OK @EXPORT %Constant);
  2         4  
  2         105  
21 2     2   8 use warnings;
  2         3  
  2         40  
22 2     2   8 no warnings qw(uninitialized);
  2         4  
  2         64  
23             local $^W=0;
24              
25              
26             # External modules
27             #
28 2     2   530 use WebDyne::Base;
  2         44  
  2         15  
29 2     2   15 use File::Spec;
  2         4  
  2         61  
30 2     2   11 use Data::Dumper;
  2         3  
  2         1891  
31             require Opcode;
32              
33              
34             # Version information
35             #
36             $VERSION='1.247';
37              
38              
39             # Get mod_perl version. Clear $@ after evals
40             #
41             eval {require mod_perl2 if ($ENV{'MOD_PERL_API_VERSION'} == 2)} ||
42             eval {require Apache2 if $ENV{'MOD_PERL'}=~/1.99/} ||
43             eval {require mod_perl if $ENV{'MOD_PERL'}};
44             eval {undef} if $@;
45             my $Mod_perl_version=$mod_perl::VERSION || $mod_perl2::VERSION || $ENV{MOD_PERL_API_VERSION};
46             my $MP2=($Mod_perl_version > 1.99) ? 1 : 0;
47              
48              
49             # Hash of constants
50             #
51             %Constant=(
52              
53              
54             # Array structure index abstraction. Do not change or bad
55             # things will happen.
56             #
57             WEBDYNE_NODE_NAME_IX => 0,
58             WEBDYNE_NODE_ATTR_IX => 1,
59             WEBDYNE_NODE_CHLD_IX => 2,
60             WEBDYNE_NODE_SBST_IX => 3,
61             WEBDYNE_NODE_LINE_IX => 4,
62             WEBDYNE_NODE_LINE_TAG_END_IX => 5,
63             WEBDYNE_NODE_SRCE_IX => 6,
64              
65              
66             # Container structure
67             #
68             WEBDYNE_CONTAINER_META_IX => 0,
69             WEBDYNE_CONTAINER_DATA_IX => 1,
70              
71              
72             # Where compiled scripts are stored. Scripts are stored in
73             # here with a the inode of the source file as the cache
74             # file name.
75             #
76             WEBDYNE_CACHE_DN => &cache_dn,
77              
78              
79             # Empty cache files at startup ? Default is yes (psp files wil be
80             # recompiled again after a server restart)
81             #
82             WEBDYNE_STARTUP_CACHE_FLUSH => 1,
83              
84              
85             # How often to check cache for excess entries, clean to
86             # low_water if > high_water entries, based on last used
87             # time or frequency.
88             #
89             # clean_method 0 = clean based on last used time (oldest
90             # get cleaned)
91             #
92             # clean_method 1 = clean based on frequency of use (least
93             # used get cleaned)
94             #
95             WEBDYNE_CACHE_CHECK_FREQ => 256,
96             WEBDYNE_CACHE_HIGH_WATER => 64,
97             WEBDYNE_CACHE_LOW_WATER => 32,
98             WEBDYNE_CACHE_CLEAN_METHOD => 1,
99              
100              
101             # Type of eval code to run - use Safe module, or direct. Direct
102             # is default, but may allow subversion of code
103             #
104             # 1 = Safe # Not tested much - don't assume it is really safe !
105             # 0 = Direct (UnSafe)
106             #
107             WEBDYNE_EVAL_SAFE => 0,
108              
109              
110             # Prefix eval code with strict pragma. Can be undef'd to remove
111             # this behaviour, or altered to suit local taste
112             #
113             WEBDYNE_EVAL_USE_STRICT => 'use strict qw(vars);',
114              
115              
116             # Global opcode set, only these opcodes can be used if using a
117             # safe eval type. Uncomment the full_opset line if you want to
118             # be able to use all perl opcodes. Ignored if using direct eval
119             #
120             #WEBDYNE_EVAL_SAFE_OPCODE_AR => [&Opcode::full_opset()],
121             #WEBDYNE_EVAL_SAFE_OPCODE_AR => [&Opcode::opset(':default')],
122             WEBDYNE_EVAL_SAFE_OPCODE_AR => [':default'],
123              
124              
125             # Use strict var checking, eg will check that a when ${varname} param
126             # exists with a HTML page that the calling perl code (a) supplies a
127             # "varname" hash parm, and (b) that param is not undef
128             #
129             WEBDYNE_STRICT_VARS => 1,
130             WEBDYNE_STRICT_DEFINED_VARS => 0,
131              
132              
133             # When a perl method loaded by a user calls another method within
134             # that just-loaded package (eg sub foo { shift()->bar() }), the
135             # WebDyne AUTOLOAD method gets called to work out where "bar" is,
136             # as it is not in the WebDyne ISA stack.
137             #
138             # By default, this gets done every time the routine is called,
139             # which can add up when done many times. By setting the var below
140             # to 1, the AUTOLOAD method will pollute the WebDyne class with
141             # a code ref to the method in question, saving a run through
142             # AUTOLOAD if it is ever called again. The downside - it is
143             # forever, and if your module has a method of the same name as
144             # one in the WebDyne class, it will clobber the WebDyne one, probably
145             # bringing the whole lot crashing down around your ears.
146             #
147             # The upside. A speedup of about 10% on modules that use AUTOLOAD
148             # heavily
149             #
150             WEBDYNE_AUTOLOAD_POLLUTE => 0,
151              
152              
153             # Dump flag. Set to 1 if you want the tag to display the
154             # current CGI status
155             #
156             WEBDYNE_DUMP_FLAG => 0,
157              
158              
159             # DTD to use when generating HTML
160             #
161             WEBDYNE_DTD =>
162             '
163             '"http://www.w3.org/TR/html4/loose.dtd">',
164              
165              
166             # Content-type for text/html. Combined with charset to produce Content-type header
167             #
168             WEBDYNE_CONTENT_TYPE_HTML => 'text/html',
169              
170              
171             # Content-type for text/plain. As above
172             #
173             WEBDYNE_CONTENT_TYPE_PLAIN => 'text/plain',
174              
175              
176             # Encoding
177             #
178             WEBDYNE_CHARSET => 'ISO-8859-1',
179              
180              
181             # Include a Content-Type meta tag ?
182             #
183             WEBDYNE_CONTENT_TYPE_HTML_META => 0,
184              
185              
186             # Default tag paramaters, eg { lang =>'en-US' }
187             #
188             WEBDYNE_HTML_PARAM => undef,
189              
190              
191             # Ignore ignorable whitespace in compile. Play around with these settings if
192             # you don't like the formatting of the compiled HTML. See HTML::TreeBuilder
193             # man page for details here
194             #
195             WEBDYNE_COMPILE_IGNORE_WHITESPACE => 1,
196             WEBDYNE_COMPILE_NO_SPACE_COMPACTING => 0,
197              
198              
199             # Store and render comments ?
200             #
201             WEBDYNE_STORE_COMMENTS => 0,
202              
203              
204             # Send no-cache headers ?
205             #
206             WEBDYNE_NO_CACHE => 1,
207              
208              
209             # Render blocks outside of perl code
210             #
211             #WEBDYNE_DELAYED_BLOCK_RENDER => 1,
212              
213              
214             # Are warnings fatal ?
215             #
216             WEBDYNE_WARNINGS_FATAL => 0,
217              
218              
219             # CGI disable uploads default, max post size default
220             #
221             WEBDYNE_CGI_DISABLE_UPLOADS => 1,
222             WEBDYNE_CGI_POST_MAX => (512*1024), #512Kb
223              
224              
225             # Expand CGI parameters found in CGI values, e.g. button with submit=1&name=2 will get those
226             # CGI params set.
227             #
228             WEBDYNE_CGI_PARAM_EXPAND => 1,
229              
230              
231             # Disable CGI autoescape of form fields ?
232             #
233             WEBDYNE_CGI_AUTOESCAPE => 0,
234              
235              
236             # Error handling. Use text errors rather than HTML ?
237             #
238             WEBDYNE_ERROR_TEXT => 0,
239              
240              
241             # Show errors ? Extended shows additional information with granularity as per following
242             # section.
243             #
244             WEBDYNE_ERROR_SHOW => 1,
245             WEBDYNE_ERROR_SHOW_EXTENDED => 0,
246              
247              
248             # Show error, source file context, number of lines pre and post. Only applicable
249             # for extended + HTML error output.
250             #
251             WEBDYNE_ERROR_SOURCE_CONTEXT_SHOW => 1,
252             WEBDYNE_ERROR_SOURCE_CONTEXT_LINES_PRE => 4,
253             WEBDYNE_ERROR_SOURCE_CONTEXT_LINES_POST => 4,
254              
255             # Max length of source line to show in ouput. 0 for unlimited.
256             WEBDYNE_ERROR_SOURCE_CONTEXT_LINE_FRAGMENT_MAX => 80,
257              
258             # Show filename (including full filesystem path)
259             WEBDYNE_ERROR_SOURCE_FILENAME_SHOW => 1,
260              
261             # Show backtrace, show full or brief backtrace
262             WEBDYNE_ERROR_BACKTRACE_SHOW => 1,
263             WEBDYNE_ERROR_BACKTRACE_SHORT => 0,
264              
265             # Show eval trace. Uses SOURCE_CONTEXT_LINES to determine number of lines to show
266             WEBDYNE_ERROR_EVAL_CONTEXT_SHOW => 1,
267              
268             # CGI Params
269             WEBDYNE_ERROR_CGI_PARAM_SHOW => 1,
270              
271             # URI and version
272             WEBDYNE_ERROR_URI_SHOW => 1,
273             WEBDYNE_ERROR_VERSION_SHOW => 1,
274              
275              
276             # Internal indexes for error eval handler array
277             #
278             WEBDYNE_ERROR_EVAL_TEXT_IX => 0,
279             WEBDYNE_ERROR_EVAL_EMBEDDED_IX => 1,
280             WEBDYNE_ERROR_EVAL_LINE_NO_IX => 2,
281              
282              
283             # Alternate error message if WEBDYNE_ERROR_SHOW disabled
284             #
285             WEBDYNE_ERROR_SHOW_ALTERNATE =>
286             'error display disabled - enable WEBDYNE_ERROR_SHOW to show errors, or review web server error log.',
287              
288              
289             # Development mode - recompile loaded modules
290             #
291             WEBDYNE_RELOAD => 0,
292              
293              
294             # Mod_perl level. Do not change unless you know what you are
295             # doing.
296             #
297             MP2 => $MP2,
298             MOD_PERL => $Mod_perl_version
299              
300              
301             );
302              
303              
304             sub local_constant_load {
305              
306 4     4 0 11 my ($class, $constant_hr)=@_;
307 4         6 0 && debug("class $class, constant_hr %s", Dumper($constant_hr));
308 4         12 my $local_constant_cn=local_constant_cn();
309 4         17 0 && debug("local_constant_cn $local_constant_cn");
310 4   33     74 my $local_hr=(-f $local_constant_cn) && (
311             do($local_constant_cn)
312             ||
313             warn "unable to read local constant file, $!"
314             );
315 4         8 0 && debug("local_hr $local_hr");
316 4 50       11 if (my $hr=$local_hr->{$class}) {
317 0         0 0 && debug("found class $class hr %s", Dumper($hr));
318 0         0 while (my ($key, $val)=each %{$hr}) {
  0         0  
319 0         0 $constant_hr->{$key}=$val;
320             }
321             }
322              
323              
324             # Set via environment vars first
325             #
326 4         6 foreach my $key (keys %{$constant_hr}) {
  4         22  
327 122 50       184 if (my $val=$ENV{$key}) {
328 0         0 0 && debug("using environment value $val for key: $key");
329 0         0 $constant_hr->{$key}=$val;
330             }
331             }
332              
333              
334             # Then command line
335             #
336             #GetOptions($constant_hr, map { "$_=s" } keys %{$constant_hr});
337              
338              
339             # Load up Apache config - only if running under mod_perl
340             #
341 4 50       11 if ($Mod_perl_version) {
342              
343              
344             # Ignore die's for the moment so don't get caught by error handler
345             #
346 0         0 0 && debug("detected mod_perl version $Mod_perl_version - loading Apache directives");
347 0         0 local $SIG{'__DIE__'}=undef;
348 0         0 my $server_or;
349 0         0 eval {
350             # Modern mod_perl 2
351 0         0 require Apache2::ServerUtil;
352 0         0 require APR::Table;
353 0         0 $server_or=Apache2::ServerUtil->server();
354             };
355 0 0       0 $@ && eval {
356              
357             # Interim mod_perl 1.99x
358 0         0 require Apache::ServerUtil;
359 0         0 require APR::Table;
360 0         0 $server_or=Apache::ServerUtil->server();
361             };
362 0 0       0 $@ && eval {
363              
364             # mod_perl 1x ?
365 0         0 require Apache::Table;
366 0         0 $server_or=Apache->server();
367             };
368              
369             # Clear any eval errors, set via dir_config now (overrides env)
370             #
371 0 0       0 $@ && do {
372 0         0 eval {undef}; errclr()
  0         0  
  0         0  
373             };
374 0         0 0 && debug("loaded server_or: $server_or");
375 0 0       0 if ($server_or) {
376 0         0 my $table_or=$server_or->dir_config();
377 0         0 while (my ($key, $val)=each %{$table_or}) {
  0         0  
378 0         0 0 && debug("installing value $val for Apache directive: $key");
379 0 0       0 $constant_hr->{$key}=$val if exists $constant_hr->{$key};
380             }
381             }
382             }
383              
384              
385             # Is charset defined ? If so combine into content-type header
386             #
387 4 100       12 if (my $charset=$constant_hr->{'WEBDYNE_CHARSET'}) {
388             $constant_hr->{'WEBDYNE_CONTENT_TYPE_HTML'}=sprintf("%s; charset=$charset", $constant_hr->{'WEBDYNE_CONTENT_TYPE_HTML'})
389 2 50       18 unless $constant_hr->{'WEBDYNE_CONTENT_TYPE_HTML'}=~/charset=/;
390             $constant_hr->{'WEBDYNE_CONTENT_TYPE_PLAIN'}=sprintf("%s; charset=$charset", $constant_hr->{'WEBDYNE_CONTENT_TYPE_PLAIN'})
391 2 50       10 unless $constant_hr->{'WEBDYNE_CONTENT_TYPE_PLAIN'}=~/charset=/;
392             }
393              
394              
395             # Done - return constant hash ref
396             #
397 4         11 $constant_hr;
398              
399             }
400              
401              
402             sub local_constant_cn {
403              
404              
405             # Where local constants reside
406             #
407 4     4 0 6 my $local_constant_fn='webdyne.pm';
408 4         5 my $local_constant_cn;
409 4 50       14 if ($^O=~/MSWin[32|64]/) {
410 0   0     0 my $dn=$ENV{'WEBDYNE_HOME'} || $ENV{'WEBDYNE'} || $ENV{'WINDIR'};
411 0         0 $local_constant_cn=
412             File::Spec->catfile($dn, $local_constant_fn)
413             }
414             else {
415 4         64 $local_constant_cn=File::Spec->catfile(
416             File::Spec->rootdir(), 'etc', $local_constant_fn
417             )
418             }
419 4         12 return $local_constant_cn;
420              
421             }
422              
423              
424             sub cache_dn {
425              
426              
427             # Where the cache directory should be located
428             #
429 2     2 0 2 my $cache_dn;
430 2 50       7 if ($ENV{'PAR_TEMP'}) {
431 0         0 $cache_dn=$ENV{'PAR_TEMP'}
432             }
433              
434              
435             # Used to set like this - now leave the installer to
436             # find and set an appropriate location
437             #
438             #else {
439             #require File::Temp;
440             #$cache_dn=&File::Temp::tempdir( CLEANUP=> 1 );
441             #}
442             #elsif ($prefix) {
443             # $cache_dn=File::Spec->catdir($prefix, 'cache');
444             #}
445             #elsif ($^O=~/MSWin[32|64]/) {
446             # $cache_dn=File::Spec->catdir($ENV{'SYSTEMROOT'}, qw(TEMP webdyne))
447             #}
448             #else {
449             # $cache_dn=File::Spec->catdir(
450             # File::Spec->rootdir(), qw(var cache webdyne));
451             #}
452 2         53 return $cache_dn
453              
454             }
455              
456              
457             sub hashref {
458              
459 0     0 0   my $class=shift();
460 0           return \%{"${class}::Constant"};
  0            
461              
462             }
463              
464              
465             # Export constants to namespace, place in export tags
466             #
467             require Exporter;
468             @ISA=qw(Exporter);
469             &local_constant_load(__PACKAGE__, \%Constant);
470             foreach (keys %Constant) {${$_}=$Constant{$_}}
471             @EXPORT=map {'$' . $_} keys %Constant;
472             @EXPORT_OK=@EXPORT;
473             %EXPORT_TAGS=(all => [@EXPORT_OK]);
474             $_=\%Constant;