1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
package Apache::RegistryLoader;
use 5.003_97;
use mod_perl 1.01;
use strict;
use Apache::Registry ();
use Apache::Constants qw(OPT_EXECCGI);
@Apache::RegistryLoader::ISA = qw(Apache::Registry);
$Apache::RegistryLoader::VERSION = '1.91';
sub new {
my $class = shift;
bless {@_} => $class;
}
sub handler {
my($self, $uri, $filename, $virthost) = @_;
Apache::warn(__PACKAGE__.qq{ failed, reason: uri is a required parameter}),
return
unless defined $uri and $uri;
if ($filename) {
Apache::warn(__PACKAGE__.qq{: Cannot find a filename [$filename]}),
return
unless -e $filename;
} else {
# try to translate URI->filename
if (my $func = $self->{trans}) {
no strict 'refs';
$filename = &{$func}($uri);
Apache::warn(__PACKAGE__.
qq{: Translation of uri [$uri] to filename failed [tried: $filename]}),
return
unless -e $filename;
} else {
# try to guess
(my $guess = $uri) =~ s,^/,,;
$filename = Apache->server_root_relative($guess);
Apache::warn(__PACKAGE__.
qq{: No 'trans' sub was passed: tried to guess the filename [tried: $filename], but failed, for uri [$uri]}),
return
unless -e $filename;
}
}
# warn "*** RegistryLoader: uri=$uri, filename=$filename\n";
my $r = bless {
uri => $uri,
filename => $filename,
} => ref($self) || $self;
$r->{virthost} = $virthost if defined $virthost;
$r->SUPER::handler;
}
#override Apache class methods called by Apache::Registry
#normally only available at request-time via blessed request_rec pointer
sub slurp_filename {
my $r = shift;
my $filename = $r->filename;
my $fh = Apache::gensym(__PACKAGE__);
open $fh, $filename;
local $/;
my $code = <$fh>;
return \$code;
}
sub get_server_name { shift->{virthost} }
sub filename { shift->{filename} }
sub uri { shift->{uri} }
sub status {200}
sub path_info {}
sub log_error { shift; die @_ if $@; warn @_; }
*log_reason = \&log_error;
sub allow_options { OPT_EXECCGI } #will be checked again at run-time
sub clear_rgy_endav {}
sub stash_rgy_endav {}
sub request {}
sub seqno {0}
sub server { shift }
sub is_virtual { exists shift->{virthost} }
sub header_out {""}
sub chdir_file {
my($r, $file) = @_;
$file ||= $r->filename;
Apache::chdir_file(undef, $file);
}
1;
__END__
=head1 NAME
Apache::RegistryLoader - Compile Apache::Registry scripts at server startup
=head1 SYNOPSIS
#in PerlScript
use Apache::RegistryLoader ();
my $r = Apache::RegistryLoader->new;
$r->handler($uri, $filename);
$r->handler($uri, $filename, $virtual_hostname);
=head1 DESCRIPTION
This modules allows compilation of B<Apache::Registry> scripts at
server startup. The script's handler routine is compiled by the
parent server, of which children get a copy. The
B<Apache::RegistryLoader> C<handler> method takes arguments of C<uri>
and the C<filename>. URI to filename translation normally doesn't
happen until HTTP request time, so we're forced to roll our own
translation.
If filename is omitted and a C<trans> routine was not
defined, the loader will try using the B<uri> relative to
B<ServerRoot>. Example:
#in httpd.conf
ServerRoot /opt/www/apache
Alias /perl/ /opt/www/apache/perl
#in PerlScript
use Apache::RegistryLoader ();
#/opt/www/apache/perl/test.pl
#is the script loaded from disk here:
Apache::RegistryLoader->new->handler("/perl/test.pl");
To make the loader smarter about the uri->filename translation, you may
provide the C<new> method with a C<trans> function to translate the
uri to filename.
The following example will pre-load all files ending with C<.pl> in the
B<perl-scripts/> directory relative to B<ServerRoot>.
The example code assumes the Location URI C</perl> is an B<Alias> to
this directory.
{
use Cwd ();
use Apache::RegistryLoader ();
use DirHandle ();
use strict;
my $dir = Apache->server_root_relative("perl-scripts/");
my $rl = Apache::RegistryLoader->new(trans => sub {
my $uri = shift;
$uri =~ s:^/perl/:/perl-scripts/:;
return Apache->server_root_relative($uri);
});
my $dh = DirHandle->new($dir) or die $!;
for my $file ($dh->read) {
next unless $file =~ /\.pl$/;
$rl->handler("/perl/$file");
}
}
=head1 AUTHORS
Doug MacEachern
Stas Bekman (Rewrote the handler() to report and handle all the possible
erroneous conditions)
=head1 SEE ALSO
Apache::Registry(3), Apache(3), mod_perl(3)
|
