File Coverage

lib/CGI/PathInfo.pm
Criterion Covered Total %
statement 149 150 99.3
branch 51 52 98.0
condition 3 3 100.0
subroutine 11 11 100.0
pod 5 5 100.0
total 219 221 99.1


line stmt bran cond sub pod time code
1             package CGI::PathInfo;
2              
3 5     5   9381 use strict;
  5         34  
  5         143  
4 5     5   23 use warnings;
  5         8  
  5         205  
5              
6             BEGIN {
7 5     5   12 $CGI::PathInfo::VERSION = '1.05';
8 5         8848 $CGI::PathInfo::_mod_perl = 0;
9             }
10              
11             # check for mod_perl and include the 'Apache' module if needed
12             if (exists($ENV{'MOD_PERL'}) && (0 == $CGI::PathInfo::_mod_perl)) {
13             $| = 1;
14              
15             if (exists ($ENV{MOD_PERL_API_VERSION}) && ($ENV{MOD_PERL_API_VERSION} == 2)) {
16             require Apache2::RequestUtil;
17             require Apache2::RequestIO;
18             require APR::Pool;
19             $CGI::PathInfo::_mod_perl = 2;
20              
21             } else {
22             require Apache;
23             $CGI::PathInfo::_mod_perl = 1;
24             }
25             }
26              
27             sub new {
28 36     36 1 1346 my $proto = shift;
29 36         46 my $package = __PACKAGE__;
30 36         42 my $class;
31 36 100       114 if (ref($proto)) {
    100          
32 2         3 $class = ref ($proto);
33             } elsif ($proto) {
34 32         40 $class = $proto;
35             } else {
36 2         13 $class = $package;
37             }
38 36         63 my $self = bless {},$class;
39              
40 36         87 $self->{$package}->{'field_names'} = [];
41 36         62 $self->{$package}->{'field'} = {};
42 36         109 $self->{$package}->{'settings'} = {
43             'eq' => '-',
44             'spliton' => '/',
45             'stripleadingslash' => 1,
46             'striptrailingslash' => 1,
47             };
48              
49 36         44 my $parms;
50 36 100       82 if ($#_ == 0) {
    100          
51 12         17 $parms = shift;
52             } elsif ($#_ > 0) {
53 8 100       23 if (0 == $#_ % 2) {
54 2         11 require Carp;
55 2         255 Carp::croak('[' . localtime(time) . "] [error] $package" . '::new() - odd number of passed parameters');
56             }
57 6         18 %$parms = @_;
58             } else {
59 16         22 $parms = {};
60             }
61 34 100       87 if (ref($parms) ne 'HASH') {
62 4         23 require Carp;
63 4         812 Carp::croak('[' . localtime(time) . "] [error] $package" . '::new() - Passed parameters do not appear to be valid');
64             }
65 30         70 my @parm_keys = keys %$parms;
66 30         58 foreach my $parm_name (@parm_keys) {
67 19         33 my $lc_parm_name = lc ($parm_name);
68 19 100       40 if (not exists $self->{$package}->{'settings'}->{$lc_parm_name}) {
69 6         29 require Carp;
70 6         744 Carp::croak('[' . localtime(time) . "] [error] $package" . "::new() - Passed parameter name '$parm_name' is not valid here");
71             }
72 13         25 $self->{$package}->{'settings'}->{$lc_parm_name} = $parms->{$parm_name};
73             }
74 24         57 $self->_decode_path_info;
75              
76 24         101 return $self;
77             }
78              
79             #######################################################################
80              
81             sub param {
82 28     28 1 279 my $self = shift;
83 28         33 my $package = __PACKAGE__;
84              
85 28 100       59 if (1 < @_) {
86 4         5 my $n_parms = @_;
87 4 100       11 if (($n_parms % 2) == 1) {
88 1         6 require Carp;
89 1         253 Carp::croak('[' . localtime(time) . "] [error] $package" . "::param() - Odd number of parameters passed");
90             }
91 3         15 my $parms = { @_ };
92 3         9 $self->_set($parms);
93 2         6 return;
94             }
95 24 100 100     85 if ((@_ == 1) and (ref ($_[0]) eq 'HASH')) {
96 1         2 my $parms = shift;
97 1         5 $self->_set($parms);
98 1         3 return;
99             }
100              
101 23         31 my @result = ();
102 23 100       63 if ($#_ == -1) {
103 8         15 @result = @{$self->{$package}->{'field_names'}};
  8         22  
104             } else {
105 15         21 my ($fieldname)=@_;
106 15 100       43 if (defined($self->{$package}->{'field'}->{$fieldname})) {
107 13         16 @result = @{$self->{$package}->{'field'}->{$fieldname}->{'value'}};
  13         27  
108             }
109             }
110              
111              
112 23 100       46 if (wantarray) {
113 17         48 return @result;
114             } else {
115 6         14 return $result[0];
116             }
117             }
118              
119             #######################################################################
120              
121             sub calling_parms_table {
122 2     2 1 9 my $self = shift;
123 2         2 my $package = __PACKAGE__;
124              
125 2         578 require HTML::Entities;
126              
127 2         5603 my $outputstring = "\n"; \n";
PATH_INFO Fields
FieldValue
128 2         6 my @field_list = $self->param;
129 2         8 foreach my $fieldname (sort @field_list) {
130 3         9 my @values = $self->param($fieldname);
131 3         5 my $sub_field_counter= $#values;
132 3         6 for (my $fieldn=0; $fieldn <= $sub_field_counter; $fieldn++) {
133 3         7 my $e_fieldname = HTML::Entities::encode_entities($fieldname);
134 3         42 my $fieldvalue = HTML::Entities::encode_entities($values[$fieldn]);
135 3         46 $outputstring .= "
$e_fieldname (#$fieldn) $fieldvalue
136             }
137             }
138              
139 2         4 $outputstring .= "
\n";
140              
141 2         17 return $outputstring;
142             }
143              
144             #######################################################################
145              
146             sub url_encode {
147 257     257 1 3698 my $self = shift;
148 257         309 my ($line) = @_;
149              
150 257 100       343 return '' if (! defined ($line));
151 256         513 $line =~ s/([^a-zA-Z0-9])/"\%".unpack("H",$1).unpack("h",$1)/egs;
  194         525  
152 256         499 return $line;
153             }
154              
155             #######################################################################
156              
157             sub url_decode {
158 358     358 1 1328 my $self = shift;
159 358         466 my ($line) = @_;
160              
161 358 100       490 return '' if (! defined ($line));
162 357         434 $line =~ s/\+/ /gos;
163 357         717 $line =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/egs;
  256         562  
164 357         653 return $line;
165             }
166              
167              
168             ########################################################################
169             # Performs PATH_INFO decoding
170              
171             sub _decode_path_info {
172 24     24   29 my $self = shift;
173 24         29 my $package = __PACKAGE__;
174              
175 24         29 my $buffer = '';
176 24 100       47 if (1 == $CGI::PathInfo::_mod_perl) {
    50          
177 10         27 $buffer = Apache->request->path_info;
178             } elsif (2 == $CGI::PathInfo::_mod_perl) {
179 0         0 $buffer = Apache2::RequestUtil->request->path_info;
180             } else {
181 14 100       45 $buffer = $ENV{'PATH_INFO'} if (defined $ENV{'PATH_INFO'});
182             }
183 24         138 $self->_burst_URL_encoded_buffer($buffer);
184              
185 24         31 return;
186             }
187              
188             ##########################################################################
189             # Bursts normal URL encoded buffers
190             # Takes: $buffer - the actual data to be burst
191             #
192             # parameters are presumed to be seperated by ';' characters
193             #
194              
195             sub _burst_URL_encoded_buffer {
196 24     24   31 my $self = shift;
197 24         50 my $package = __PACKAGE__;
198              
199 24         41 my ($buffer) = @_;
200 24         30 my $settings = $self->{$package}->{'settings'};
201 24 100       53 if ($settings->{'stripleadingslash'}) { $buffer =~ s#^/+##s; }
  20         119  
202 24 100       55 if ($settings->{'striptrailingslash'}) { $buffer =~ s#/+$##s; }
  20         51  
203              
204 24         31 my $spliton = $settings->{'spliton'};
205 24         31 my $eq_mark = $settings->{'eq'};
206              
207             # Split the name-value pairs on the selected split char
208 24         32 my @pairs = ();
209 24 100       49 if ($buffer) {
210 22         106 @pairs = split(/$spliton/, $buffer);
211             }
212              
213             # Initialize the field hash and the field_names array
214 24         60 $self->{$package}->{'field'} = {};
215 24         56 $self->{$package}->{'field_names'} = [];
216              
217 24         39 foreach my $pair (@pairs) {
218 74         186 my ($name, $data) = split(/$eq_mark/,$pair,2);
219              
220             # Anything that didn't split is omitted from the output
221 74 100       148 next if (not defined $data);
222              
223             # De-URL encode %-encoding
224 50         81 $name = $self->url_decode($name);
225 50         71 $data = $self->url_decode($data);
226              
227 50 100       131 if (! defined ($self->{$package}->{'field'}->{$name}->{'count'})) {
228 44         47 push (@{$self->{$package}->{'field_names'}},$name);
  44         80  
229 44         82 $self->{$package}->{'field'}->{$name}->{'count'} = 0;
230             }
231 50         72 my $record = $self->{$package}->{'field'}->{$name};
232 50         54 my $field_count = $record->{'count'};
233 50         50 $record->{'count'}++;
234 50         110 $record->{'value'}->[$field_count] = $data;
235             }
236 24         48 return;
237             }
238              
239             ##################################################################
240             #
241             # Sets values into the object directly
242             # Pass an anon hash for name/value pairs. Values may be
243             # anon lists or simple strings
244             #
245             ##################################################################
246              
247             sub _set {
248 4     4   5 my $self = shift;
249 4         5 my $package = __PACKAGE__;
250              
251 4         8 my ($parms) = @_;
252 4         10 foreach my $name (keys %$parms) {
253 4         6 my $value = $parms->{$name};
254 4         5 my $data = [];
255 4         8 my $data_type = ref $value;
256 4 100       10 if (not $data_type) {
    100          
257 2         12 $data = [ $value ];
258             } elsif ($data_type eq 'ARRAY') {
259             # Shallow copy the anon array to prevent action at a distance
260 1         3 @$data = map {$_} @$value;
  2         4  
261             } else {
262 1         7 require Carp;
263 1         135 Carp::croak ('[' . localtime(time) . "] [error] $package" . "::_set() - Parameter '$name' has illegal data type of '$data_type'");
264             }
265              
266 3 100       17 if (! defined ($self->{$package}->{'field'}->{$name}->{'count'})) {
267 1         1 push (@{$self->{$package}->{'field_names'}},$name);
  1         3  
268             }
269 3         5 my $record = {};
270 3         8 $self->{$package}->{'field'}->{$name} = $record;
271 3         5 $record->{'count'} = @$data;
272 3         8 $record->{'value'} = $data;
273             }
274 3         4 return;
275             }
276              
277             ##########################################################################
278              
279             1;