File Coverage

web/cgi-bin/yatt.lib/YATT/Toplevel/CGI.pm
Criterion Covered Total %
statement 109 453 24.0
branch 15 206 7.2
condition 10 86 11.6
subroutine 29 84 34.5
pod 0 55 0.0
total 163 884 18.4


line stmt bran cond sub pod time code
1             # -*- mode: perl; coding: utf-8 -*-
2             package YATT::Toplevel::CGI;
3 2     2   6800 use strict;
  2         3  
  2         71  
4 2     2   8 use warnings FATAL => qw(all);
  2         3  
  2         135  
5              
6             BEGIN {
7 2     2   7 require Exporter; *import = \&Exporter::import;
  2         4  
8 2         28 $INC{'YATT/Toplevel/CGI.pm'} = __FILE__;
9             }
10              
11 2     2   6 use base qw(File::Spec);
  2         2  
  2         165  
12 2     2   8 use File::Basename;
  2         3  
  2         124  
13 2     2   13 use Carp;
  2         2  
  2         83  
14 2     2   452 use UNIVERSAL;
  2         11  
  2         10  
15              
16             #----------------------------------------
17 2     2   42 use YATT;
  2         3  
  2         9  
18 2         17 use YATT::Types -alias => [MY => __PACKAGE__
19 2     2   47 , Translator => 'YATT::Translator::Perl'];
  2         3  
20              
21             require YATT::Inc;
22 2     2   8 use YATT::Util;
  2         2  
  2         233  
23 2     2   6 use YATT::Util::Finalizer;
  2         4  
  2         78  
24 2     2   14 use YATT::Util::Taint qw(untaint_any);
  2         3  
  2         84  
25 2     2   8 use YATT::Util::Symbol;
  2         2  
  2         191  
26 2     2   325 use YATT::Util::CmdLine;
  2         2  
  2         74  
27              
28 2     2   279 use YATT::Exception;
  2         3  
  2         85  
29              
30             #----------------------------------------
31 2     2   8 use base qw(YATT::Class::Configurable);
  2         2  
  2         165  
32 2         21 use YATT::Types -base => __PACKAGE__
33             , [Config => [qw(^cf_registry
34             cf_driver
35             cf_docs cf_tmpl
36             cf_charset
37             cf_language
38             cf_debug_allowed_ip
39             cf_translator_param
40             cf_user_config
41             cf_no_header
42             cf_allow_unknown_config
43             cf_auto_reload
44             cf_no_chdir
45             cf_rlimit
46             cf_use_session
47             )
48             , ['^cf_app_prefix' => 'YATT']
49             , ['^cf_find_root_upward' => 2]
50             ]]
51 2     2   8 , qw(:export_alias);
  2         3  
52              
53             Config->define(create => \&create_toplevel);
54              
55             #----------------------------------------
56              
57 2         5 use vars map {'$'.$_} our @env_vars
  16         7698  
58             = qw(DOCUMENT_ROOT
59             PATH_INFO
60             PATH_TRANSLATED
61             REDIRECT_REDIRECT_STATUS
62             REDIRECT_STATUS
63             REDIRECT_URL
64             REQUEST_URI
65             SCRIPT_FILENAME
66 2     2   10 );
  2         2  
