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.60'; |
7
|
33
|
|
|
33
|
|
65596
|
use strict; |
|
33
|
|
|
|
|
94
|
|
|
33
|
|
|
|
|
1005
|
|
8
|
33
|
|
|
33
|
|
176
|
use warnings; |
|
33
|
|
|
|
|
71
|
|
|
33
|
|
|
|
|
886
|
|
9
|
|
|
|
|
|
|
|
10
|
33
|
|
|
33
|
|
184
|
use Cwd; |
|
33
|
|
|
|
|
72
|
|
|
33
|
|
|
|
|
2164
|
|
11
|
|
|
|
|
|
|
|
12
|
33
|
|
|
33
|
|
286
|
use File::Glob; |
|
33
|
|
|
|
|
76
|
|
|
33
|
|
|
|
|
2344
|
|
13
|
33
|
|
|
33
|
|
221
|
use File::Spec; |
|
33
|
|
|
|
|
108
|
|
|
33
|
|
|
|
|
1027
|
|
14
|
33
|
|
|
33
|
|
670
|
use HTML::Mason::Tools qw(read_file_ref paths_eq); |
|
33
|
|
|
|
|
98
|
|
|
33
|
|
|
|
|
1928
|
|
15
|
33
|
|
|
33
|
|
250
|
use Params::Validate qw(:all); |
|
33
|
|
|
|
|
74
|
|
|
33
|
|
|
|
|
5340
|
|
16
|
|
|
|
|
|
|
|
17
|
33
|
|
|
33
|
|
15894
|
use HTML::Mason::ComponentSource; |
|
33
|
|
|
|
|
95
|
|
|
33
|
|
|
|
|
1009
|
|
18
|
33
|
|
|
33
|
|
13570
|
use HTML::Mason::Resolver; |
|
33
|
|
|
|
|
89
|
|
|
33
|
|
|
|
|
926
|
|
19
|
33
|
|
|
33
|
|
222
|
use base qw(HTML::Mason::Resolver); |
|
33
|
|
|
|
|
120
|
|
|
33
|
|
|
|
|
2980
|
|
20
|
|
|
|
|
|
|
|
21
|
33
|
|
|
33
|
|
224
|
use HTML::Mason::Exceptions (abbr => ['param_error']); |
|
33
|
|
|
|
|
64
|
|
|
33
|
|
|
|
|
1537
|
|
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
sub get_info { |
24
|
2278
|
|
|
2278
|
1
|
6073
|
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
|
|
|
|
|
23959
|
my $srcfile = File::Spec->canonpath( File::Spec->catfile( $comp_root_path, $path ) ); |
33
|
2278
|
100
|
|
|
|
42522
|
return unless -f $srcfile; |
34
|
1130
|
|
|
|
|
4491
|
my $modified = (stat _)[9]; |
35
|
1130
|
100
|
|
|
|
3491
|
my $base = $comp_root_key eq 'MAIN' ? '' : "/$comp_root_key"; |
36
|
1130
|
100
|
|
|
|
2814
|
$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
|
|
1792
|
source_callback => sub { read_file_ref($srcfile) }, |
47
|
1130
|
|
|
|
|
12384
|
); |
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
|
8
|
my ($self, $pattern, $comp_root_path) = @_; |
56
|
|
|
|
|
|
|
|
57
|
3
|
|
|
|
|
372
|
my @files = File::Glob::bsd_glob($comp_root_path . $pattern); |
58
|
3
|
|
|
|
|
12
|
my $root_length = length $comp_root_path; |
59
|
3
|
|
|
|
|
7
|
my @paths; |
60
|
3
|
|
|
|
|
11
|
foreach my $file (@files) { |
61
|
7
|
100
|
|
|
|
86
|
next unless -f $file; |
62
|
6
|
50
|
|
|
|
23
|
if (substr($file, 0, $root_length) eq $comp_root_path) { |
63
|
6
|
|
|
|
|
21
|
push(@paths, substr($file, $root_length)); |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
} |
66
|
3
|
|
|
|
|
17
|
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__ |