File Coverage

blib/lib/XAO/testcases/Web/base.pm
Criterion Covered Total %
statement 62 63 98.4
branch 6 12 50.0
condition n/a
subroutine 14 14 100.0
pod 0 6 0.0
total 82 95 86.3


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             XAO::testcases::base - base class for easier XAO::Web project testing
4              
5             =head1 DESCRIPTION
6              
7             This class extends XAO::testcases::base for easier testing of Web based
8             projects. It adds a CGI variable to the setup.
9              
10             =cut
11              
12             ###############################################################################
13             package XAO::testcases::Web::base;
14 22     22   539375 use strict;
  22         56  
  22         682  
15 22     22   10175 use IO::File;
  22         157611  
  22         2938  
16 22     22   198 use XAO::Utils;
  22         65  
  22         1149  
17 22     22   6536 use XAO::Base;
  22         19998  
  22         879  
18 22     22   7213 use XAO::Objects;
  22         32589  
  22         692  
19 22     22   9051 use XAO::Web;
  22         74  
  22         775  
20 22     22   142 use XAO::Projects qw(:all);
  22         53  
  22         2807  
21              
22 22     22   409 use base qw(XAO::testcases::base);
  22         81  
  22         11046  
23              
24             sub new ($) {
25 22     22 0 8430 my $proto=shift;
26 22         186 my $self=$proto->SUPER::new(@_);
27              
28             # Site root is not set up yet at this point, so can't use the data
29             # from the test site configuration.
30             #
31             # Nearly identical code is in t/xao/projects/test/objects/Config.pm
32             #
33 22         262 my %d;
34 22         39 if(1) {
35 22 50       878 open(F,'.config') ||
36             die "No .config found, run 'perl Makefile.PL'";
37 22         160 local($/);
38 22         587 my $t=;
39 22         266 close(F);
40 22         1615 eval $t;
41             }
42              
43 22 50       261 $self->{'skip_db_tests'}=$d{'test_dsn'} eq 'none' ? 1 : 0;
44              
45 22         131 return $self;
46             }
47              
48             sub list_tests ($) {
49 44     44 0 8185 my $self=shift;
50              
51 44         344 my @tests=$self->SUPER::list_tests(@_);
52              
53 44 50       16207 if($self->{'skip_db_tests'}) {
54 44         102 @tests=grep { ! /_db_/ } @tests;
  96         258  
55             }
56              
57 44 50       232 return wantarray ? @tests : \@tests;
58             }
59              
60             sub set_up {
61 38     38 0 8421 my $self=shift;
62              
63 38         195 $self->SUPER::set_up();
64              
65 38         131310 my $site=XAO::Web->new(sitename => 'test');
66 38         267 $site->set_current();
67              
68 38         828 my $cgi=$self->cgi_object;
69              
70 38 50       519 if(my $charset=$site->config->get('charset')) {
71 38 50       2514 if($cgi->can('set_param_charset')) {
72 38         158 $cgi->set_param_charset($charset);
73             }
74             else {
75 0         0 eprint "CGI object we have does not support set_param_charset";
76             }
77 38         154 $site->config->header_args(
78             -Charset => $charset,
79             );
80             }
81              
82 38         168 $site->config->embedded('web')->enable_special_access();
83 38         156 $site->config->cgi($cgi);
84 38         136 $site->config->embedded('web')->disable_special_access();
85              
86 38         144 $self->{'siteconfig'}=$site->config;
87 38         282 $self->{'web'}=$site;
88 38         174 $self->{'cgi'}=$cgi;
89              
90 38         185 return $self;
91             }
92              
93             sub cgi_object {
94 38     38 0 262 XAO::Objects->new(
95             objname => 'CGI',
96             query => 'foo=bar&ucode=%D1%82%D0%B5%D1%81%D1%82&bytes=%01%02%03%04&test=1',
97             );
98             }
99              
100             sub web {
101 81     81 0 6601 my $self=shift;
102 81         201 return $self->{'web'};
103             }
104              
105             sub cgi {
106 12     12 0 4633 my $self=shift;
107 12         82 return $self->{'cgi'};
108             }
109              
110             ###############################################################################
111             1;
112             __END__