File Coverage

blib/lib/Net/ICAP/Response.pm
Criterion Covered Total %
statement 102 110 92.7
branch 25 42 59.5
condition 4 12 33.3
subroutine 15 15 100.0
pod 5 5 100.0
total 151 184 82.0


line stmt bran cond sub pod time code
1             # Net::ICAP::Response -- Response object for ICAP
2             #
3             # (c) 2012, Arthur Corliss
4             #
5             # $Revision: 0.03 $
6             #
7             # This software is licensed under the same terms as Perl, itself.
8             # Please see http://dev.perl.org/licenses/ for more information.
9             #
10             #####################################################################
11              
12             #####################################################################
13             #
14             # Environment definitions
15             #
16             #####################################################################
17              
18             package Net::ICAP::Response;
19              
20 2     2   23956 use 5.008003;
  2         8  
  2         93  
21              
22 2     2   15 use strict;
  2         4  
  2         105  
23 2     2   64 use warnings;
  2         5  
  2         73  
24 2     2   13 use vars qw($VERSION @ISA @_properties @_methods);
  2         4  
  2         274  
25 2     2   1258 use Class::EHierarchy qw(:all);
  2         9335  
  2         407  
26 2     2   660 use Net::ICAP::Common qw(:std :debug :resp);
  2         5  
  2         556  
27 2     2   775 use Net::ICAP::Message;
  2         6  
  2         101  
28 2     2   15 use Paranoid::Debug;
  2         4  
  2         2334  