67             push our @EXPORT, (qw(&use_env_vars
68             &rootname
69             &capture
70             &new_config
71             ), map {'*'.$_} our @env_vars);
72              
73             our Config $CONFIG;
74             our ($CGI, $SESSION, %COOKIE, %HEADER, $RANDOM_LIST, $RANDOM_INDEX);
75 4     4 0 12 sub rc_global () { qw(CONFIG CGI SESSION HEADER COOKIE
76             RANDOM_LIST RANDOM_INDEX) }
77             push our @EXPORT_OK, (@EXPORT, map {'*'.$_} rc_global);
78              
79             sub ROOT_CONFIG () {'.htyattroot'}
80              
81             #----------------------------------------
82             # run -> run_zzz -> dispatch(handler) -> dispatch_zzz(handler) -> handler
83              
84             # run は環境変数を整えるためのエントリー関数。
85              
86             sub run {
87 0     0 0 0 my ($pack, $method) = splice @_, 0, 2;
88 0         0 use_env_vars();
89 0 0       0 my $sub = $pack->can("run_$method")
90             or croak "Can't find handler for $method";
91              
92 0         0 &YATT::break_run;
93 0         0 $sub->($pack, @_);
94             }
95              
96             sub run_cgi {
97 0     0 0 0 my $pack = shift;
98 0         0 my $cgi = $pack->new_cgi(shift);
99              
100 0         0 local $CONFIG = my Config $config = $pack->new_config(shift);
101              
102 0         0 my ($root, $file, $error, $param);
103 0 0       0 if (catch {
104 0     0   0 ($pack, $root, $cgi, $file, $param)
105             = $pack->prepare_dispatch($cgi, $config);
106             } \ $error) {
107 0         0 $pack->dispatch_error($root, $error
108             , {phase => 'prepare', target => $file});
109             } else {
110 0         0 $pack->run_retry_max(3, $root, $file, $cgi, $param);
111             }
112             }
113              
114             sub run_retry_max {
115 0     0 0 0 my ($pack, $max, $root_or_config, $file, $cgi, @param) = @_;
116 0         0 my $root = do {
117 0 0       0 if (UNIVERSAL::isa($root_or_config, Config)) {
118 0         0 my Config $config = $root_or_config;
119 0         0 $config->{cf_registry}
120             } else {
121 0         0 $root_or_config;
122             }
123             };
124             my $rc = catch {
125 0     0   0 $pack->dispatch($root, $cgi, $file, @param);
126 0         0 } \ my $error;
127 0 0       0 if ($rc) {
128 0         0 my ($i) = (0);
129 0   0     0 while ($rc and ($file, $cgi) = can_retry($error)) {
130 0 0       0 if ($i++ > $max) {
131 0         0 $pack->dispatch_error($root, $error
132             , {phase => 'retry', target => $file});
133 0         0 undef $error;
134 0         0 last;
135             }
136             $rc = catch {
137 0     0   0 $pack->dispatch($root, $cgi, $file);
138 0         0 } \ $error;
139             }
140             }
141 0 0 0     0 if ($rc and not is_normal_end($error)) {
142 0         0 $pack->dispatch_error($root, $error
143             , {phase => 'action', target => $file});
144             }
145             }
146              
147             sub create_toplevel {
148 1     1 0 10 my $pack = shift;
149 1         2 my Config $config = $pack->new_config(shift);
150 1 50       5 $config->configure(@_) if @_;
151 1   50     2 my $dir = $config->{cf_docs} ||= '.';
152 1         8 $pack->can('try_load_config')->($config, $dir);
153 1         3 my $instpkg = $pack->get_instpkg($config);
154              
155 1         2 my @loader = (DIR => $config->{cf_docs});
156 1 50       3 push @loader, LIB => $config->{cf_tmpl} if $config->{cf_tmpl};
157              
158 1         2 my $trans = $config->{cf_registry} = $instpkg->new_translator
159             (\@loader, $config->translator_param);
160              
161 1         6 ($instpkg, $trans, $config);
162             }
163              
164             #
165             # XXX: should be: create_toplevel_from_cgi($cgi, $config)
166             # => ($instpkg, $trans, $config, $cgi, $file, $param);
167             # since $config->{cf_registry} points $translator.
168             #
169             sub prepare_dispatch {
170 0     0 0 0 (my ($pack, $cgi), my Config $config) = @_;
171 0         0 my ($rootdir, $file, $loader, $param) = do {
172 0 0 0     0 if (not $config->{cf_registry} and $config->{cf_docs}) {
    0 0        
    0          
173             # $config->try_load_config($config->{cf_docs});
174 0         0 ($config->{cf_docs}, $cgi->path_info
175             , [DIR => $config->{cf_docs}]);
176             } elsif ($REDIRECT_STATUS) {
177             # 404 Not found handling
178 0   0     0 my $target = $PATH_TRANSLATED || $DOCUMENT_ROOT . $REDIRECT_URL;
179             # This ensures .htyattroot is loaded.
180 0   0     0 ($pack->param_for_redirect($target
181             , $SCRIPT_FILENAME || $0, $config
182             , $REDIRECT_STATUS == 404
183             ));
184             } elsif ($PATH_INFO and $SCRIPT_FILENAME) {
185 0         0 (untaint_any(dirname($SCRIPT_FILENAME))
186             , untaint_any($PATH_INFO)
187             , $pack->loader_for_script($SCRIPT_FILENAME, $config));
188             } else {
189 0         0 $pack->plain_error($cgi, <
190             None of PATH_TRANSLATED and PATH_INFO is given.
191             END
192             }
193             };
194              
195 0 0       0 unless ($loader) {
196 0         0 $pack->plain_error($cgi, <
197             Can't find loader.
198             END
199             }
200              
201 0 0       0 unless (chdir($rootdir)) {
202 0         0 $pack->plain_error($cgi, "Can't chdir to $rootdir: $!");
203             }
204              
205 0 0       0 unless ($PATH_INFO) {
206 0 0       0 if ($PATH_TRANSLATED) {
207             # XXX: ミス時に効率悪い。substr して eq に書き直すべき。
208 0 0       0 if (index($PATH_TRANSLATED, $rootdir) == 0) {
209 0         0 $PATH_INFO = substr($PATH_TRANSLATED, length($rootdir));
210             }
211             }
212             }
213              
214 0 0       0 if (my $sub = $cgi->can('charset')) {
215             # print "\n\n", YATT::Util::terse_dump(CONFIG => $config);
216 0   0     0 $sub->($cgi, $config->{cf_charset} || 'utf-8');
217             }
218              
219 0         0 my $instpkg = $pack->get_instpkg($config);
220              
221 0   0     0 my $root = $config->{cf_registry} ||= $instpkg->new_translator
222             ($loader, $config->translator_param
223             , debug_translator => $ENV{DEBUG});
224              
225 0         0 $instpkg->set_random_list;
226              
227 0         0 $instpkg->force_parameter_convention($cgi); # XXX: unless $config->{...}
228              
229 0         0 ($instpkg, $root, $cgi, $file, $param);
230             }
231              
232             our $PARAM_CONVENTION = qr{^[\w:\-]};
233              
234             sub force_parameter_convention {
235 1     1 0 2786 my ($pack, $cgi) = @_;
236 1         1 my @deleted;
237 1         3 foreach my $name ($cgi->param) {
238 1 50       15 next if $name =~ $PARAM_CONVENTION;
239 1         7 push @deleted, [$name => $cgi->multi_param($name)];
240 0         0 $cgi->delete($name);
241             }
242 0         0 @deleted;
243             }
244              
245             *get_instpkg = \&prepare_export;
246             sub prepare_export {
247 1     1 0 1 my ($pack, $config, $instpkg) = @_;
248 1   50     5 $instpkg ||= $config && $config->app_prefix || 'main';
      33        
249              
250 1         4 $pack->add_isa($instpkg, $pack);
251 1         3 foreach my $name ($pack->rc_global) {
252 7         5 *{globref($instpkg, $name)} = *{globref(MY, $name)};
  7         11  
  7         10  
253             }
254             $instpkg
255 1         3 }
256              
257             sub run_template {
258 0     0 0 0 my ($pack, $file, $cgi, $config) = @_;
259              
260 0 0 0     0 if (defined $file and -r $file) {
261 0         0 ($PATH_INFO, $REDIRECT_STATUS, $PATH_TRANSLATED) = ('', 200, $file);
262 0 0       0 die "really?" unless $ENV{REDIRECT_STATUS} == 200;
263 0 0       0 die "really?" unless $ENV{PATH_TRANSLATED} eq $file;
264             }
265              
266 0         0 $pack->run_cgi($cgi, $config);
267             }
268              
269             #========================================
270             # *: dispatch_zzz が無事に最後まで処理を終えた場合は bye を呼ぶ。
271             # *: dispatch_zzz の中では catch はしない。dispatch の外側(run)で catch する。
272              
273             sub bye {
274 0   0 0 0 0 die shift->Exception->new(error => '', normal => shift || 1
275             , caller => [caller], @_);
276             }
277              
278             sub raise_retry {
279 0     0 0 0 my ($pack, $file, $cgi, @param) = @_;
280 0         0 die $pack->Exception->new(error => '', retry => [$file, $cgi, @param]
281             , caller => [caller])
282             }
283              
284             sub dispatch {
285 0     0 0 0 my ($top, $root, $cgi, $file, @param) = @_;
286 0         0 &YATT::break_dispatch;
287              
288 0         0 $root->mark_load_failure;
289              
290 0         0 local $CGI = $cgi;
291 0         0 local ($SESSION, %COOKIE, %HEADER);
292 0 0       0 if ($CONFIG->{cf_use_session}) {
293 0         0 $SESSION = $top->new_session($cgi);
294             }
295 0         0 my @elpath = $root->parse_elempath($top->canonicalize_html_filename($file));
296 0         0 my ($found, $renderer, $pkg, $widget);
297              
298 0 0       0 if (catch {
    0          
    0          
299 0     0   0 $found = ($renderer, $pkg, $widget)
300             = $root->lookup_handler_to(render => @elpath);
301             } \ my $error) {
302 0         0 $top->dispatch_error($root, $error
303             , {phase => 'get_handler', target => $file});
304             } elsif (not $found) {
305             # XXX: これも。
306 0         0 $top->dispatch_not_found($root, $file, @param);
307             } elsif (not defined $renderer) {
308 0         0 $top->dispatch_error($root, "Can't compile: $file"
309             , {phase => 'get_handler', target => $file});
310             } else {
311 0 0       0 unless ($CONFIG->{cf_no_chdir}) {
312             # XXX: これもエラー処理を
313 0         0 my $dir = untaint_any(dirname($widget->filename));
314 0         0 chdir($dir);
315             }
316 0 0 0     0 if (not defined $param[0] and $widget->public) {
317 0         0 $param[0] = $widget->reorder_cgi_params($cgi);
318             }
319 0 0       0 if (my $handler = $pkg->can('dispatch_action')) {
320 0         0 $handler->($top, $root, $renderer, $pkg, @param);
321             } else {
322 0         0 $top->dispatch_action($root, $renderer, $pkg, @param);
323             }
324             }
325             }
326              
327             sub dispatch_not_found {
328 0     0 0 0 my ($top, $root, $file) = @_;
329 0         0 my $ERR = \*STDOUT;
330              
331 0         0 print $ERR "\n\nNot found: $file";
332             }
333              
334             # XXX: もう少し改善を。
335             sub dispatch_error {
336 0     0 0 0 my ($top, $root, $error, $info) = @_;
337 0         0 my $ERR = \*STDOUT;
338 0         0 my ($found, $renderer, $pkg, $html);
339              
340 0 0       0 unless ($root) {
    0          
    0          
    0          
341 0         0 print $ERR "\n\nroot_load_error($error)";
342             } elsif (catch {
343 0     0   0 $found = ($renderer, $pkg) = $root->lookup_handler_to(render => 'error')
344             } \ my $load_error) {
345 0         0 print $ERR "\n\nload_error($load_error), original_error=($error)";
346             } elsif (not $found) {
347 0 0       0 print $ERR $CGI ? $CGI->header : "\n\n";
348 0         0 print $ERR $error;
349 0 0       0 $top->printenv_html($info, id => 'error_info') if $info;
350 0         0 $top->printenv_html;
351             } elsif (catch {
352 0     0   0 $html = capture {$renderer->($pkg, [$error, $info])};
  0         0  
353             } \ my Exception $error2) {
354 0 0       0 unless (ref $error2) {
    0          
    0          
355 0         0 print $ERR "\n\nerror in error page($error2), original_error=($error)";
356             } elsif (not UNIVERSAL::isa($error2, Exception)) {
357 0         0 print $ERR "\n\nUnknown error in error page($error2), original_error=($error)";
358             } elsif ($error2->is_normal) {
359             # should be ignored
360             } else {
361 0         0 print $ERR "\n\nerror in error page($error2->{cf_error}), original_error=($error)";
362             }
363             } else {
364 0 0       0 print $ERR $CGI ? $CGI->header : "Content-type: text/html\n\n";
365 0         0 print $ERR $html;
366             }
367              
368 0         0 $top->bye;
369             }
370              
371             sub dispatch_action {
372 0     0 0 0 my ($top, $root, $action, $pkg, @param) = @_;
373 0         0 &YATT::break_handler;
374 0 0 0     0 if ($CONFIG && $CONFIG->{cf_no_header}) {
375 0         0 $action->($pkg, @param);
376             } else {
377 0     0   0 my $html = capture { $action->($pkg, @param) };
  0         0  
378             # XXX: SESSION, COOKIE, HEADER...
379 0 0       0 print $SESSION ? $SESSION->header : $CGI->header;
380 0         0 print $html;
381             }
382 0         0 $top->bye;
383             }
384              
385             sub plain_error {
386 0     0 0 0 my ($pack, $cgi, $message) = @_;
387 0 0       0 print $cgi->header if $cgi;
388 0         0 print $message;
389 0         0 $pack->printenv_html;
390 0 0       0 $pack->plain_exit($cgi ? 0 : 1);
391             }
392              
393             sub plain_exit {
394 0     0 0 0 my ($pack, $exit_code) = @_;
395 0         0 exit $exit_code;
396             }
397              
398             sub printenv_html {
399 0     0 0 0 my ($pack, $env, %opts) = @_;
400 0   0     0 $opts{id} ||= 'printenv';
401 0         0 my $ERR = \*STDOUT;
402 0   0     0 $env ||= \%ENV;
403 0         0 print $ERR "\n"; \n";
404 0         0 foreach my $k (sort keys %$env) {
405 0         0 print $ERR "
", $k, "", $env->{$k}, "
406             }
407 0         0 print $ERR "
\n";
408             }
409              
410             #========================================
411              
412             sub loader_for_script {
413 0     0 0 0 my ($pack, $script_filename) = @_;
414 0         0 my $driver = untaint_any(rootname($script_filename));
415 0         0 my @loader = (DIR => untaint_any("$driver.docs")
416             , $pack->tmpl_for_driver($driver));
417 0         0 \@loader;
418             }
419              
420             sub tmpl_for_driver {
421 0     0 0 0 my ($pack, $rootname) = @_;
422 0 0       0 return unless -d (my $dir = "$rootname.tmpl");
423 0         0 (LIB => $dir);
424             }
425              
426             sub upward_find_file {
427 0     0 0 0 my ($pack, $file, $level) = @_;
428 0         0 my @path = $pack->splitdir($pack->rel2abs($file));
429 0 0       0 my $limit = defined $level ? @path - $level : 0;
430 0         0 my ($dir);
431 0         0 for (my $i = $#path - 1; $i >= $limit; $i--) {
432 0         0 $dir = join "/", @path[0..$i];
433 0         0 $file = "$dir/" . $pack->ROOT_CONFIG;
434 0 0       0 next unless -r $file;
435 0 0       0 return wantarray ? ($dir, $file) : $file;
436             }
437              
438             return
439 0         0 }
440              
441             sub try_load_config {
442 1     1 0 1 (my Config $config, my ($file)) = @_;
443              
444 1         1 my $dir;
445 1 50 33     78 unless (defined $file and -r $file) {
    50 33        
    50          
    50          
    50          
446 0 0       0 die "No such file or directory! "
447             . (defined $file ? $file : "(undef)") . "\n";
448             } elsif (-f $file) {
449             # ok
450 0         0 $file = $config->rel2abs($file);
451 0         0 $dir = dirname($file);
452             } elsif (! -d $file) {
453 0         0 die "Unsupported file type! $file";
454             } elsif (-r (my $found = "$file/" . $config->ROOT_CONFIG)) {
455 0         0 ($dir, $file) = ($file, $found);
456             } elsif ($config->find_root_upward
457             and my @found = $config->upward_find_file
458             ($file, $config->find_root_upward)) {
459 0         0 ($dir, $file) = @found;
460             } else {
461 1         2 $dir = $file;
462             }
463              
464 1         6 $config->configure(docs => $dir);
465              
466 1 50 33     13 return unless -f $file and -r $file;
467              
468             # XXX: configure_by_file
469 0         0 my @param = do {
470 0         0 require YATT::XHF;
471 0         0 my $parser = new YATT::XHF(filename => $file);
472 0         0 $parser->read_as('pairlist');
473             };
474 0         0 $config->heavy_configure(@param);
475             }
476              
477             sub trim_trailing_pathinfo {
478 0     0 0 0 my ($pack, $strref, @prefix) = @_;
479 0 0       0 @prefix = ('') unless @prefix;
480 0         0 my @dirs = $pack->splitdir($$strref);
481 0         0 my @found;
482 0   0     0 while (@dirs and -e join("/", @prefix, @found, $dirs[0])) {
483 0         0 push @found, shift @dirs;
484             }
485 0         0 $$strref = join("/", @found);
486 0 0       0 return unless @dirs;
487 0         0 join("/", @dirs);
488             }
489              
490             sub param_for_redirect {
491 0     0 0 0 (my ($pack, $path_translated, $script_filename)
492             , my Config $cfobj, my $not_found) = @_;
493 0         0 my $driver = untaint_any(rootname($script_filename));
494              
495 0         0 my @params;
496 0 0 0     0 if (not $not_found and not -e $path_translated) {
497             # not_found でもないのに、 path_translated が not exists であるケース
498             # == trailing path_info が有るケース。
499 0         0 push @params, $pack->trim_trailing_pathinfo(\$path_translated);
500             }
501              
502             # This should set $cfobj->{cf_docs}
503 0 0       0 unless ($cfobj->{cf_registry}) {
504             # .htyattroot の読み込みは、registry 作成前の一度で十分。
505 0         0 $cfobj->try_load_config(dirname(untaint_any($path_translated)));
506             }
507              
508 0         0 my $target = substr($path_translated
509             , length($cfobj->{cf_docs}));
510              
511 0         0 my @loader = (DIR => $cfobj->{cf_docs}
512             , $pack->tmpl_for_driver($driver));
513              
514 0 0       0 return ($cfobj->{cf_docs}, $target, \@loader, @params ? \@params : ());
515             }
516              
517             #========================================
518              
519 0     0 0 0 sub cgi_classes () { qw(CGI::Simple CGI) }
520              
521             sub new_cgi {
522 0     0 0 0 my ($pack, $oldcgi) = @_;
523 0         0 my $class;
524 0         0 foreach my $c ($pack->cgi_classes) {
525 0         0 eval qq{require $c};
526 0 0       0 unless ($@) {
527 0         0 $class = $c;
528 0         0 last;
529             }
530             }
531 0 0       0 unless ($class) {
532 0         0 die "Can't load any of cgi classes";
533             }
534              
535 0 0 0     0 if ($class eq "CGI" and not $class->can("multi_param")) {
536 0         0 require YATT::Util::CGICompat;
537 0         0 import YATT::Util::CGICompat;
538             }
539              
540             # 1. To make sure passing 'public' parameters only.
541             # 2. To avoid CGI::Simple eval()
542 0 0       0 if (UNIVERSAL::isa($oldcgi, $class)) {
543 0         0 $class->new($pack->extract_cgi_params($oldcgi));
544             } else {
545 0 0       0 $class->new(defined $oldcgi ? $oldcgi : ());
546             }
547             }
548              
549             sub new_session {
550 0     0 0 0 my ($toplevel, $cgi) = @_;
551 0         0 require CGI::Session;
552 0         0 my ($dsn, @opts) = do {
553 0 0       0 if (ref $CONFIG->{cf_use_session}) {
554 0         0 @{$CONFIG->{cf_use_session}}
  0         0  
555             } else {
556 0         0 $CONFIG->{cf_use_session}
557             }
558             };
559 0         0 CGI::Session->new($dsn, $cgi, @opts);
560             }
561              
562             sub entity_session {
563 0     0 0 0 my ($pack, $name) = @_;
564 0         0 $SESSION->param($name);
565             }
566              
567             sub entity_save_session {
568 0     0 0 0 $SESSION->save_param;
569             }
570              
571             sub new_config {
572 1     1 0 1 my $pack = shift;
573 1 50       3 my Config $config = @_ == 1 ? shift : \@_;
574 1 50 33     11 return $config if defined $config
      33        
575             and ref $config and UNIVERSAL::isa($config, Config);
576              
577 1 50 33     9 if (ref $pack or not UNIVERSAL::isa($pack, Config)) {
578 1         2 $pack = $pack->Config;
579             }
580              
581 1         2 $config = $pack->new(do {
582 1 50       3 unless (defined $config) {
    50          
    0          
    0          
583             ()
584 0         0 } elsif (not ref $config) {
585 1         9 (docs => $config)
586             } elsif (ref $config eq 'ARRAY') {
587 0         0 @$config
588             } elsif (ref $config eq 'HASH') {
589 0         0 %$config
590             } else {
591 0         0 $pack->plain_error(undef, <
592             Invalid configuration parameter: $config
593             END
594             }
595             });
596              
597 1         2 $config->{cf_driver} = $0;
598              
599 1         5 $config;
600             }
601              
602             sub heavy_configure {
603 0     0 0 0 my Config $config = shift;
604 0         0 my $config_keys = $config->fields_hash;
605 0         0 my $trans_keys = $config->load_type('Translator')->fields_hash_of_class;
606 0         0 my (@mine, @trans, @unknown);
607 0         0 while (my ($name, $value) = splice @_, 0, 2) {
608 0         0 my $mine = $config_keys->{"cf_$name"};
609 0 0       0 if ($mine) {
610 0         0 push @mine, $name, $value;
611             }
612 0 0       0 if ($trans_keys->{"cf_$name"}) {
    0          
613 0         0 push @trans, [$name, $value];
614             } elsif (not $mine) {
615 0         0 push @unknown, [$name, $value];
616             }
617             }
618 0 0       0 $config->configure(@mine) if @mine;
619 0         0 foreach my $name ($config->configkeys) {
620 0 0 0     0 if ($trans_keys->{"cf_$name"}
621             and defined (my $value = $config->{"cf_$name"})) {
622 0         0 push @trans, [$name, $value];
623             }
624             }
625 0         0 $config->{cf_translator_param}{$_->[0]} = $_->[1] for @trans;
626 0 0       0 if (@unknown) {
627 0 0       0 unless ($config->{cf_allow_unknown_config}) {
628 0         0 croak "Unknown config opts: "
629 0         0 . join(", ", map {join("=", @$_)} @unknown);
630             }
631 0         0 $config->{cf_user_config}{$_->[0]} = $_->[1] for @unknown;
632             }
633 0         0 $config;
634             }
635              
636             sub configure_rlimit {
637 0     0 0 0 (my Config $config, my $rlimit_hash) = @_;
638 0         0 my $class = 'YATT::Util::RLimit';
639 0 0       0 eval qq{require $class} or die $@;
640 0         0 while (my ($rsrc, $limit) = each %$rlimit_hash) {
641 0 0       0 if (my $sub = $class->can("rlimit_" . $rsrc)) {
642 0         0 $sub->($limit);
643             } else {
644 0         0 $class->can('rlimit')->("RLIMIT_" . uc($rsrc), $limit);
645             }
646             }
647             }
648              
649             sub extract_cgi_params {
650 0     0 0 0 my ($pack, $cgi) = @_;
651 0         0 my %param;
652 0         0 foreach my $name ($cgi->param) {
653 0         0 my @value = $cgi->param($name);
654 0 0       0 if (@value > 1) {
655 0         0 $param{$name} = \@value;
656             } else {
657 0         0 $param{$name} = $value[0];
658             }
659             }
660 0         0 \%param
661             }
662              
663             sub new_translator {
664 1     1 0 8 my ($self, $loader) = splice @_, 0, 2;
665 1   33     8 my $pack = ref $self || $self;
666 1         5 $pack->call_type(Translator => new =>
667             app_prefix => $pack
668             , default_base_class => $pack
669             , rc_global => [$pack->rc_global]
670             , loader => $loader, @_);
671             }
672              
673             sub use_env_vars {
674 0     0 0 0 my ($env) = @_;
675 0 0       0 $env = \%ENV unless defined $env;
676 0         0 foreach my $vn (our @env_vars) {
677 0         0 *{globref(MY, $vn)} = do {
  0         0  
678 0 0       0 $env->{$vn} = '' unless defined $env->{$vn};
679 0         0 \ $env->{$vn};
680             };
681             }
682 0   0     0 $SCRIPT_FILENAME ||= $0;
683             }
684              
685             #========================================
686              
687             sub set_random_list {
688 0     0 0 0 my ($this, $random) = @_;
689 0 0       0 if (defined $random) {
690 0 0       0 $RANDOM_LIST = ref $random ? $random : [split " ", $random];
691 0         0 $RANDOM_INDEX = 0;
692             } else {
693 0         0 undef $RANDOM_LIST;
694 0         0 undef $RANDOM_INDEX;
695             }
696             }
697              
698             sub entity_rand {
699 0     0 0 0 my ($this, $scalar) = @_;
700 0   0     0 $scalar ||= 1;
701 0 0       0 if ($RANDOM_LIST) {
702 0         0 my $val = $RANDOM_LIST->[$RANDOM_INDEX++ % @$RANDOM_LIST];
703 0         0 $val * $scalar;
704             } else {
705 0         0 rand $scalar;
706             }
707             }
708              
709             sub entity_randomize {
710 0     0 0 0 my ($this) = shift;
711 0         0 my $sub = $this->can('entity_rand');
712 0         0 my @result;
713 0         0 push @result, splice @_, $sub->($this, scalar @_), 1 while @_;
714 0 0       0 wantarray ? @result : \@result;
715             }
716              
717             sub entity_breakpoint {
718 0     0 0 0 &YATT::breakpoint();
719             }
720              
721             sub entity_concat {
722 0     0 0 0 my $this = shift;
723 0         0 join '', @_;
724             }
725              
726             sub entity_join {
727 0     0 0 0 my ($this, $sep) = splice @_, 0, 2;
728 0 0       0 join $sep, grep {defined $_ && $_ ne ''} @_;
  0         0  
729             }
730              
731             sub entity_format {
732 0     0 0 0 my ($this, $format) = (shift, shift);
733 0         0 sprintf $format, @_;
734             }
735              
736             sub entity_is_debug_allowed {
737 0     0 0 0 my ($this) = @_;
738 0 0       0 unless (defined $CGI->{'.allow_debug'}) {
739 0         0 $CGI->{'.allow_debug'} = $this->is_debug_allowed($CGI->remote_addr);
740             }
741 0         0 $CGI->{'.allow_debug'};
742             }
743              
744             sub is_debug_allowed {
745 0     0 0 0 my ($this, $ip) = @_;
746 0         0 my $pat = $$CONFIG{cf_debug_allowed_ip};
747 0 0       0 unless (defined $pat) {
    0          
    0          
748 0         0 $pat = $$CONFIG{cf_debug_allowed_ip} = $this->load_htdebug;
749             } elsif (ref $pat) {
750 0         0 $pat = $$CONFIG{cf_debug_allowed_ip} = qr{@{[join "|", map {"^$_"} @$pat]}};
  0         0  
  0         0  
751             } elsif ($pat eq '') {
752 0         0 return 0
753             }
754 0         0 $ip =~ $pat;
755             }
756              
757             sub load_htdebug {
758 0     0 0 0 my ($this) = @_;
759 0         0 my $dir = untaint_any(dirname($CONFIG->{cf_driver}));
760 0         0 my $fn = "$dir/.htdebug";
761 0 0       0 return '' unless -r $fn;
762 0 0       0 open my $fh, '<', $fn or die "Can't open $fn: $!";
763 0         0 local $_;
764 0         0 my @pat;
765 0         0 while (<$fh>) {
766 0         0 chomp;
767 0         0 s/\#.*//;
768 0 0       0 next unless /\S/;
769 0         0 push @pat, '^'.quotemeta($_);
770             }
771 0         0 qr{@{[join "|", @pat]}};
  0         0  
772             }
773              
774 0     0 0 0 sub entity_CGI { $CGI }
775              
776             sub entity_remote_addr {
777 0     0 0 0 $CGI->remote_addr
778             }
779              
780             #========================================
781              
782             sub entity_param {
783 0     0 0 0 my ($this) = shift;
784 0         0 $CGI->param(@_);
785             }
786              
787             #
788             # For &HTML(); shortcut.
789             # To use this, special_entities should have 'HTML'.
790             #
791             sub entity_HTML {
792 0     0 0 0 my $this = shift;
793 0         0 \ join "", grep {defined $_} @_;
  0         0  
794             }
795              
796             sub entity_dump {
797 0     0 0 0 shift;
798 0         0 YATT::Util::terse_dump(@_);
799             }
800              
801             #========================================
802              
803             sub canonicalize_html_filename {
804 0     0 0 0 my $pack = shift;
805 0 0       0 $_[0] .= "index" if $_[0] =~ m{/$};
806 0         0 my $copy = shift;
807 0         0 $copy =~ s{\.(y?html?|yatt?)$}{};
808 0         0 $copy;
809             }
810              
811             sub widget_path_in {
812 0     0 0 0 my ($pack, $rootdir, $file) = @_;
813 0 0       0 unless (index($file, $rootdir) == 0) {
814 0         0 $pack->plain_error
815             (undef, "Requested file $file is not in rootdir $rootdir");
816             }
817              
818             my @elempath
819 0         0 = split '/', $pack->canonicalize_html_filename
820             (substr($file, length($rootdir)));
821 0 0 0     0 shift @elempath if defined $elempath[0] and $elempath[0] eq '';
822              
823 0         0 @elempath;
824             }
825              
826             sub YATT::Toplevel::CGI::Config::translator_param {
827 1     1 0 1 my Config $config = shift;
828             # print "translator_param: ", terse_dump($config), "\n";
829 1 0       10 map($_ ? (ref $_ eq 'ARRAY' ? @$_ : %$_) : ()
    50          
830             , $config->{cf_translator_param})
831             }
832              
833              
834             #========================================
835 2     2   13 package YATT::Toplevel::CGI::Batch; use YATT::Inc;
  2         3  
  2         9  
836 2     2   7 use base qw(YATT::Toplevel::CGI);
  2         8  
  2         140  
837 2     2   9 use YATT::Util qw(catch);
  2         2  
  2         458  
838              
839             sub run_files {
840 0     0 0   my $pack = shift;
841 0           my ($method, $flag, @opts) = $pack->parse_opts(\@_);
842 0           my $config = $pack->new_config(\@opts);
843 0           $pack->parse_params(\@_, \ my %param);
844              
845 0           foreach my $file (@_) {
846 0 0         print "=== $file ===\n" if $ENV{VERBOSE};
847 0 0         if (catch {
848 0     0     $pack->run_template($pack->rel2abs($file), \%param, $config);
849             } \ my $error) {
850 0           print STDERR $error;
851             }
852 0 0         print "\n" if $ENV{VERBOSE};
853             }
854             }
855              
856             sub dispatch_action {
857 0     0 0   my ($top, $root, $action, $pkg, @param) = @_;
858 0           &YATT::break_handler;
859 0           $action->($pkg, @param);
860 0           $top->bye;
861             }
862              
863             1;