File Coverage

blib/lib/HTML/Mason/Tools.pm
Criterion Covered Total %
statement 98 114 85.9
branch 34 58 58.6
condition n/a
subroutine 24 26 92.3
pod 12 14 85.7
total 168 212 79.2


line stmt bran cond sub pod time code
1             # Copyright (c) 1998-2005 by Jonathan Swartz. All rights reserved.
2             # This program is free software; you can redistribute it and/or modify it
3             # under the same terms as Perl itself.
4              
5             #
6             # Miscellaneous tools used by the other Mason modules. Some of these
7             # admittedly exist in better versions on CPAN but we rewrite them so
8             # as to minimize external package requirements.
9             #
10              
11             package HTML::Mason::Tools;
12             $HTML::Mason::Tools::VERSION = '1.58';
13 34     34   47016 use strict;
  34         69  
  34         851  
14 34     34   147 use warnings;
  34         56  
  34         707  
15              
16 34     34   144 use Cwd;
  34         55  
  34         1786  
17 34     34   170 use File::Spec;
  34         56  
  34         881  
18 34     34   9869 use HTML::Mason::Exceptions( abbr => [qw(system_error param_error error)] );
  34         93  
  34         261  
19              
20             require Exporter;
21              
22 34     34   228 use vars qw(@ISA @EXPORT_OK);
  34         73  
  34         3535  