29              
30             ($VERSION) = ( q$Revision: 0.03 $ =~ /(\d+(?:\.(\d+))+)/sm );
31              
32             @ISA = qw(Net::ICAP::Message Class::EHierarchy);
33              
34             @_properties = (
35             [ CEH_RESTR | CEH_SCALAR, '_status' ],
36             [ CEH_RESTR | CEH_HASH,
37             '_status_text',
38             { 100 => 'Continue after ICAP Preview',
39             200 => 'OK',
40             204 => 'No Modifications Needed',
41             400 => 'Bad Request',
42             401 => 'Unauthorized',
43             403 => 'Forbidden',
44             404 => 'ICAP Service Not Found',
45             405 => 'Method Not Allowed For Service',
46             407 => 'Proxy Authentication Required',
47             408 => 'Request Time-out',
48             411 => 'Length Required',
49             414 => 'Request-URI Too Large',
50             418 => 'Bad Composition',
51             500 => 'Internal Server Error',
52             501 => 'Method Not Implemented',
53             502 => 'Bad Gateway',
54             503 => 'Service Overloaded',
55             504 => 'Gateway Time-out',
56             505 => 'ICAP Version Not Supported',
57             }
58             ],
59             );
60              
61             #####################################################################
62             #
63             # Module code follows
64             #
65             #####################################################################
66              
67             sub _initialize ($;@) {
68              
69 11     11   1765 my $obj = shift;
70 11         26 my %args = @_;
71 11         18 my $rv = 1;
72              
73 11         36 pdebug( "entering w/$obj and @{[ keys %args]}", ICAPDEBUG1 );
  11         59  
74 11         114 pIn();
75              
76             # Set internal state if args were passed
77 11 100       93 $rv = $obj->status( $args{status} ) if exists $args{status};
78              
79 11         26 pOut();
80 11         90 pdebug( "leaving w/rv: $rv", ICAPDEBUG1 );
81              
82 11         118 return $rv;
83             }
84              
85             sub _validHeaders ($) {
86              
87             # Purpose: Returns a list of valid ICAP headers
88             # Returns: Array
89             # Usage: @val = $obj->_validHeaders;
90              
91 40     40   54 my $obj = shift;
92              
93             return (
94 40         168 qw(Allow Methods Service Server ISTag
95             Opt-body-type Max-Connections Options-TTL Service-ID
96             Preview Transfer-Preview Transfer-Ignore
97             Transfer-Complete), $obj->SUPER::_validHeaders
98             );
99             }
100              
101             sub status ($;$) {
102              
103             # Purpose: Gets/sets response status code
104             # Returns: Boolean/string
105             # Usage: $rv = $obj->status($code);
106             # Usage: $code = $obj->status;
107              
108 17     17 1 31 my $obj = shift;
109 17         23 my $status = shift;
110 17 100       57 my $s = defined $status ? $status : 'undef';
111 17         21 my ( $r, $rv );
112              
113 17         64 pdebug( "entering w/$s", ICAPDEBUG1 );
114 17         165 pIn();
115              
116 17 100       120 if ( defined $status ) {
117              
118             # Write mode
119 6 50       36 if ( $obj->exists( '_status_text', $status ) ) {
120 6         236 $rv = $obj->property( '_status', $status );
121             } else {
122 0         0 $obj->error("invalid status code passed: $status");
123 0         0 $rv = 0;
124             }
125              
126             } else {
127              
128             # Read mode
129 11         37 $rv = $obj->property('_status');
130             }
131              
132 17 50       775 $r = defined $rv ? $rv : 'undef';
133 17         50 pOut();
134 17         138 pdebug( "leaving w/rv: $r", ICAPDEBUG1 );
135              
136 17         222 return $rv;
137             }
138              
139             sub statusText ($;$) {
140              
141             # Purpose: Returns associated status description string
142             # Returns: String
143             # Usage: $text = $obj->statusText($code);
144             # Usage: $text = $obj->statusText;
145              
146 11     11 1 17 my $obj = shift;
147 11         20 my $status = shift;
148 11 50       30 my $s = defined $status ? $status : 'undef';
149 11         16 my ( $rv, $r );
150              
151 11         42 pdebug( "entering w/$s", ICAPDEBUG1 );
152 11         104 pIn();
153              
154 11 50       100 $status = $obj->property('_status') unless defined $status;
155 11 50       413 if ( defined $status ) {
156 11         15 $s = $status;
157 11 50       34 $rv = $obj->retrieve( '_status_text', $status )
158             if $obj->exists( '_status_text', $status );
159             }
160              
161 11 50       773 $obj->error("invalid or undefined status: $s")
162             unless defined $rv;
163              
164 11 50       28 $r = defined $rv ? $rv : 'undef';
165 11         32 pOut();
166 11         88 pdebug( "leaving w/rv: $r", ICAPDEBUG1 );
167              
168 11         134 return $rv;
169             }
170              
171             sub sanityCheck ($) {
172              
173             # Purpose: Checks for required information
174             # Returns: Boolean
175             # Usage: $rv = $obj->sanityCheck;
176              
177 11     11 1 20 my $obj = shift;
178 11         16 my $rv = 1;
179 11         12 my $t;
180              
181 11         44 $t = $obj->property('_status');
182 11 50 33     463 unless ( defined $t and length $t ) {
183 0         0 $obj->error('missing a valid request method');
184 0         0 $rv = 0;
185             }
186              
187 11         36 $t = $obj->property('_version');
188 11 50 33     489 unless ( defined $t and length $t ) {
189 0         0 $obj->error('missing a valid ICAP protocol version');
190 0         0 $rv = 0;
191             }
192              
193 11         40 $t = $obj->header('ISTag');
194 11 50 33     71 unless ( defined $t and length $t ) {
195 0         0 $obj->error('missing mandatory ISTag header');
196 0         0 $rv = 0;
197             }
198              
199 11 50       46 $obj->error('failed sanity check') unless $rv;
200 11 50       23 $obj->error('failed sanity check') unless $rv;
201              
202 11         40 return $rv;
203             }
204              
205             sub parse ($$) {
206              
207             # Purpose: Parses message from passed input
208             # Returns: Boolean
209             # Usage: $rv = $obj->parse($input);
210              
211 10     10 1 1628 my $obj = shift;
212 10         15 my $input = shift;
213 10 50       29 my $i = defined $input ? $input : 'undef';
214 10         15 my $rv = 0;
215 10         14 my ( $line, $s, $v );
216              
217 10         62 pdebug( "entering w/$obj, $i", ICAPDEBUG1 );
218 10         99 pIn();
219              
220 10 50       74 if ( defined $input ) {
221              
222             # Purge internal state
223 10         42 $obj->property( '_status', undef );
224              
225             # Parse
226 10         526 $rv = $obj->SUPER::parse($input);
227              
228 10 100       32 if ($rv) {
229              
230             # Extract response specific fields
231 5         21 $line = $obj->property('_start');
232 5         261 ( $v, $s ) = ( $line =~ /^(\S+)\s+(\d+)/sm );
233              
234             # Save the extracted information
235 5   33     22 $rv = $obj->status($s) && $obj->version($v);
236              
237             # Final sanity check
238 5 50       29 $rv = $obj->sanityCheck if $rv;
239             }
240             }
241              
242 10         192 pOut();
243 10         86 pdebug( "leaving w/rv: $rv", ICAPDEBUG1 );
244              
245 10         149 return $rv;
246             }
247              
248             sub generate ($$) {
249              
250             # Purpose: Generates an ICAP response
251             # Returns: String
252             # Usage: $response = $obj->generate($ref);
253              
254 6     6 1 464 my $obj = shift;
255 6         11 my $out = shift;
256 6         8 my $rv;
257              
258 6 50       17 if ( $obj->sanityCheck ) {
259              
260             # Build start line
261 6         19 $obj->property( '_start', join ' ', ICAP_VERSION, $obj->status,
262             $obj->statusText );
263              
264             # Generate ICAP message
265 6         344 $rv = $obj->SUPER::generate($out);
266             }
267              
268 6         41 return $rv;
269             }
270              
271             1;
272              
273             __END__