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.07";
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   862 use warnings;
  1         2  
  1         34  
44 1     1   4 use strict;
  1         1  
  1         30  
45              
46             our $VERSION = "0.07";
47              
48 1     1   401 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             protocol
66              
67             =cut
68              
69             __PACKAGE__->mk_accessors(qw{
70             hostname
71             uri
72             apr_pool
73             args
74             get_server_port
75             dir_config
76             status
77             content_type
78             method
79             protocol
80             });
81              
82              
83             =head1 METHODS
84              
85             =head2 new()
86              
87             Object constructor.
88              
89             =cut
90              
91             sub new {
92             my $class = shift;
93             my $self = $class->SUPER::new({
94             'get_server_port' => 80,
95             'apr_pool' => APR::Pool->new,
96             'method' => 'GET',
97             'protocol' => 'HTTP/1.1',
98             @_,
99             });
100            
101             # initialize all apr tables
102             foreach my $apt_table_name (qw(apr_table headers_in headers_out subprocess_env dir_config)) {
103             my $apr_table = $self->{$apt_table_name} || APR::Table::make($self->apr_pool, 100);
104            
105             # if the parameter is plain HASH, convert it to APR::Table
106             if (ref $apr_table eq 'HASH') {
107             my $hash = $apr_table;
108             $apr_table = APR::Table::make($self->apr_pool, 100);
109             while (my ($key, $value) = each(%{$hash})) {
110             $apr_table->add($key => $value);
111             }
112             }
113            
114             $self->{$apt_table_name} = $apr_table;
115             }
116            
117             return $self;
118             }
119              
120             =head2 notes
121              
122             Get/Set notes.
123              
124             =cut
125              
126              
127             sub notes {
128             my $self = shift;
129             my $note_name = shift;
130              
131             if (@_ > 0) {
132             $self->{'notes'}->{$note_name} = shift;
133             }
134              
135             return $self->{'notes'}->{$note_name};
136             }
137              
138             =head2 pnotes
139              
140             Get/Set pnotes.
141              
142             =cut
143              
144             sub pnotes {
145             my $self = shift;
146             my $note_name = shift;
147            
148             if (@_ > 0) {
149             $self->{'pnotes'}->{$note_name} = shift;
150             }
151            
152             return $self->{'pnotes'}->{$note_name};
153             }
154              
155             sub unparsed_uri {
156             my $self = shift;
157            
158             return $self->uri.($self->args ? '?'.$self->args : '' );
159             }
160              
161             =head2 APR::Table methods
162              
163             =head3 apt_table()
164             =head3 subprocess_env()
165             =head3 headers_in()
166             =head3 headers_out()
167             =head3 dir_config()
168              
169             =cut
170              
171             sub apr_table { return shift->_get_set('apr_table', @_) };
172             sub subprocess_env { return shift->_get_set('subprocess_env', @_) };
173             sub headers_in { return shift->_get_set('headers_in', @_) };
174             sub headers_out { return shift->_get_set('headers_out', @_) };
175             sub dir_config { return shift->_get_set('dir_config', @_) };
176              
177             sub err_headers_out {
178             my $self = shift;
179             $self->headers_out(@_);
180             }
181              
182             sub _get_set {
183             my $self = shift;
184             my $name = shift;
185            
186             if (@_ > 0) {
187             my $key_name = shift;
188             if (@_ > 0) {
189             $self->{$name}->add($key_name => shift);
190             }
191             return $self->{$name}->get($key_name);
192             }
193             else {
194             return $self->{$name};
195             }
196             }
197              
198              
199             =head2 Apache2::Filter::r
200              
201             just calls $self->request_rec(@_);
202              
203             =cut
204              
205             sub Apache2::Filter::r {
206             my $self = shift;
207             $self->request_rec(@_);
208             }
209              
210             =head2 Apache2::Filter::request_rec
211              
212             Returns Apache2::RequestRec.
213              
214             =cut
215              
216             sub Apache2::Filter::request_rec {
217             my $self = shift;
218            
219             if (@_ > 0) {
220             $self->{'request_rec'} = shift;
221             }
222            
223             if (ref $self->{'request_rec'} ne __PACKAGE__) {
224             $self->{'request_rec'} = bless $self->{'request_rec'}, __PACKAGE__;
225             }
226            
227            
228             return $self->{'request_rec'};
229             }
230              
231             =head2 populate_env
232              
233             Sets CGI %ENV variables based on current RequestRec object.
234              
235             =cut
236              
237             sub populate_env {
238             my $self = shift;
239              
240             $ENV{REQUEST_METHOD} = $self->method;
241             $ENV{HTTP_HOST} = $self->hostname;
242             $ENV{REQUEST_URI} = $self->uri;
243             $ENV{QUERY_STRING} = $self->args;
244             my $cookie = $self->headers_in->get('cookie');
245             $ENV{HTTP_COOKIE} = $cookie
246             if $cookie;
247             }
248              
249             =head2 rflush
250              
251             empty call
252              
253             =cut
254              
255             sub rflush { }
256              
257              
258             'writing on the wall';
259              
260             __END__