File Coverage

blib/lib/Test/Environment/Plugin/Apache2/Apache2/RequestRec.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             package Test::Environment::Plugin::Apache2::Apache2::RequestRec;
2              
3             our $VERSION = '0.06';
4              
5             1;
6              
7             package Apache2::RequestRec;
8              
9             =head1 NAME
10              
11             Test::Environment::Plugin::Apache2::Apache2::RequestRec - fake Apache2::RequestRec for Test::Environment
12              
13             =head1 SYNOPSIS
14              
15             use Test::Environment qw{
16             Apache2
17             };
18            
19             my $request = Apache2::RequestRec->new(
20             'headers_in' => {
21             'Accept-Encoding' => 'xyz,gzip'
22             },
23             'hostname' => 'with.the.man.sk',
24             'uri' => '/index.html',
25             'args' => 'id=me',
26             );
27             is(
28             My::App:Apache2::Index::handler($request),
29             Apache2::Const::REDIRECT,
30             );
31             is(
32             $request->headers_out->get('Location'),
33             'http://with.the.man.sk/me/',
34             );
35              
36             =head1 DESCRIPTION
37              
38             Will populate Apache2::RequestRec namespace with fake methods that can be used for
39             testing.
40              
41             =cut
42              
43 1     1   896 use warnings;
  1         2  
  1         35  
44 1     1   5 use strict;
  1         2  
  1         42  
45              
46             our $VERSION = '0.06';
47              
48 1     1   444 use APR::Pool;
  0            
  0            
49             use APR::Table;
50              
51             use base 'Class::Accessor::Fast';
52              
53              
54             =head1 PROPERTIES
55              
56             hostname
57             uri
58             apr_pool
59             args
60             get_server_port
61             dir_config
62             status
63             content_type
64             method
65              
66             =cut
67              
68             __PACKAGE__->mk_accessors(qw{
69             hostname
70             uri
71             apr_pool
72             args
73             get_server_port
74             dir_config
75             status
76             content_type
77             method
78             });
79              
80              
81             =head1 METHODS
82              
83             =head2 new()
84              
85             Object constructor.
86              
87             =cut
88              
89             sub new {
90             my $class = shift;
91             my $self = $class->SUPER::new({
92             'get_server_port' => 80,
93             'apr_pool' => APR::Pool->new,
94             'method' => 'GET',
95             @_,
96             });
97            
98             # initialize all apr tables
99             foreach my $apt_table_name (qw(apr_table headers_in headers_out subprocess_env dir_config)) {
100             my $apr_table = $self->{$apt_table_name} || APR::Table::make($self->apr_pool, 100);
101            
102             # if the parameter is plain HASH, convert it to APR::Table
103             if (ref $apr_table eq 'HASH') {
104             my $hash = $apr_table;
105             $apr_table = APR::Table::make($self->apr_pool, 100);
106             while (my ($key, $value) = each(%{$hash})) {
107             $apr_table->add($key => $value);
108             }
109             }
110            
111             $self->{$apt_table_name} = $apr_table;
112             }
113            
114             return $self;
115             }
116              
117             =head2 pnotes
118              
119             Get/Set pnote.
120              
121             =cut
122              
123             sub pnotes {
124             my $self = shift;
125             my $note_name = shift;
126            
127             if (@_ > 0) {
128             $self->{'pnotes'}->{$note_name} = shift;
129             }
130            
131             return $self->{'pnotes'}->{$note_name};
132             }
133              
134             sub unparsed_uri {
135             my $self = shift;
136            
137             return $self->uri.($self->args ? '?'.$self->args : '' );
138             }
139              
140             =head2 APR::Table methods
141              
142             =head3 apt_table()
143             =head3 subprocess_env()
144             =head3 headers_in()
145             =head3 headers_out()
146             =head3 dir_config()
147              
148             =cut
149              
150             sub apr_table { return shift->_get_set('apr_table', @_) };
151             sub subprocess_env { return shift->_get_set('subprocess_env', @_) };
152             sub headers_in { return shift->_get_set('headers_in', @_) };
153             sub headers_out { return shift->_get_set('headers_out', @_) };
154             sub dir_config { return shift->_get_set('dir_config', @_) };
155              
156             sub err_headers_out {
157             my $self = shift;
158             $self->headers_out(@_);
159             }
160              
161             sub _get_set {
162             my $self = shift;
163             my $name = shift;
164            
165             if (@_ > 0) {
166             my $key_name = shift;
167             if (@_ > 0) {
168             $self->{$name}->add($key_name => shift);
169             }
170             return $self->{$name}->get($key_name);
171             }
172             else {
173             return $self->{$name};
174             }
175             }
176              
177              
178             =head2 Apache2::Filter::r
179              
180             just calls $self->request_rec(@_);
181              
182             =cut
183              
184             sub Apache2::Filter::r {
185             my $self = shift;
186             $self->request_rec(@_);
187             }
188              
189             =head2 Apache2::Filter::request_rec
190              
191             Returns Apache2::RequestRec.
192              
193             =cut
194              
195             sub Apache2::Filter::request_rec {
196             my $self = shift;
197            
198             if (@_ > 0) {
199             $self->{'request_rec'} = shift;
200             }
201            
202             if (ref $self->{'request_rec'} ne __PACKAGE__) {
203             $self->{'request_rec'} = bless $self->{'request_rec'}, __PACKAGE__;
204             }
205            
206            
207             return $self->{'request_rec'};
208             }
209              
210              
211             'writing on the wall';
212              
213             __END__