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
|
package Apache::PerlRunFilter;
use strict;
use Apache::PerlRun;
use Apache::Constants qw(:common);
use Symbol;
use vars qw($Debug @ISA);
@ISA = qw(Apache::PerlRun);
sub readscript {
my $pr = shift;
my $fh = $pr->{'fh'};
local $/;
return $pr->{'code'} = \(scalar <$fh>);
}
sub handler {
my ($package, $r) = @_;
($package, $r) = (__PACKAGE__, $package) unless $r;
my $pr = $package->new($r);
my $rc = $pr->can_compile;
return $rc unless $rc == OK;
# Get a filehandle to the Perl code
if (lc $r->dir_config('Filter') eq 'on') {
my ($fh, $status) = $r->filter_input();
return $status unless $status == OK;
$pr->{'fh'} = $fh;
} else {
$pr->{'fh'} = gensym;
open $pr->{'fh'}, $r->filename or die $!;
}
# After here is the same as PerlRun.pm...
my $package = $pr->namespace;
my $code = $pr->readscript;
$pr->parse_cmdline($code);
$pr->set_script_name;
$pr->chdir_file;
my $line = $pr->mark_line;
my %orig_inc = %INC;
my $eval = join '',
'package ',
$package,
';use Apache qw(exit);',
$line,
$$code,
"\n";
$rc = $pr->compile(\$eval);
$pr->chdir_file("$Apache::Server::CWD/");
#in case .pl files do not declare package ...;
for (keys %INC) {
next if $orig_inc{$_};
next if /\.pm$/;
delete $INC{$_};
}
if(my $opt = $r->dir_config("PerlRunOnce")) {
$r->child_terminate if lc($opt) eq "on";
}
{ #flush the namespace
no strict;
my $tab = \%{$package.'::'};
foreach (keys %$tab) {
if(defined &{$tab->{$_}}) {
undef_cv_if_owner($package, \&{$tab->{$_}});
}
}
%$tab = ();
}
return $rc;
}
sub undef_cv_if_owner {
return unless $INC{'B.pm'};
my($package, $cv) = @_;
my $obj = B::svref_2object($cv);
my $stash = $obj->GV->STASH->NAME;
return unless $package eq $stash;
undef &$cv;
}
1;
__END__
=head1 NAME
Apache::PerlRunFilter - run Perl scripts in an Apache::Filter chain
=head1 SYNOPSIS
#in httpd.conf
PerlModule Apache::PerlRunFilter
# Run the output of scripts through Apache::SSI
<Files ~ "\.pl$">
SetHandler perl-script
PerlHandler Apache::PerlRunFilter Apache::SSI
PerlSetVar Filter on
</Files>
# Generate some Perl code using templates, then execute it
<Files ~ "\.tmpl$">
SetHandler perl-script
PerlHandler YourModule::GenCode Apache::PerlRunFilter
PerlSetVar Filter on
</Files>
=head1 DESCRIPTION
This module is a subclass of Apache::PerlRun, and contains all of its
functionality. The only difference between the two is that this
module can be used in conjunction with the Apache::Filter module,
whereas Apache::PerlRun cannot.
It only takes a tiny little bit of code to make the filtering stuff
work, so perhaps it would be more appropriate for the code to be
integrated right into Apache::PerlRun. As it stands, I've had to
duplicate a bunch of PerlRun's code here (in the handler routine), so
bug fixes & feature changes must be made both places.
=head1 CAVEATS
Note that this is not an exact replacement for Apache::Registry - it
doesn't do any of the code-caching stuff that Registry does. It
shouldn't be too hard a task, but for now Registry is still based on
old code, and Doug's plan is to make future versions of Registry by
subclassing PerlRun (see Apache::RegistryNG). Since this is the case,
I figured I'd hold off on doing any Registry work until things have
moved forward a bit.
=head1 SEE ALSO
perl(1), mod_perl(3), Apache::PerlRun(3)
=head1 AUTHOR
Ken Williams <ken@forum.swarthmore.edu>
=cut
|
