File Coverage

blib/lib/XAO/Web.pm
Criterion Covered Total %
statement 221 307 71.9
branch 66 136 48.5
condition 21 75 28.0
subroutine 22 27 81.4
pod 9 10 90.0
total 339 555 61.0


line stmt bran cond sub pod time code
1             package XAO::Web;
2 22     22   199180 use warnings;
  22         53  
  22         757  
3 22     22   136 use strict;
  22         60  
  22         413  
4 22     22   117 use Encode;
  22         46  
  22         1648  
5 22     22   160 use Error qw(:try);
  22         49  
  22         128  
6 22     22   3117 use XAO::Utils;
  22         47  
  22         1295  
7 22     22   2896 use XAO::Projects;
  22         7044  
  22         960  
8 22     22   2541 use XAO::Objects;
  22         18855  
  22         712  
9 22     22   10533 use XAO::SimpleHash;
  22         45255  
  22         810  
10 22     22   8846 use XAO::PageSupport;
  22         115  
  22         706  
11 22     22   9021 use XAO::Templates;
  22         64  
  22         740  
12 22     22   216 use XAO::Errors qw(XAO::Web);
  22         53  
  22         141  
13              
14             ###############################################################################
15             # XAO::Web version number. Hand changed with every release!
16             #
17 22     22   7677 use vars qw($VERSION);
  22         46  
  22         88201  