23              
24             @ISA = qw(Exporter);
25             @EXPORT_OK = qw(can_weaken read_file read_file_ref url_escape paths_eq compress_path mason_canonpath taint_is_on load_pkg pkg_loaded absolute_comp_path checksum);
26              
27             # Is weaken available? Even under 5.6+, it might not be available on systems w/o a compiler.
28             #
29             BEGIN
30 0         0 {
31 34     34   232 require Scalar::Util;
32              
33 34 50       22921 my $can_weaken = defined &Scalar::Util::weaken ? 1 : 0;
34              
35 871     871 0 4052 sub can_weaken () { $can_weaken }
36             }
37              
38             # read_file($file, $binmode)
39             # Return contents of file. If $binmode is 1, read in binary mode.
40             #
41             sub read_file
42             {
43 6     6 1 93 my $fh = _get_reading_handle(@_);
44 6         13 return do {local $/; scalar <$fh>};
  6         33  
  6         201  
45             }
46              
47              
48             # This routine is just like read_file, except more memory-efficient
49             # and better for large files. Probably not quite as fast.
50             #
51             # Using read_file_ref(), I have verified (in 5.6.1, anyway) that
52             # reading a file consumes only about as much memory as the size of the
53             # file. Using read_file() uses 2x the size of the file.
54             #
55             # Don't go using read() willy-nilly, though, it's usually not worth
56             # the potential bugs. It's easy to mess up the logic.
57              
58             sub read_file_ref
59             {
60 531     531 0 1641 my $fh = _get_reading_handle(@_);
61 531         1505 my ($buffer, $retval) = ('');
62 531         878 while (1) {
63             # Important to read in chunks - 16KB is a good compromise
64             # between not bloating memory usage and not calling read many
65             # times for small files
66 1053         16788 $retval = read $fh, $buffer, 1024 * 16, length($buffer);
67 1053 50       2690 system_error "read_file_ref: Couldn't read from '$_[0]': $!"
68             unless defined $retval;
69 1053 100       2129 last if !$retval;
70             }
71 531         5086 return \$buffer;
72             }
73              
74             sub _get_reading_handle {
75 537     537   1343 my ($file,$binmode) = @_;
76 537 50       5334 error "read_file: '$file' does not exist" unless -e $file;
77 537 50       1517 error "read_file: '$file' is a directory" if (-d _);
78 537 50       10370 open my $fh, "< $file"
79             or system_error "read_file: could not open file '$file' for reading: $!";
80 537 100       1711 binmode $fh if $binmode;
81 537         1408 return $fh;
82             }
83              
84             #
85             # Determines whether two paths are equal, taking into account
86             # case-insensitivity in Windows O/S.
87             #
88             sub paths_eq {
89 0 0   0 1 0 return File::Spec->case_tolerant ? (lc($_[0]) eq lc($_[1])) : $_[0] eq $_[1];
90             }
91              
92             #
93             # Compress a component path into a single, filesystem-friendly
94             # string. Uses URL-like escaping with + instead of %.
95             #
96             sub compress_path
97             {
98 82     82 1 168 my ($path) = @_;
99 82         171 for ($path) {
100 82         412 s@^/@@;
101 82         427 s/([^\w\.\-\~])/sprintf('+%02x', ord $1)/eg;
  124         802  
102             }
103 82         378 return $path;
104             }
105              
106             #
107             # Return the absolute version of a component path. Handles . and ..
108             # Second argument is directory path to resolve relative paths against.
109             #
110             sub absolute_comp_path
111             {
112 649     649 1 1642 my ($comp_path, $dir_path) = @_;
113              
114 649 100       2906 $comp_path = "$dir_path/$comp_path" if $comp_path !~ m@^/@;
115 649         1611 return mason_canonpath($comp_path);
116             }
117              
118              
119             #
120             # Makes a few fixes to File::Spec::canonpath. Will go away if/when they
121             # accept our patch.
122             #
123             sub mason_canonpath {
124             # Just like File::Spec::canonpath, but we're having trouble
125             # getting a patch through to them.
126 649     649 1 1332 my $path = shift;
127 649         4984 $path =~ s|/+|/|g; # xx////yy -> xx/yy
128 649         1937 $path =~ s|(?:/\.)+/|/|g; # xx/././yy -> xx/yy
129             {
130 649 50       1142 $path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx
  666         1816  
131 666         1253 $path =~ s|^/(?:\.\./)+|/|s; # /../../xx -> xx
132 666 50       1585 $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx
133 666 50       1620 $path =~ s|/[^/]+/\.\.$|| && redo; # /xx/.. -> /
134 666 100       1817 $path =~ s|[^/]+/\.\./|| && redo; # /xx/../yy -> /yy
135             }
136 649         2164 return $path;
137             }
138              
139             #
140             # Determine if package is installed without loading it, by checking
141             # the INC path.
142             #
143             sub pkg_installed
144             {
145 0     0 1 0 my ($pkg) = @_;
146              
147 0         0 (my $pkgfile = "$pkg.pm") =~ s{::}{/}g;
148 0         0 return grep(-f "$_/$pkgfile",@INC);
149             }
150              
151             #
152             # Determined if package is loaded by checking for its version.
153             #
154             sub pkg_loaded
155             {
156 84     84 1 188 my ($pkg) = @_;
157              
158 84         161 my $varname = "${pkg}::VERSION";
159 34     34   248 no strict 'refs';
  34         97  
  34         16772  
160 84 100       494 return $$varname ? 1 : 0;
161             }
162              
163             #
164             # Load package $pkg if not already loaded. Return 1 if file was found
165             # and loaded successfully. When file is not found: if optional second
166             # argument $nf_error is provided, die with that error message,
167             # otherwise return 0. Errors while loading the package are always
168             # passed through as fatal errors.
169             #
170             sub load_pkg {
171 11     11 1 112 my ($pkg, $nf_error) = @_;
172              
173 11         267 my $file = File::Spec->catfile( split /::/, $pkg );
174 11         45 $file .= '.pm';
175 11 100       55 return 1 if exists $INC{$file};
176              
177 4     3   343 eval "use $pkg";
  3     1   1277  
  2         1955  
  2         85  
  1         476  
  1         26987  
  1         266  
178              
179 4 100       188 if ($@) {
180 1 50       9 if ($@ =~ /^Can\'t locate (.*) in \@INC/) {
181 1 50       3 if (defined($nf_error)) {
182 1         12 error sprintf("Can't locate %s in \@INC. %s\n(\@INC contains: %s)",
183             $1, $nf_error, join(" ", @INC));
184             } else {
185 0         0 undef $@;
186 0         0 return 0;
187             }
188             } else {
189 0         0 error $@;
190             }
191             }
192 3         127 return 1;
193             }
194              
195             # This code seems to be very fragile! Please don't check in changes
196             # unless you've tested it with Perl 5.00503, 5.6.1, and 5.8.0, or at
197             # least tell Dave to run the tests.
198             my $TaintIsOn;
199             sub taint_is_on
200             {
201 1094 100   1094 1 4575 return $TaintIsOn if defined $TaintIsOn;
202 29         100 return $TaintIsOn = _taint_is_on();
203             }
204              
205             sub _taint_is_on
206             {
207 29 50   29   194 if ( $] >= 5.008 )
208             {
209             # We have to eval a string because this variable name causes
210             # earlier Perls to not compile at all.
211 29 100       2552 return eval '${^TAINT}' ? 1 : 0;
212             }
213             else
214             {
215 0         0 local $^W;
216 0 0       0 eval { "+$0$^X" && eval 1 };
  0         0  
217 0 0       0 return $@ ? 1 : 0;
218             }
219             }
220              
221             sub coerce_to_array
222             {
223 5     5 1 16 my ($val, $name) = @_;
224              
225 5 50       17 return ($val) unless ref $val;
226              
227 5 50       19 if ( UNIVERSAL::isa( $val, 'ARRAY' ) )
    0          
228             {
229 5         23 return @$val;
230             }
231             elsif ( UNIVERSAL::isa( $val, 'HASH' ) )
232             {
233 0         0 return %$val;
234             }
235              
236 0         0 param_error "Cannot coerce $val to an array for '$name' parameter";
237             }
238              
239             sub coerce_to_hash
240             {
241 2     2 1 5 my ($val, $name) = @_;
242              
243 2 50       4 param_error "Cannot convert a single value to a hash for '$name' parameter"
244             unless ref $val;
245              
246 2 50       8 if ( UNIVERSAL::isa( $val, 'ARRAY' ) )
    50          
247             {
248 0         0 return @$val;
249             }
250             elsif ( UNIVERSAL::isa( $val, 'HASH' ) )
251             {
252 2         8 return %$val;
253             }
254              
255 0         0 param_error "Cannot coerce $val to a hash";
256             }
257              
258             # Adler32 algorithm
259             sub checksum {
260 391     391 1 1244 my ($str) = @_;
261            
262 391         759 my $s1 = 1;
263 391         598 my $s2 = 1;
264 391         11238 for my $c (unpack("C*", $str)) {
265 286432         319810 $s1 = ($s1 + $c ) % 65521;
266 286432         347034 $s2 = ($s2 + $s1) % 65521;
267             }
268 391         9115 return ($s2 << 16) + $s1;
269             }
270              
271             1;
272              
273             __END__