File Coverage

blib/lib/DiaColloDB/WWW/Handler/cgi.pm
Criterion Covered Total %
statement 18 54 33.3
branch 0 22 0.0
condition 0 10 0.0
subroutine 6 8 75.0
pod 2 2 100.0
total 26 96 27.0


line stmt bran cond sub pod time code
1             ##-*- Mode: CPerl -*-
2              
3             ## File: DiaColloDB::WWW::Handler::cgi.pm
4             ## Author: Bryan Jurish <moocow@cpan.org>
5             ## Description:
6             ## + DiaColloDB::WWW::Server URI handler for template-toolkit files via cgi
7             ## + adapted from DTA::CAB::Server::HTTP::Handler::CGI ( svn+ssh://odo.dwds.de/home/svn/dev/DTA-CAB/trunk/CAB/Server/HTTP/Handler/CGI.pm )
8             ##======================================================================
9              
10             package DiaColloDB::WWW::Handler::cgi;
11 1     1   6 use DiaColloDB::WWW::Handler;
  1         2  
  1         8  
12 1     1   24 use HTTP::Status;
  1         2  
  1         42  
13 1     1   257 use File::Basename qw(basename);
  1         9  
  1         22  
14 1     1   93 use URI::Escape qw(uri_escape uri_escape_utf8);
  1         9  
  1         20  
15 1     1   80 use Carp;
  1         2  
  1         16  
16 1     1   87 use strict;
  1         2  
  1         529  
17              
18             our @ISA = qw(DiaColloDB::WWW::Handler);
19              
20             ##--------------------------------------------------------------
21             ## Methods
22              
23             ## $h = $class_or_obj->new(%options)
24             ## + %options:
25             ## (
26             ## template => $ttkfile, ##-- ttk template for instantiation (REQUIRED)
27             ## )
28             sub new {
29 0     0 1   my $that = shift;
30 0   0       my $h = bless {
31             template => undef,
32             @_,
33             }, ref($that)||$that;
34 0           return $h;
35             }
36              
37             ## $rsp = $h->run($server, $clientConn, $httpRequest)
38             sub run {
39 0     0 1   my ($h,$srv,$csock,$hreq) = @_;
40              
41             ##-- load config
42 0           local (%::dstar) = qw();
43             {
44 0           package main;
45 0           my ($rcfile);
46 0 0         if (-r ($rcfile="$srv->{wwwdir}/dstar.rc")) {
47 0 0         do "$rcfile" or $h->logconfess("run(): failed to load dstar config file '$rcfile': $@");
48             }
49 0 0         if (-r ($rcfile="$srv->{wwwdir}/local.rc")) {
50 0 0         do "$rcfile" or $h->logconfess("run(): failed to load local config file '$rcfile': $@");
51             }
52 0   0       $::dstar{corpus} ||= $srv->{dburl};
53             }
54              
55             ##-- setup dbcgi object
56 0 0 0       my $dbcgi = DiaColloDB::WWW::CGI->new(%{$srv->{cgiArgs}//{}})
  0            
57             or $h->logconfess("could not create DiaColloDB::WWW::CGI object: $!");
58 0           $dbcgi->t_start(); ##-- re-start package-global timer (hack; this should really be object-local)
59 0           $dbcgi->{ttk_vars}{DIACOLLO_DBURL} = $srv->{dburl};
60 0           $dbcgi->{ttk_vars}{dstar}{$_} = $::dstar{$_} foreach (keys %::dstar);
61 0 0         $dbcgi->fromRequest($hreq,$csock)
62             or $h->logconfess("run(): failed to setup {dbcgi} object from HTTP::Request");
63              
64             ##-- run dbcgi template
65 0           my $ttkey = $dbcgi->ttk_key(basename($h->{template}, '.ttk'));
66 0           my $israw = $dbcgi->{ttk_rawkeys}{$ttkey};
67 0           my ($content,$status);
68 0           eval {
69 0 0         $dbcgi->ttk_process($h->{template}, $dbcgi->vars,
70             ($israw ? ({ENCODING=>undef},{binmode=>':raw'}) : (undef,undef)),
71             \$content);
72 0           $status = RC_OK;
73             };
74 0 0         if ($@) {
    0          
75 0           ($status,$content) = (RC_INTERNAL_SERVER_ERROR, join('',$dbcgi->htmlerror(undef,$@)));
76             } elsif (!$content) {
77 0           ($status,$content) = (RC_INTERNAL_SERVER_ERROR, join('',$dbcgi->htmlerror(undef,"template '$h->{template}' returned no content")));
78             }
79              
80             ##-- construct HTTP::Response
81 0 0         utf8::encode($content) if (utf8::is_utf8($content));
82 0           my ($headers);
83 0 0         if ($content =~ s/^(.*?)(?:\x{0d}\x{0a}){2}//s) {
84 0           my $headstr = $1;
85 0           $headers = [ map {split(/\s*:\s*/,$_,2)} split(/\x{0d}\x{0a}/,$headstr) ];
  0            
86             }
87 0   0       my $rsp = $h->response($status, undef, $headers//[]);
88 0           $rsp->content_ref(\$content);
89 0           return $rsp;
90             }
91              
92              
93             ## undef = $h->finish($server, $clientSocket)
94             ## + clean up handler state after run() (dummy, inherited)
95              
96              
97             1; ##-- be happy
98              
99             __END__