File Coverage

blib/lib/HTTP/DAV/Utils.pm
Criterion Covered Total %
statement 39 126 30.9
branch 7 38 18.4
condition 2 14 14.2
subroutine 5 17 29.4
pod 0 15 0.0
total 53 210 25.2


line stmt bran cond sub pod time code
1             package HTTP::DAV::Utils;
2              
3 5     5   976 use strict;
  5         6  
  5         152  
4 5     5   18 use vars qw($VERSION);
  5         5  
  5         5133  
5              
6             $VERSION = '0.11';
7              
8             ###########################################################################
9             # Borrowed from Lincoln Stein's CGI.pm
10             # Smart rearrangement of parameters to allow named parameter
11             # calling. We do the rearangement if:
12             # 1. The first parameter begins with a -
13             # 2. The use_named_parameters() method returns true
14             sub rearrange {
15 1     1 0 1 my($order,@param) = @_;
16 1 50       2 return () unless @param;
17              
18             # IF the user has passed a hashref instead of a hash then flatten it out.
19 1 50       3 if (ref($param[0]) eq 'HASH') {
20 0         0 @param = %{$param[0]};
  0         0  
21             } else {
22             # If the user has specified that they will be explicitly
23             # using named_parameters (by setting &use_named_parameters(1))
24             # or the first parameter starts with a -, then continue.
25             # Otherwise just return the parameters as they were given to us.
26             return @param
27 1 50 33     10 unless (defined($param[0]) && substr($param[0],0,1) eq '-')
      33        
28             || &use_named_parameters();
29             }
30              
31             # map parameters into positional indices
32 1         1 my ($i,%pos);
33 1         1 $i = 0;
34 1         2 foreach (@$order) {
35 2 50       4 foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; }
  2         5  
36 2         1 $i++;
37             }
38              
39 1         2 my (@result,%leftover);
40 1         3 $#result = $#$order; # preextend
41 1         3 while (@param) {
42 1         2 my $key = uc(shift(@param));
43 1         4 $key =~ s/^\-//;
44 1 50       2 if (exists $pos{$key}) {
45 1         2 $result[$pos{$key}] = shift(@param);
46             } else {
47 0         0 $leftover{$key} = shift(@param);
48             }
49             }
50              
51 1 50       2 push (@result,&make_attributes(\%leftover)) if %leftover;
52 1         4 @result;
53             }
54              
55             #### Method: use_named_parameters
56             # Borrowed from Lincoln Stein's CGI.pm
57             # Force DAV.pm to use named parameter-style method calls
58             # rather than positional parameters. The same effect
59             # will happen automatically if the first parameter
60             # begins with a -.
61             my $named=0;
62             sub use_named_parameters {
63 0     0 0 0 my($use_named) = shift;
64 0 0       0 return $named unless defined ($use_named);
65              
66             # stupidity to avoid annoying warnings
67 0         0 return $named = $use_named;
68             }
69              
70             # Borrowed from Lincoln Stein's CGI.pm
71             sub make_attributes {
72 0     0 0 0 my($attr) = @_;
73 0 0 0     0 return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
      0        
74 0         0 my(@att);
75 0         0 foreach (keys %{$attr}) {
  0         0  
76 0         0 my($key) = $_;
77 0         0 $key=~s/^\-//; # get rid of initial - if present
78 0         0 $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
79 0 0       0 push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/);
80             }
81 0         0 return @att;
82             }
83              
84             ###########################################################################
85             sub bad {
86 0     0 0 0 my($str) = @_;
87 0         0 print STDERR "Error: $str\n";
88 0         0 exit;
89             }
90              
91             sub bad_node {
92 0     0 0 0 my($node,$str) = @_;
93 0         0 print STDERR "XML error in " . $node->getNodeName . ": $str";
94 0         0 print STDERR "\n";
95 0         0 print STDERR "DUMP:\n";
96 0 0       0 print STDERR $node->toString if $node;
97 0         0 exit;
98             }
99              
100             ###########################################################################
101             # This method searches for any text-based data in the children of
102             # the node supplied. It will croak if the node has anything other
103             # than text values (such as Elements or Comments).
104             sub get_only_cdata {
105 0     0 0 0 my($node) = @_;
106 0         0 my $return_cdata = "";
107 0         0 my $nodes = $node->getChildNodes();
108 0         0 my $n = $nodes->getLength;
109 0         0 for (my $i = 0; $i < $n; $i++) {
110 0         0 my $node = $nodes->item($i);
111 0 0       0 if ( $node->getNodeTypeName eq "TEXT_NODE" ) {
112 0         0 $return_cdata .= $node->getNodeValue;
113             } else {
114             #bad_node($node, "node has non TEXT children");
115             }
116             }
117              
118 0         0 return $return_cdata;
119             }
120              
121              
122             # This is a sibling to the XML::DOM's getElementsByTagName().
123             # The main difference here is that it ignores the namespace
124             # component of the element. This was done because it
125             # Takes a node and returns a list of nodes.
126             # Note that the real getElementsByTagName allows you to
127             # specify recurse or not. This routine doesn't allow recurse.
128             sub get_elements_by_tag_name {
129 0     0 0 0 my ($node, $elemname ) = @_;
130              
131 0 0       0 return unless $node;
132              
133 0         0 my @return_nodes;
134              
135             # This is gruesome. Because we don't yet support namespaces, it
136             # just lops off the first half of the Element name
137 0         0 $elemname =~ s/.*?:(.*)$/$1/g;
138              
139 0         0 my $nodelist = $node->getChildNodes();
140 0         0 my $length = $nodelist->getLength();
141 0         0 for ( my $i=0; $i < $length; $i++ ) {
142 0         0 my $node = $nodelist->item($i);
143             # Debian change?
144 0 0       0 if ( $node->getNodeName() =~ /(?:^|:)$elemname$/ ) {
145 0         0 push(@return_nodes,$node);
146             }
147             }
148              
149 0         0 return @return_nodes;
150             }
151              
152             sub get_only_element {
153 0     0 0 0 my($node,$elemname) = @_;
154              
155 0 0       0 return unless $node;
156              
157             # Find the one child element of a specific name
158 0 0       0 if ( $elemname ) {
159              
160             # This is gruesome. Because we don't yet support namespaces, it
161             # just lops off the first half of the Element name.
162 0         0 $elemname =~ s/.*?:(.*)$/$1/g;
163              
164             #my $nodes = $node->getElementsByTagName($elemname,0);
165 0         0 my $nodelist = $node->getChildNodes();
166 0         0 my $length = $nodelist->getLength();
167 0         0 for ( my $i=0; $i < $length; $i++ ) {
168 0         0 my $node = $nodelist->item($i);
169 0 0       0 return $node if $node->getNodeName() =~ /$elemname/;
170             }
171              
172             # if ( $nodes->getLength > 1 ) {
173             # bad_node($node, "Too many \"$elemname\" in node");
174             # } elsif ( $nodes->getLength < 1 ) {
175             # return;
176             # #bad_node($node, "No node found matching \"$elemname\" in node");
177             # }
178             # return $nodes->item(0);
179              
180             # Just get the first child element.
181             } else {
182 0         0 my $nodelist = $node->getChildNodes();
183 0         0 my $length = $nodelist->getLength();
184 0         0 for ( my $i=0; $i < $length; $i++ ) {
185 0         0 my $node = $nodelist->item($i);
186 0 0       0 if ($node->getNodeTypeName eq "ELEMENT_NODE" ) {
187 0         0 return $nodelist->item($i);
188             }
189             }
190             }
191             }
192              
193             ###########################################################################
194             sub XML_remove_namespace {
195             #print "XML: $_[0] -> ";
196 0     0 0 0 $_[0] =~ s/.*?:(.*)/$1/g;
197             #$_[0] =~ s/(.*?)\s.*/$1/g;
198             #print "$_[0]\n";
199 0         0 return $_[0];
200             }
201              
202             ###########################################################################
203             sub make_uri {
204 8     8 0 10 my $uri = shift;
205 8 50       13 if (ref($uri) =~ /URI/) {
206 0         0 $uri = $uri->as_string;
207             }
208             # Remove double slashes from the url
209 8         21 $uri = URI->new($uri);
210 8         5332 my $path = $uri->path;
211 8         123 $path =~ s{//}{/}g;
212             #print "make_uri: $uri->$path\n";
213 8         11 $uri->path($path);
214             #print "make_uri: $uri\n";
215 8         113 return $uri;
216             }
217              
218             sub make_trail_slash {
219 0     0 0 0 my ($uri) = @_;
220 0         0 $uri =~ s{/*$}{}g;
221 0         0 $uri .= '/';
222 0         0 return $uri;
223             }
224              
225             sub compare_uris {
226 4     4 0 3238 my ($uri1,$uri2) = @_;
227              
228 4         5 for ($uri1, $uri2) {
229 8         11 $_ = make_uri($_);
230 8         14 s{/$}{};
231 8         56 s{(%[0-9a-fA-F][0-9a-fA-F])}{lc $1}eg;
  8         28  
232             }
233              
234 4         15 return $uri1 eq $uri2;
235             }
236              
237             # This subroutine takes a URI and gets the last portion
238             # of it: the filename.
239             # e.g. /dir1/dir2/file.txt => file.txt
240             # /dir1/dir2/ => dir2
241             # / => undef
242             sub get_leafname {
243 0     0 0   my($url) = shift;
244 0           my $leaf;
245 0           ($url,$leaf) = &split_leaf($url);
246 0           return $leaf;
247             }
248              
249             # This subroutine takes a URI and splits the leaf from the path.
250             # It returns both.
251             # of it: the filename.
252             # e.g. /dir1/dir2/file.txt => file.txt
253             # /dir1/dir2/ => dir2
254             # / => undef
255             sub split_leaf {
256 0     0 0   my($url) = shift;
257 0           $url =~ s#[\/\\]$##; #Remove trailing slashes.
258 0           $url = HTTP::DAV::Utils::make_uri($url);
259              
260             # Remove the leaf from the path.
261 0           my $path = $url->path_query();
262 0           my @path = split(/[\/\\]+/,$path);
263 0   0       my $leaf = pop @path || "";
264 0           $path = join('/',@path);
265              
266             #Now put the path back into the URL.
267 0           $url->path_query($path);
268              
269 0           return ($url,$leaf);
270             }
271              
272             # Turns a file-oriented glob
273             # into a regular expression.
274             # BTW, I recommend you eval any regex command you use on
275             # this outputted regex value.
276             # If somebody types uses an incorrect glob and you try to /$regex/ it
277             # then perl will bomb with a fatal regex error.
278             # For instance, /file[ab.txt/ would bomb.
279             sub glob2regex {
280 0     0 0   my($f) = @_;
281             # Turn the leafname glob into a regex.
282             # Substitute \ for \\
283             # Substitute . for \.
284             # Substitute * for .*
285             # Substitute ? for .
286             # No need to substitute [...]
287 0           $f =~ s/\\/\\\\/g;
288 0           $f =~ s/\./\\./g;
289 0           $f =~ s/\*/.*/g;
290 0           $f =~ s/\?/./g;
291 0 0         print "Glob regex becomes $f\n" if $HTTP::DAV::DEBUG>1;
292 0           return $f;
293             }
294              
295             1;