18             $VERSION='1.90';
19              
20             ###############################################################################
21              
22             =head1 NAME
23              
24             XAO::Web - XAO Web Developer, dynamic content building suite
25              
26             =head1 SYNOPSIS
27              
28             use XAO::Web;
29              
30             my $web=XAO::Web->new(sitename => 'test');
31              
32             $web->execute(cgi => $cgi,
33             path => '/index.html');
34              
35             my $config=$web->config;
36              
37             $config->clipboard->put(foo => 'bar');
38              
39             =head1 DESCRIPTION
40              
41             Please read L for general overview and setup
42             instructions, and please read L for an overview
43             of the templating system. Check also misc/samplesite for code examples
44             and a generic site setup.
45              
46             XAO::Web module provides a frameworks for loading site configuration and
47             executing objects and templates in the site context. It is used in
48             scripts and in Apache web server handler to generate actual web pages
49             content.
50              
51             Normally a developer does not need to use XAO::Web directly.
52              
53             =head1 SITE INITIALIZATION
54              
55             When XAO::Web creates a new site (for mod_perl that happens only once
56             during each instance on Apache lifetime) it first loads new 'Config'
57             object using XAO::Objects' new() method and site name it knows. If site
58             overrides Config - it loads site specific Config, if not - the systme
59             one.
60              
61             After the object is created XAO::Web embeds two standard additional
62             configuration objects into it:
63              
64             =over
65              
66             =item hash
67              
68             Hash object is primarily used to keep site configuration parameters. It
69             is just a XAO::SimpleHash object and most of its methods get embedded -
70             get, put, getref, delete, defined, exists, keys, values, contains.
71              
72             =item web
73              
74             Web configuration embeds methods that allow cookie, clipboard and
75             cgi manipulations -- add_cookie, cgi, clipboard, cookies, header,
76             header_args.
77              
78             =back
79              
80             After that XAO::Web calls init() method on the Config object which
81             is supposed to finish configuration set up and usually stuffs some
82             parameters into 'hash', then connects to a database and embeds database
83             configuration object into the Config object as well. Refer to
84             L for an example of site specific Config object and
85             init() method.
86              
87             When object initialization is completed the Config object is placed into
88             XAO::Projects registry and is retrieved from there on next access to the
89             same site in case of mod_perl.
90              
91             B that means that if you are embedding a site specific version
92             of an object during initialisation you need to pass 'sitename' into
93             XAO::Objects' new() method.
94              
95             =head1 METHODS
96              
97             Methods of XAO::Web objects include:
98              
99             =over
100              
101             =cut
102              
103             ###############################################################################
104              
105             sub analyze ($$;$$);
106             sub clipboard ($);
107             sub config ($);
108             sub execute ($%);
109             sub new ($%);
110             sub set_current ($);
111             sub sitename ($);
112              
113             ###############################################################################
114              
115             =item analyze ($;$$)
116              
117             Checks how to display the given path (scalar or split up array
118             reference). Always returns valid results or throws an error if that
119             can't be accomplished.
120              
121             Returns hash reference:
122              
123             prefix => longest matching prefix (directory in case of template found)
124             path => path to the page after the prefix
125             fullpath => full path from original query
126             objname => object name that will serve this path
127             objargs => object args hash (may be empty)
128              
129             Optional second argument can be used to enforce a specific site name.
130              
131             Optional third argument must be used to allow returning records of types
132             other than 'xaoweb'. This is used by Apache::XAO to get 'maptodir' and
133             'external' mappings. Default is to look for xaoweb only records.
134              
135             =cut
136              
137             sub analyze ($$;$$) {
138 84     84 1 187 my ($self,$patharr,$sitename,$allow_other_types)=@_;
139              
140 84 50       184 $patharr=[ split(/\/+/,$patharr) ] unless ref $patharr;
141              
142 84   66     570 shift @$patharr while @$patharr && !length($patharr->[0]);
143 84         190 unshift(@$patharr,'');
144 84         243 my $path=join('/',@$patharr);
145              
146             # Looking for the object matching the path.
147             #
148 84         167 my $siteconfig=$self->config;
149 84         1652 my $table=$siteconfig->get('path_mapping_table');
150 84 50       3683 if($table) {
151 84         235 for(my $i=@$patharr; $i>=0; $i--) {
152 248 100       504 my $dir=$i ? join('/',@{$patharr}[0..$i-1]) : '';
  167         379  
153              
154             my $od=$table->{$dir} ||
155             $table->{'/'.$dir} ||
156             $table->{$dir.'/'} ||
157 248   33     1431 $table->{'/'.$dir.'/'};
158 248 100       658 next unless defined $od;
159              
160             ##
161             # If $od is an empty string or an empty array reference --
162             # this means that we need to fall back to default handler
163             # for that path.
164             #
165             # The same happens for 'default' type in a hash reference.
166             #
167 3         11 my $rhash;
168 3 50       22 if(ref($od) eq 'HASH') {
    0          
169 3   50     17 my $type=$od->{'type'} || 'xaoweb';
170 3 50 0     13 if($type eq 'default') {
    50          
    0          
    0          
171 0         0 last;
172             }
173             elsif($type eq 'xaoweb') {
174 3 50       13 if(!$od->{'objname'}) {
175 0         0 throw XAO::E::Web "analyze - no objname/objargs for '$dir'";
176             }
177 3         17 $rhash=merge_refs($od);
178             }
179             elsif($allow_other_types) {
180 0         0 $rhash=merge_refs($od);
181             }
182             elsif($od->{'xaoweb'} && ref($od->{'xaoweb'}) eq 'HASH') {
183 0         0 $rhash=merge_refs($od->{'xaoweb'});
184             }
185             else {
186 0         0 next;
187             }
188             }
189             elsif(ref($od) eq 'ARRAY') {
190 0 0       0 last unless @$od;
191 0         0 my %args;
192 0 0       0 if(scalar(@{$od})%2 == 1) {
  0         0  
193 0         0 %args=@{$od}[1..$#{$od}];
  0         0  
  0         0  
194             }
195             else {
196 0         0 throw XAO::E::Web "analyze - odd number of arguments in the mapping table, dir=$dir, objname=$od->[0]";
197             }
198 0         0 $rhash={
199             type => 'xaoweb',
200             objname => $od->[0],
201             objargs => \%args,
202             };
203             }
204             else {
205 0 0       0 last unless length($od);
206 0         0 $rhash={
207             type => 'xaoweb',
208             objname => $od,
209             objargs => { },
210             };
211             }
212              
213 3         61 $rhash->{'path'}=join('/',@{$patharr}[$i..$#$patharr]);
  3         11  
214 3         8 $rhash->{'patharr'}=$patharr;
215 3         12 $rhash->{'prefix'}=$dir;
216 3         11 $rhash->{'fullpath'}=$path;
217              
218 3         13 return $rhash;
219             }
220             }
221              
222             ##
223             # Now looking for exactly matching template and returning Page
224             # object if found.
225             #
226 81         256 my $filename=XAO::Templates::filename($path,$sitename);
227 81 100       267 if($filename) {
228             return {
229             type => 'xaoweb',
230             subtype => 'file',
231             objname => 'Page',
232             objargs => { },
233             path => $path,
234             patharr => $patharr,
235             fullpath => $path,
236 80         234 prefix => join('/',@{$patharr}[0..($#$patharr-1)]),
  80         772  
237             filename => $filename,
238             };
239             }
240              
241             ##
242             # Nothing was found, returning Default object
243             #
244             return {
245 1         9 type => 'xaoweb',
246             subtype => 'notfound',
247             objname => 'Default',
248             path => $path,
249             patharr => $patharr,
250             fullpath => $path,
251             prefix => ''
252             };
253             }
254              
255             ###############################################################################
256              
257             =item clipboard ()
258              
259             Returns site clipboard object.
260              
261             =cut
262              
263             sub clipboard ($) {
264 0     0 1 0 my $self=shift;
265 0         0 return $self->config->clipboard;
266             }
267              
268             ###############################################################################
269              
270             =item config ()
271              
272             Returns site configuration object reference.
273              
274             =cut
275              
276             sub config ($) {
277 630     630 1 977 my $self=shift;
278 630   33     6007 return $self->{'siteconfig'} ||
279             throw XAO::E::Web "config - no configuration object";
280             }
281              
282             ###############################################################################
283              
284             =item execute (%)
285              
286             Executes given `path' using given `cgi' environment. Prints results to
287             standard output and uses CGI object methods to send header.
288              
289             B Execute() changes global projects context and is not re-entry safe
290             currently! Meaning that if you create a XAO::Web object in any method
291             called inside of execute() loop and then call execute() on that newly
292             created XAO::Web object the system will fail and no useful results will
293             be produced.
294              
295             =cut
296              
297             sub execute ($%) {
298 11     11 1 32 my $self=shift;
299 11         44 my $args=get_args(\@_);
300              
301             # Setting dprint/eprint to Apache or PSGI methods if needed
302             #
303 11         166 my $old_logprint_handler;
304 11 50       51 if($args->{'apache'}) {
    50          
305             $old_logprint_handler=XAO::Utils::set_logprint_handler(sub {
306 0     0   0 $args->{'apache'}->server->warn($_[0]);
307 0         0 });
308             }
309             elsif($args->{'psgi'}) {
310             $old_logprint_handler=XAO::Utils::set_logprint_handler(sub {
311 0     0   0 $args->{'psgi'}->{'psgi.errors'}->print($_[0]."\n");
312 0         0 });
313             }
314              
315             # Setting the current project context to our site.
316             #
317 11         31 $self->set_current();
318              
319             # We check if the site has a mapping for '/internal-error' in
320             # path_mapping_table. If it has we wrap process() into the try block
321             # and execute /internal-error if we get an error.
322             #
323 11         30 my $pagetext;
324             try {
325 11     11   366 $pagetext=$self->process($args);
326             }
327             otherwise {
328 0     0   0 my $e=shift;
329              
330             # Under mod_perl we get apache's internal exceptions for genuine apache
331             # problems (timeouts, etc). These are not re-throwable apparently,
332             # so we wrap them into Error::Simple.
333             #
334 0 0       0 if($e->isa('APR::Error')) {
335 0         0 $e=Error::Simple->new("$e");
336             }
337              
338             $self->config->header_args(
339 0         0 -Status => '500 Internal Error',
340             -expires => 'now',
341             -cache_control => 'no-cache',
342             );
343              
344 0   0     0 my $edata=$self->clipboard->get('/internal_error') || { };
345              
346 0   0     0 my $path=$edata->{'display_path'} || '/internal-error/index.html';
347 0         0 my $pd=$self->analyze($path);
348              
349 0 0 0     0 if($pd && $pd->{'type'} eq 'xaoweb' && $pd->{'objname'} ne 'Default') {
      0        
350 0         0 eprint "$e";
351              
352 0   0     0 $edata->{'message'}||="$e";
353 0   0     0 $edata->{'code'}||='UNKNOWN';
354 0   0     0 $edata->{'path'}||=$args->{'path'};
355 0   0     0 $edata->{'pagedesc'}||=$self->clipboard->get('pagedesc');
356              
357 0         0 $self->clipboard->put(internal_error => $edata);
358              
359 0         0 $pagetext=$self->process($args,{
360             path => $path,
361             template => undef,
362             pagedesc => $pd,
363             });
364             }
365             else {
366 0 0       0 XAO::Utils::set_logprint_handler($old_logprint_handler) if $old_logprint_handler;
367 0         0 throw $e;
368             }
369 11         155 };
370              
371             # We need to call "header" for CGI to do its magic on it. We
372             # typically will get an empty string in mod_perl environment, and the
373             # header will be sent to Apache by CGI.
374             #
375 11         271 my $header=$self->config->header;
376              
377             # If we get the header then it was not printed before and we are
378             # expected to print out the page. This is almost always true except
379             # when page includes something like Redirect object.
380             #
381 11         12845 my $result;
382 11 50       31 if(defined $header) {
383 11 50       57 if(my $env=$args->{'psgi'}) {
    50          
384              
385             # Can't use $header, need an array that includes header_args
386             # and cookies.
387             #
388             $result=[
389 0         0 $args->{'cgi'}->psgi_header({ $self->config->header_array() }),
390             [ $pagetext ],
391             ];
392             }
393             elsif(my $r=$args->{'apache'}) {
394 0         0 my $h=$self->config->header_args;
395              
396 0 0 0     0 if($mod_perl::VERSION && $mod_perl::VERSION >= 1.99) {
397             # This is accomplished by CGI when config->header is
398             # called above, and it does not work properly anyway
399             #
400             ### while(my ($n,$v)=each %$h) {
401             ### dprint "n='$n' v='$v'";
402             ### $r->headers_out->set($n => $v);
403             ### $r->err_headers_out->set($n => $v);
404             ### }
405 0 0       0 $r->content_type('text/html') unless $r->content_type;
406             }
407             else {
408 0         0 while(my ($n,$v)=each %$h) {
409 0         0 $r->header_out($n => $v);
410 0         0 $r->err_header_out($n => $v);
411             }
412 0         0 $r->send_http_header;
413             }
414              
415 0 0       0 $r->print($pagetext) unless $r->header_only;
416             }
417             else {
418 11         424 print $header,
419             $pagetext;
420             }
421             }
422              
423             # Cleaning up site configuration
424             #
425 11         50 $self->config->cleanup(mode => 'after');
426              
427             # Restoring the default dprint/eprint handling
428             #
429 11 50       38 XAO::Utils::set_logprint_handler($old_logprint_handler) if $old_logprint_handler;
430              
431             # Only really needed for PSGI
432             #
433 11         39 return $result;
434             }
435              
436             ###############################################################################
437              
438             =item expand (%)
439              
440             Expands given `path' using given `cgi' or 'apache' environment. Returns
441             just the text of the page in scalar context and page content plus header
442             content in array context.
443              
444             This is normally used in scripts to execute only a particular template
445             and to get results of execution. BUT this code is also used as part of
446             the normal execute().
447              
448             `Objargs' argument may refer to a hash of additional parameters to be
449             passed to the template being executed.
450              
451             Example:
452              
453             my $report=$web->expand(
454             cgi => XAO::Objects->new(objname => 'CGI'),
455             path => '/bits/stat-report',
456             objargs => {
457             CUSTOMER_ID => '123X234Z',
458             MIN_TIME => time - 86400 * 7,
459             },
460             );
461              
462             See also lower level process() method.
463              
464             =cut
465              
466             sub expand ($%) {
467 71     71 1 677 my $self=shift;
468 71         206 my $args=get_args(\@_);
469              
470 71         886 $self->set_current;
471              
472             # Processing the page and getting its text. Setting dprint and
473             # eprint to use Apache logging if there is a reference to Apache
474             # request given to us.
475             #
476 71         506 my $pagetext=$self->process($args);
477              
478             # In scalar context (normal cases) we return only the resulting page
479             # text. In array context (compatibility) we return header as well.
480             #
481 71 50       155 if(wantarray) {
482 0         0 eprint "Calling ".ref($self)."::expand in ARRAY context is obsolete";
483 0         0 my $header=$self->config->header;
484 0         0 $self->config->cleanup(mode => 'after');
485 0         0 return ($pagetext,$header);
486             }
487             else {
488 71         155 $self->config->cleanup(mode => 'after');
489 71         598 return $pagetext;
490             }
491             }
492              
493             ###############################################################################
494              
495             sub _expand_list ($$) {
496 161     161   5031 my ($self,$autolist)=@_;
497              
498 161         255 my $content='';
499              
500 161 100       376 if(!$autolist) {
    50          
    0          
501 138         468 return '';
502             }
503             elsif(ref($autolist) eq 'ARRAY') {
504 23         74 my $clipboard=$self->config->clipboard;
505              
506 23         66 for(my $i=0; $i<@$autolist; $i+=2) {
507 28         182 my ($objname,$objargs)=@{$autolist}[$i,$i+1];
  28         76  
508 28         104 my $obj=XAO::Objects->new(objname => $objname);
509 28         2101 $content.=$obj->expand($objargs);
510              
511             # Not processing any more if there was a final output.
512             #
513 28 100       78 last if $clipboard->get('_no_more_output');
514             }
515             }
516             elsif(ref($autolist) eq 'HASH') {
517 0         0 eprint "Using HASH auto-list is deprecated, use an ordered array";
518 0         0 foreach my $objname (keys %{$autolist}) {
  0         0  
519 0         0 my $obj=XAO::Objects->new(objname => $objname);
520 0         0 $content.=$obj->expand($autolist->{$objname});
521             }
522             }
523             else {
524 0         0 throw XAO::E::Web "process - don't know how to handle ($autolist)," .
525             " must be a hash or an array reference";
526             }
527              
528 23         701 return $content;
529             }
530              
531             ###############################################################################
532              
533             =item process (%)
534              
535             Takes the same arguments as the expand() method returning expanded page
536             text. Does not clean the site context and should not be called directly
537             -- for normal situations either expand() or execute() methods should be
538             called.
539              
540             =cut
541              
542             sub process ($%) {
543 82     82 1 147 my $self=shift;
544 82         203 my $args=get_args(\@_);
545              
546 82         763 my $siteconfig=$self->config;
547 82         1940 my $clipboard=$siteconfig->clipboard;
548 82         184 my $sitename=$self->sitename;
549              
550             # Making sure path starts from a slash
551             #
552 82   33     209 my $path=$args->{'path'} || throw XAO::E::Web "process - no 'path' given";
553 82         226 $path='/' . $path;
554 82         403 $path=~s/\/{2,}/\//g;
555              
556             # Resetting page text stack in case it was terminated abnormally
557             # before and we're in the same process/memory.
558             #
559 82         295 XAO::PageSupport::reset();
560              
561             # Analyzing the path. We have to do that up here because the object
562             # might specify that we should not touch CGI.
563             #
564 82         140 my $pd=$args->{'pagedesc'};
565 82 50       186 if(!$pd) {
566 82         226 my @path=split(/\//,$path);
567 82 50       186 push(@path,"") unless @path;
568 82 50       215 push(@path,"index.html") if $path =~ /\/$/;
569 82         218 $pd=$self->analyze(\@path);
570             }
571              
572             # Figuring out current active URL. It might be the same as base_url
573             # and in most cases it is, but it just as well might be different.
574             #
575             # The URL should be full path to the start point -
576             # http://host.com in case of rewrite and something like
577             # http://host.com/cgi-bin/xao-apache.pl/sitename in case of plain
578             # CGI usage.
579             #
580 82         155 my $active_url;
581 82         146 my $apache=$args->{'apache'};
582 82         134 my $cgi=$args->{'cgi'};
583 82 100       176 if(!$cgi) {
584 7 50       15 !$args->{'psgi'} ||
585             throw XAO::E::Web "- need to have a CGI with PSGI";
586 7         34 $cgi=XAO::Objects->new(objname => 'CGI', no_cgi => $pd->{'no_cgi'});
587             }
588 82 50       196 if($apache) {
589 0         0 $active_url="http://" . $apache->hostname;
590             }
591             else {
592 82 50 33     310 if(defined($CGI::VERSION) && $CGI::VERSION>=2.80) {
593 82         553 $active_url=$cgi->url(-base => 1, -full => 0);
594 82   100     31505 my $pinfo=$cgi->path_info || '';
595 82   100     1264 my $uri=$cgi->request_uri || '';
596 82         755 $uri=~s/^(.*?)\?.*$/$1/;
597 82 100 33     783 if($pinfo =~ /^\/\Q$sitename\E(\/.+)?\Q$uri\E/) {
    50          
598             # mod_rewrite
599             }
600             elsif($pinfo && $uri =~ /^(.*)\Q$pinfo\E$/) {
601             # cgi
602 0         0 $active_url.=$1;
603             }
604             # dprint ">2.8 $active_url";
605             }
606             else {
607 0         0 $active_url=$cgi->url(-full => 1, -path_info => 0);
608 0 0       0 $active_url=$1 if $active_url=~/^(.*)(\Q$path\E)$/;
609             # dprint "<2.8 $active_url";
610             }
611              
612             # Trying to understand if rewrite module was used or not. If not
613             # - adding sitename to the end of guessed URL.
614             #
615 82 50 33     398 if($active_url =~ /cgi-bin/ || $active_url =~ /xao-[\w-]+\.pl/) {
616 0         0 $active_url.="/$sitename";
617             }
618             }
619              
620             # Eating extra slashes
621             #
622 82         204 chop($active_url) while $active_url =~ /\/$/;
623 82         213 $active_url=~s/(?
624              
625             # Figuring out secure URL
626             #
627 82         138 my $active_is_secure;
628             my $active_url_secure;
629 82 100       264 if($active_url =~ /^http:(\/\/.*)$/) {
    50          
630 48         141 $active_url_secure='https:' . $1;
631 48         76 $active_is_secure=0;
632             }
633             elsif($active_url =~ /^https:(\/\/.*)$/) {
634 34         59 $active_url_secure=$active_url;
635 34         83 $active_url='http:' . $1;
636 34         49 $active_is_secure=1;
637             }
638             else {
639 0         0 dprint "Wrong active URL ($active_url)";
640 0         0 $active_url_secure=$active_url;
641             }
642              
643             # Storing active URLs
644             #
645 82         273 $clipboard->put(active_url => $active_url);
646 82         1834 $clipboard->put(active_url_secure => $active_url_secure);
647              
648             # Checking if we have base_url, assuming active_url if not.
649             # Ensuring that URL does not end with '/'.
650             #
651 82 50       3182 if($siteconfig->defined('base_url')) {
652 82         2904 my $url=$siteconfig->get('base_url');
653 82 50       3484 $url=~/^http:/i ||
654             throw XAO::E::Web "- bad base_url ($url) for sitename=$sitename";
655 82         154 my $nu=$url;
656 82         196 chop($nu) while $nu =~ /\/$/;
657 82 50       164 $siteconfig->put(base_url => $nu) if $nu ne $url;
658              
659 82         1398 $url=$siteconfig->get('base_url_secure');
660 82 50       3269 if(!$url) {
661 0         0 $url=$siteconfig->get('base_url');
662 0         0 $url=~s/^http:/https:/i;
663             }
664 82         130 $nu=$url;
665 82         186 chop($nu) while $nu =~ /\/$/;
666 82         1439 $siteconfig->put(base_url_secure => $nu);
667             }
668             else {
669 0         0 $siteconfig->put(base_url => $active_url);
670 0         0 $siteconfig->put(base_url_secure => $active_url_secure);
671 0         0 dprint "No base_url for sitename '$sitename'; assuming base_url=$active_url, base_url_secure=$active_url_secure";
672             }
673              
674             # Checking if we're running under mod_perl
675             #
676 82 50 33     1950 my $mod_perl=($apache || $ENV{'MOD_PERL'}) ? 1 : 0;
677 82         240 $clipboard->put(mod_perl => $mod_perl);
678 82         1390 $clipboard->put(mod_perl_request => $apache);
679              
680             # Checking if a charset is known for the site. If it is, setting
681             # it up for CGI-params decoding and for output.
682             #
683 82         2547 my $charset=$siteconfig->get('charset');
684 82 50       3190 if($charset) {
685 82 50       222 if($cgi->can('set_param_charset')) {
686 82         185 $cgi->set_param_charset($charset);
687             }
688             else {
689 0         0 eprint "CGI object we have does not support set_param_charset";
690             }
691 82         1480 $siteconfig->header_args(
692             -Charset => $charset,
693             );
694             }
695              
696             # Putting CGI object into site configuration. The special case is
697             # 'no_cgi' in the path_mapping_table which means that the object is
698             # going to handle CGI arguments itself. It can be useful if it needs
699             # raw query string.
700             #
701 82         289 $siteconfig->embedded('web')->enable_special_access;
702 82         1637 $siteconfig->cgi($cgi);
703 82         180 $siteconfig->embedded('web')->disable_special_access;
704              
705             # Traditionally URLs that do not end with .foo are considered
706             # directories and get an internal redirect to path/index.html
707             # Sometimes it is desirable to be able to pass down any URLs without
708             # a forced redirect -- this is controlled by 'urlstyle' parameter
709             # set to 'raw'.
710             #
711 82   100     327 my $urlstyle=$pd->{'urlstyle'} || 'files';
712 82 100       186 if($urlstyle eq 'files') {
    50          
713 81 100       374 if($pd->{'patharr'}->[-1] !~ /\.\w+$/) {
714 2         16 my $pd=$self->analyze([ @{$pd->{'patharr'}},'index.html' ]);
  2         18  
715             #use Data::Dumper; dprint "pd=",Dumper($pd);
716 2 100       21 if($pd->{'objname'} ne 'Default') {
717 1 50       26 my $newpath=$siteconfig->get($active_is_secure ? 'base_url_secure' : 'base_url') . $path . '/';
718 1         50 dprint "Redirecting $path to $newpath";
719 1         22 $siteconfig->header_args(
720             -Location => $newpath,
721             -Status => 301,
722             );
723 1         13 return "Directory index redirection\n";
724             }
725             }
726             }
727             elsif($urlstyle eq 'raw') {
728             # nothing
729             }
730             else {
731 0         0 eprint "Unknown urlstyle '$urlstyle' for $path";
732             }
733              
734             # Separator for the error_log :)
735             #
736 81 50 33     230 if(XAO::Utils::get_debug() && !$args->{'quieter'}) {
737 0         0 my @d=localtime;
738 0         0 my $date=sprintf("%02u:%02u:%02u %u/%02u/%04u",$d[2],$d[1],$d[0],$d[4]+1,$d[3],$d[5]+1900);
739 0         0 undef(@d);
740 0         0 dprint "============ date=$date, mod_perl=$mod_perl, " .
741             "path='$path', translated='$pd->{path}'";
742             }
743              
744             # Putting path decription into the site clipboard
745             #
746 81         448 $clipboard->put(pagedesc => $pd);
747              
748             # Setting expiration time in the page header to immediate
749             # expiration. If that's not what the page wants -- it can override
750             # these.
751             #
752 81         2868 $siteconfig->header_args(
753             -expires => 'now',
754             -cache_control => 'no-cache',
755             );
756              
757             # Do we need to run any objects before executing? A good place to
758             # turn on debug mode if required using Debug object.
759             #
760 81         1591 my $pageheader=$self->_expand_list($siteconfig->get('auto_before'));
761              
762             # If the header issued a final output (commonly a redirect), then
763             # nothing else needs to be done.
764             #
765 81         148 my $pagebody='';
766 81         131 my $pagefooter='';
767 81 100       162 if(!$clipboard->get('_no_more_output')) {
768              
769             # Preparing object arguments out of standard ones, object specific
770             # once from template paths and supplied hash (in that order of
771             # preference).
772             #
773             my $objargs={
774             path => $pd->{'path'},
775             fullpath => $pd->{'fullpath'},
776 80         2201 prefix => $pd->{'prefix'},
777             };
778              
779 80         311 $objargs=merge_refs($objargs,$pd->{'objargs'},$args->{'objargs'});
780              
781             # Loading page displaying object and executing it.
782             #
783 80         1766 my $obj=XAO::Objects->new(objname => 'Web::' . $pd->{'objname'});
784 80         5710 $pagebody=$obj->expand($objargs);
785              
786             # Do we need to run any objects after executing? A good place to
787             # dump benchmark statistics for example.
788             #
789 80         1649 $pagefooter=$self->_expand_list($siteconfig->get('auto_after'));
790             }
791              
792             # Done! Somewhat convoluted way of joining strings is here because
793             # the page header would be a unicode character string (even if
794             # it is really an empty string) and that would contaminate the
795             # concatenation and convert the resulting page text into a character
796             # string. That is not desirable if the output is a binary document.
797             #
798             my $pagetext=join('',map {
799 81 100 50     216 Encode::is_utf8($_) ? Encode::encode($charset || 'utf8',$_) : $_;
  243         982  
800             } ($pageheader,$pagebody,$pagefooter));
801              
802             ### dprint "---length(pageheader)=".length($pageheader).", utf8=".Encode::is_utf8($pageheader);
803             ### dprint "---length(pagebody)= ".length($pagebody).", utf8=".Encode::is_utf8($pagebody);
804             ### dprint "---length(pagefooter)=".length($pagefooter).", utf8=".Encode::is_utf8($pagefooter);
805             ### dprint "---length(pagetext)= ".length($pagetext).", utf8=".Encode::is_utf8($pagetext);
806              
807 81         1675 $siteconfig->header_args(
808             -content_length => length($pagetext),
809             );
810              
811 81         288 return $pagetext;
812             }
813              
814             ###############################################################################
815              
816             =item new (%)
817              
818             Creates or loads a context for the named site. The only required
819             argument is 'sitename' which provides the name of the site.
820              
821             =cut
822              
823             sub new ($%) {
824 38     38 1 394 my $proto=shift;
825 38         921 my $args=get_args(\@_);
826              
827             ##
828             # Getting site name
829             #
830 38   33     2065 my $sitename=$args->{'sitename'} ||
831             throw XAO::E::Web "new - required parameter missing (sitename)";
832              
833             ##
834             # Loading or creating site configuration object.
835             #
836 38         599 my $siteconfig=XAO::Projects::get_project($sitename);
837 38 50       543 if(!$siteconfig) {
838             ##
839             # Creating configuration.
840             #
841 38         789 $siteconfig=XAO::Objects->new(
842             sitename => $sitename,
843             objname => 'Config',
844             );
845              
846             ##
847             # Always embedding at least web config and a hash
848             #
849 38         157659 $siteconfig->embed(web => new XAO::Objects objname => 'Web::Config');
850 38         10929 $siteconfig->embed(hash => new XAO::SimpleHash);
851              
852             ##
853             # Running initialization, this is where parameters are inserted and
854             # normally FS::Config gets embedded.
855             #
856 38   33     13322 $siteconfig->init($args->{'init_args'} || ());
857              
858             ##
859             # Creating an entry in in-memory projects repository
860             #
861 38         13558 XAO::Projects::create_project(
862             name => $sitename,
863             object => $siteconfig,
864             );
865             }
866              
867             # CGI in args is not supported any more, needs to be passed in execute
868             #
869 38 50       2229 $args->{'cgi'} &&
870             throw XAO::E::Web "- 'cgi' argument to 'new' is not supported, pass it to 'execute'";
871              
872             # This helps Mailer to be called outside of web context.
873             # TODO: Probably need some better initialization strategy, this does
874             # not feel as the Right Thing
875             #
876 38         1089 my $url=$siteconfig->get('base_url');
877 38 50       3775 if($url) {
878 38 50       440 $url=~/^http:/i ||
879             throw XAO::E::Web "new - bad base_url ($url) for sitename=$sitename";
880 38         153 my $nu=$url;
881 38         584 chop($nu) while $nu =~ /\/$/;
882 38 50       185 $siteconfig->put(base_url => $nu) if $nu ne $url;
883              
884 38         999 $url=$siteconfig->get('base_url_secure');
885 38 50       1462 if(!$url) {
886 38         844 $url=$siteconfig->get('base_url');
887 38         1999 $url=~s/^http:/https:/i;
888             }
889 38         134 $nu=$url;
890 38         179 chop($nu) while $nu =~ /\/$/;
891 38         876 $siteconfig->put(base_url_secure => $nu);
892             }
893              
894             # Done
895             #
896             bless {
897 38   33     2024 sitename => $sitename,
898             siteconfig => $siteconfig,
899             }, ref($proto) || $proto;
900             }
901              
902             ###############################################################################
903              
904             sub check_uri_access ($$) {
905 0     0 0 0 my ($self,$uri)=@_;
906              
907             # By convention we disallow access to /bits/ and /CVS/ for security
908             # reasons. If needed the site can override these or add other
909             # regex'es into path_deny_table
910             #
911 0         0 my $pdtc=$self->config->get('path_deny_table_compiled');
912 0 0       0 if(!$pdtc) {
913 0   0     0 my $pdt=merge_refs({
914             '/bits/' => 1,
915             '/CVS/' => 1,
916             },$self->config->get('path_deny_table') || { });
917 0         0 $pdtc=[ map { qr/$_/ } grep { $pdt->{$_} } keys %$pdt ];
  0         0  
  0         0  
918 0         0 $self->config->put('path_deny_table_compiled' => $pdtc);
919             }
920              
921 0         0 return ! grep { $uri =~ $_ } @$pdtc;
  0         0  
922             }
923              
924             ###############################################################################
925              
926             =item set_current ()
927              
928             Sets the current site as the current project in the sense of XAO::Projects.
929              
930             =cut
931              
932             sub set_current ($) {
933 120     120 1 215 my $self=shift;
934              
935 120         319 XAO::Projects::set_current_project($self->sitename);
936              
937             # Cleaning up the configuration. Useful even if it was just created
938             # as it will unlock tables in the database for instance.
939             # We call it here because cleanup code may rely on the project being
940             # active.
941             #
942 120         1558 $self->config->cleanup(mode => 'before');
943             }
944              
945             ###############################################################################
946              
947             =item sitename ()
948              
949             Returns site name.
950              
951             =cut
952              
953             sub sitename ($) {
954 202     202 1 331 my $self=shift;
955 202 50       873 $self->{'sitename'} || throw XAO::E::Web "sitename - no site name";
956             }
957              
958             ###############################################################################
959             1;
960             __END__