File Coverage

blib/lib/HTML/Mason/Resolver/File.pm
Criterion Covered Total %
statement 50 61 81.9
branch 9 18 50.0
condition 0 3 0.0
subroutine 14 15 93.3
pod 3 3 100.0
total 76 100 76.0


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
3             # it under the same terms as Perl itself.
4              
5             package HTML::Mason::Resolver::File;
6             $HTML::Mason::Resolver::File::VERSION = '1.58';
7 33     33   44154 use strict;
  33         78  
  33         912  
8 33     33   160 use warnings;
  33         60  
  33         982  
9              
10 33     33   156 use Cwd;
  33         68  
  33         1959  
11              
12 33     33   181 use File::Glob;
  33         76  
  33         1654  
13 33     33   176 use File::Spec;
  33         75  
  33         744  
14 33     33   401 use HTML::Mason::Tools qw(read_file_ref paths_eq);
  33         61  
  33         1570  
15 33     33   201 use Params::Validate qw(:all);
  33         65  
  33         4905  
16              
17 33     33   8758 use HTML::Mason::ComponentSource;
  33         81  
  33         845  
18 33     33   8650 use HTML::Mason::Resolver;
  33         82  
  33         819  
19 33     33   184 use base qw(HTML::Mason::Resolver);
  33         77  
  33         2646  
20              
21 33     33   191 use HTML::Mason::Exceptions (abbr => ['param_error']);
  33         58  
  33         138  
22              
23             sub get_info {
24 2278     2278 1 6045 my ($self, $path, $comp_root_key, $comp_root_path) = @_;
25              
26             # Note that canonpath has the property of not collapsing a series
27             # of /../../ dirs in an unsafe way. This means that if the
28             # component path is /../../../../etc/passwd, we're still safe. I
29             # don't know if this was intentional, but it's certainly a good
30             # thing, and something we want to preserve if the code ever
31             # changes.
32 2278         23654 my $srcfile = File::Spec->canonpath( File::Spec->catfile( $comp_root_path, $path ) );
33 2278 100       31854 return unless -f $srcfile;
34 1130         3773 my $modified = (stat _)[9];
35 1130 100       3525 my $base = $comp_root_key eq 'MAIN' ? '' : "/$comp_root_key";
36 1130 100       3079 $comp_root_key = undef if $comp_root_key eq 'MAIN';
37              
38             return
39             HTML::Mason::ComponentSource->new
40             ( friendly_name => $srcfile,
41             comp_id => "$base$path",
42             last_modified => $modified,
43             comp_path => $path,
44             comp_class => 'HTML::Mason::Component::FileBased',
45             extra => { comp_root => $comp_root_key },
46 531     531   1789 source_callback => sub { read_file_ref($srcfile) },
47 1130         11648 );
48             }
49              
50             #
51             # Return all existing url_paths matching the given glob pattern underneath the given root.
52             # glob_path is required for using the "preloads" parameter.
53             #
54             sub glob_path {
55 3     3 1 9 my ($self, $pattern, $comp_root_path) = @_;
56              
57 3         248 my @files = File::Glob::bsd_glob($comp_root_path . $pattern);
58 3         10 my $root_length = length $comp_root_path;
59 3         6 my @paths;
60 3         12 foreach my $file (@files) {
61 7 100       47 next unless -f $file;
62 6 50       19 if (substr($file, 0, $root_length) eq $comp_root_path) {
63 6         17 push(@paths, substr($file, $root_length));
64             }
65             }
66 3         12 return @paths;
67             }
68              
69             #
70             # Given an apache request object and a list of component root pairs,
71             # return the associated component path or undef if none exists. This
72             # is called for top-level web requests that resolve to a particular
73             # file.
74             # apache_request_to_comp_path is required for running Mason under mod_perl.
75             #
76             sub apache_request_to_comp_path {
77 0     0 1   my ($self, $r, @comp_root_array) = @_;
78              
79 0           my $file = $r->filename;
80 0 0         $file .= $r->path_info unless -f $file;
81              
82             # Clear up any weirdness here so that paths_eq compares two
83             # 'canonical' paths (canonpath is called on comp roots when
84             # resolver object is created. Seems to be needed on Win32 (see
85             # bug #356).
86 0           $file = File::Spec->canonpath($file);
87              
88 0           foreach my $root (map $_->[1], @comp_root_array) {
89 0 0         if (paths_eq($root, substr($file, 0, length($root)))) {
90 0           my $path = substr($file, length $root);
91 0 0         $path = length $path ? join '/', File::Spec->splitdir($path) : '/';
92 0 0 0       chop $path if $path ne '/' && substr($path, -1) eq '/';
93              
94 0           return $path;
95             }
96             }
97 0           return undef;
98             }
99              
100              
101             1;
102              
103             __END__