line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package CatalystX::ASP; |
2
|
|
|
|
|
|
|
|
3
|
9
|
|
|
9
|
|
3921431
|
use namespace::autoclean; |
|
9
|
|
|
|
|
36853
|
|
|
9
|
|
|
|
|
36
|
|
4
|
9
|
|
|
9
|
|
1020
|
use Moose; |
|
9
|
|
|
|
|
381234
|
|
|
9
|
|
|
|
|
69
|
|
5
|
9
|
|
|
9
|
|
62844
|
use Moose::Util::TypeConstraints; |
|
9
|
|
|
|
|
26
|
|
|
9
|
|
|
|
|
90
|
|
6
|
9
|
|
|
9
|
|
23971
|
use MooseX::Types::Path::Tiny qw(Path Paths); |
|
9
|
|
|
|
|
3685269
|
|
|
9
|
|
|
|
|
90
|
|
7
|
9
|
|
|
9
|
|
23811
|
use Scalar::Util qw(blessed); |
|
9
|
|
|
|
|
23
|
|
|
9
|
|
|
|
|
530
|
|
8
|
9
|
|
|
9
|
|
55
|
use Path::Tiny; |
|
9
|
|
|
|
|
17
|
|
|
9
|
|
|
|
|
443
|
|
9
|
9
|
|
|
9
|
|
53
|
use Module::Runtime qw(require_module); |
|
9
|
|
|
|
|
18
|
|
|
9
|
|
|
|
|
67
|
|
10
|
9
|
|
|
9
|
|
429
|
use Digest::MD5 qw(md5_hex); |
|
9
|
|
|
|
|
71
|
|
|
9
|
|
|
|
|
439
|
|
11
|
9
|
|
|
9
|
|
50
|
use Carp; |
|
9
|
|
|
|
|
15
|
|
|
9
|
|
|
|
|
10023
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
with 'CatalystX::ASP::Compiler', 'CatalystX::ASP::Parser'; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
our $VERSION = '1.14'; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
=head1 NAME |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
CatalystX::ASP - PerlScript/ASP on Catalyst |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
=head1 VERSION |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
version 1.12 |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
=head1 SYNOPSIS |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
package MyApp; |
28
|
|
|
|
|
|
|
use Moose; |
29
|
|
|
|
|
|
|
use Catalyst; |
30
|
|
|
|
|
|
|
extends 'Catalyst'; |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
with 'CatalystX::ASP::Role'; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
1; |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
=head1 DESCRIPTION |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
CatalystX::ASP is a plugin for Catalyst to support ASP (PerlScript). This is |
39
|
|
|
|
|
|
|
largely based off of Joshua Chamas's L<Apache::ASP>, as the application I've been |
40
|
|
|
|
|
|
|
working with was written for L<Apache::ASP>. Thus, this was designed to be |
41
|
|
|
|
|
|
|
almost a drop-in replacement. However, there were many features that I chose not |
42
|
|
|
|
|
|
|
to implement. |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
This plugin basically creates a Catalyst View which can process ASP scripts. As |
45
|
|
|
|
|
|
|
an added bonus, a simple L<CatalystX::ASP::Role> can be included to allow for |
46
|
|
|
|
|
|
|
automatical processing of files with I<.asp> extension in the application |
47
|
|
|
|
|
|
|
I<root> directory. |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
Just to be clear, the L<Parser|CatalystX::ASP::Parser> is almost totally ripped |
50
|
|
|
|
|
|
|
off of Joshua Chamas's parser in L<Apache::ASP>. Similarly with the |
51
|
|
|
|
|
|
|
L<Compiler|CatalystX::ASP::Compiler> and L<GlobalASA|CatalystX::ASP::GlobalASA>. |
52
|
|
|
|
|
|
|
However, the other components are reimplementations. |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
=cut |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
our @CompileChecksumKeys = qw(Global GlobalPackage IncludesDir XMLSubsMatch); |
57
|
|
|
|
|
|
|
our @Objects = qw(Server Request Response Application Session); |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
has 'c' => ( |
60
|
|
|
|
|
|
|
is => 'rw', |
61
|
|
|
|
|
|
|
clearer => 'clear_c' |
62
|
|
|
|
|
|
|
); |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
has '_setup_finished' => ( |
65
|
|
|
|
|
|
|
is => 'rw', |
66
|
|
|
|
|
|
|
isa => 'Bool', |
67
|
|
|
|
|
|
|
default => 1, |
68
|
|
|
|
|
|
|
); |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
=head1 CONFIGURATION |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
You can configure CatalystX::ASP in Catalyst under the C<CatalystX::ASP> section |
73
|
|
|
|
|
|
|
of the configuration |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
__PACKAGE__->config('CatalystX::ASP' => { |
76
|
|
|
|
|
|
|
Global => 'lib', |
77
|
|
|
|
|
|
|
GlobalPackage => 'MyApp', |
78
|
|
|
|
|
|
|
IncludesDir => 'templates', |
79
|
|
|
|
|
|
|
MailHost => 'localhost', |
80
|
|
|
|
|
|
|
MailFrom => 'myapp@localhost', |
81
|
|
|
|
|
|
|
XMLSubsMatch => '(?:myapp):\w+', |
82
|
|
|
|
|
|
|
Debug => 0, |
83
|
|
|
|
|
|
|
}): |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
The following documentation is also plagiarized from Joshua Chamas. |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
=over |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=item Global |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
Global is the nerve center of an Apache::ASP application, in which the |
92
|
|
|
|
|
|
|
global.asa may reside defining the web application's event handlers. |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
Includes, specified with C<< <!--#include file=somefile.inc--> >> or |
95
|
|
|
|
|
|
|
C<< $Response->Include() >> syntax, may also be in this directory, please see |
96
|
|
|
|
|
|
|
section on includes for more information. |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
=cut |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
has 'Global' => ( |
101
|
|
|
|
|
|
|
is => 'rw', |
102
|
|
|
|
|
|
|
isa => Path, |
103
|
|
|
|
|
|
|
coerce => 1, |
104
|
|
|
|
|
|
|
default => sub { path( '/tmp' ) }, |
105
|
|
|
|
|
|
|
); |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
=item GlobalPackage |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
Perl package namespace that all scripts, includes, & global.asa events are |
110
|
|
|
|
|
|
|
compiled into. By default, GlobalPackage is some obscure name that is uniquely |
111
|
|
|
|
|
|
|
generated from the file path of the Global directory, and global.asa file. The |
112
|
|
|
|
|
|
|
use of explicitly naming the GlobalPackage is to allow scripts access to globals |
113
|
|
|
|
|
|
|
and subs defined in a perl module that is included with commands like: |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
__PACKAGE__->config('CatalystX::ASP' => { |
116
|
|
|
|
|
|
|
GlobalPackage => 'MyApp' }); |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
=cut |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
has 'GlobalPackage' => ( |
121
|
|
|
|
|
|
|
is => 'ro', |
122
|
|
|
|
|
|
|
isa => 'Str', |
123
|
|
|
|
|
|
|
); |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
=item IncludesDir |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
No default. If set, this directory will also be used to look for includes when |
128
|
|
|
|
|
|
|
compiling scripts. By default the directory the script is in, and the Global |
129
|
|
|
|
|
|
|
directory are checked for includes. |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
This extension was added so that includes could be easily shared between ASP |
132
|
|
|
|
|
|
|
applications, whereas placing includes in the Global directory only allows |
133
|
|
|
|
|
|
|
sharing between scripts in an application. |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
__PACKAGE__->config('CatalystX::ASP' => { |
136
|
|
|
|
|
|
|
IncludeDirs => '.' }); |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
Also, multiple includes directories may be set: |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
__PACKAGE__->config('CatalystX::ASP' => { |
141
|
|
|
|
|
|
|
IncludeDirs => ['../shared', '/usr/local/asp/shared'] }); |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
Using IncludesDir in this way creates an includes search path that would look |
144
|
|
|
|
|
|
|
like C<.>, C<Global>, C<../shared>, C</usr/local/asp/shared>. The current |
145
|
|
|
|
|
|
|
directory of the executing script is checked first whenever an include is |
146
|
|
|
|
|
|
|
specified, then the C<Global> directory in which the F<global.asa> resides, and |
147
|
|
|
|
|
|
|
finally the C<IncludesDir> setting. |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
=cut |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
has 'IncludesDir' => ( |
152
|
|
|
|
|
|
|
is => 'rw', |
153
|
|
|
|
|
|
|
isa => Paths, |
154
|
|
|
|
|
|
|
coerce => 1, |
155
|
|
|
|
|
|
|
lazy => 1, |
156
|
|
|
|
|
|
|
default => sub { [ shift->Global() ] }, |
157
|
|
|
|
|
|
|
); |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
=item MailHost |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
The mail host is the SMTP server that the below Mail* config directives will |
162
|
|
|
|
|
|
|
use when sending their emails. By default L<Net::SMTP> uses SMTP mail hosts |
163
|
|
|
|
|
|
|
configured in L<Net::Config>, which is set up at install time, but this setting |
164
|
|
|
|
|
|
|
can be used to override this config. |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
The mail hosts specified in the Net::Config file will be used as backup SMTP |
167
|
|
|
|
|
|
|
servers to the C<MailHost> specified here, should this primary server not be |
168
|
|
|
|
|
|
|
working. |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
__PACKAGE__->config('CatalystX::ASP' => { |
171
|
|
|
|
|
|
|
MailHost => 'smtp.yourdomain.com.foobar' }); |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
=cut |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
has 'MailHost' => ( |
176
|
|
|
|
|
|
|
is => 'ro', |
177
|
|
|
|
|
|
|
isa => 'Str', |
178
|
|
|
|
|
|
|
default => 'localhost', |
179
|
|
|
|
|
|
|
); |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=item MailFrom |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
No default. Set this to specify the default mail address placed in the C<From:> |
184
|
|
|
|
|
|
|
mail header for the C<< $Server->Mail() >> API extension |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
__PACKAGE__->config('CatalystX::ASP' => { |
187
|
|
|
|
|
|
|
MailFrom => 'youremail@yourdomain.com.foobar' }); |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
=cut |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
has 'MailFrom' => ( |
192
|
|
|
|
|
|
|
is => 'ro', |
193
|
|
|
|
|
|
|
isa => 'Str', |
194
|
|
|
|
|
|
|
default => '', |
195
|
|
|
|
|
|
|
); |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
=item XMLSubsMatch |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
Default is not defined. Set to some regexp pattern that will match all XML and |
200
|
|
|
|
|
|
|
HTML tags that you want to have perl subroutines handle. The is |
201
|
|
|
|
|
|
|
L<Apache::ASP/XMLSubs>'s custom tag technology ported to CatalystX::ASP, and can |
202
|
|
|
|
|
|
|
be used to create powerful extensions to your XML and HTML rendering. |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
Please see XML/XSLT section for instructions on its use. |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
__PACKAGE__->config('CatalystX::ASP' => { |
207
|
|
|
|
|
|
|
XMLSubsMatch => 'my:[\w\-]+' }); |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
=cut |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
subtype 'XMLSubsRegexp' => as 'Regexp'; |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
coerce 'XMLSubsRegexp' |
214
|
|
|
|
|
|
|
=> from 'Str' |
215
|
|
|
|
|
|
|
=> via { |
216
|
|
|
|
|
|
|
$_ =~ s/\(\?\:([^\)]*)\)/($1)/isg; |
217
|
|
|
|
|
|
|
$_ =~ s/\(([^\)]*)\)/(?:$1)/isg; |
218
|
|
|
|
|
|
|
qr/$_/; |
219
|
|
|
|
|
|
|
}; |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
has 'XMLSubsMatch' => ( |
222
|
|
|
|
|
|
|
is => 'ro', |
223
|
|
|
|
|
|
|
isa => 'XMLSubsRegexp', |
224
|
|
|
|
|
|
|
coerce => 1, |
225
|
|
|
|
|
|
|
); |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
=item Debug |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
Currently only a placeholder. Only effect is to turn on stacktrace on C<__DIE__> |
230
|
|
|
|
|
|
|
signal. |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
=back |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
=cut |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
has 'Debug' => ( |
237
|
|
|
|
|
|
|
is => 'ro', |
238
|
|
|
|
|
|
|
isa => 'Bool', |
239
|
|
|
|
|
|
|
default => 0, |
240
|
|
|
|
|
|
|
); |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
has '_include_file_cache' => ( |
243
|
|
|
|
|
|
|
is => 'rw', |
244
|
|
|
|
|
|
|
isa => 'HashRef', |
245
|
|
|
|
|
|
|
traits => [qw(Hash)], |
246
|
|
|
|
|
|
|
handles => { |
247
|
|
|
|
|
|
|
_include_file_from_cache => 'get', |
248
|
|
|
|
|
|
|
_cache_include_file => 'set', |
249
|
|
|
|
|
|
|
_include_file_is_cached => 'exists', |
250
|
|
|
|
|
|
|
}, |
251
|
|
|
|
|
|
|
); |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
has '_compile_checksum' => ( |
254
|
|
|
|
|
|
|
is => 'ro', |
255
|
|
|
|
|
|
|
isa => 'Str', |
256
|
|
|
|
|
|
|
default => sub { |
257
|
|
|
|
|
|
|
my $self = shift; |
258
|
|
|
|
|
|
|
md5_hex( |
259
|
|
|
|
|
|
|
join( '&-+', |
260
|
|
|
|
|
|
|
$VERSION, |
261
|
|
|
|
|
|
|
map { $self->$_ || '' } @CompileChecksumKeys |
262
|
|
|
|
|
|
|
) |
263
|
|
|
|
|
|
|
); |
264
|
|
|
|
|
|
|
}, |
265
|
|
|
|
|
|
|
); |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
=head1 OBJECTS |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
The beauty of the ASP Object Model is that it takes the burden of CGI and |
270
|
|
|
|
|
|
|
Session Management off the developer, and puts them in objects accessible from |
271
|
|
|
|
|
|
|
any ASP script and include. For the perl programmer, treat these objects as |
272
|
|
|
|
|
|
|
globals accessible from anywhere in your ASP application. |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
The CatalystX::ASP object model supports the following: |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
Object Function |
277
|
|
|
|
|
|
|
------ -------- |
278
|
|
|
|
|
|
|
$Session - user session state |
279
|
|
|
|
|
|
|
$Response - output to browser |
280
|
|
|
|
|
|
|
$Request - input from browser |
281
|
|
|
|
|
|
|
$Application - application state |
282
|
|
|
|
|
|
|
$Server - general methods |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
These objects, and their methods are further defined in their respective |
285
|
|
|
|
|
|
|
pod. |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
=over |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
=item L<CatalystX::ASP::Session> |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
=item L<CatalystX::ASP::Response> |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
=item L<CatalystX::ASP::Request> |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
=item L<CatalystX::ASP::Application> |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
=item L<CatalystX::ASP::Server> |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
=back |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
If you would like to define your own global objects for use in your scripts and |
302
|
|
|
|
|
|
|
includes, you can initialize them in the F<global.asa> C<Script_OnStart> like: |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
use vars qw( $Form $App ); # declare globals |
305
|
|
|
|
|
|
|
sub Script_OnStart { |
306
|
|
|
|
|
|
|
$App = MyApp->new; # init $App object |
307
|
|
|
|
|
|
|
$Form = $Request->Form; # alias form data |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
In this way you can create site wide application objects and simple aliases for |
311
|
|
|
|
|
|
|
common functions. |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
=cut |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
for ( qw(Server Request Response GlobalASA Application) ) { |
316
|
|
|
|
|
|
|
my $class = join( '::', __PACKAGE__, $_ ); |
317
|
|
|
|
|
|
|
require_module $class; |
318
|
|
|
|
|
|
|
has "$_" => ( |
319
|
|
|
|
|
|
|
is => 'ro', |
320
|
|
|
|
|
|
|
isa => $class, |
321
|
|
|
|
|
|
|
clearer => "clear_$_", |
322
|
|
|
|
|
|
|
lazy => 1, |
323
|
|
|
|
|
|
|
default => sub { $class->new( asp => shift ) } |
324
|
|
|
|
|
|
|
); |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
my $session_class = join( '::', __PACKAGE__, 'Session' ); |
328
|
|
|
|
|
|
|
require_module $session_class; |
329
|
|
|
|
|
|
|
has 'Session' => ( |
330
|
|
|
|
|
|
|
is => 'ro', |
331
|
|
|
|
|
|
|
isa => $session_class, |
332
|
|
|
|
|
|
|
clearer => "clear_Session", |
333
|
|
|
|
|
|
|
lazy => 1, |
334
|
|
|
|
|
|
|
default => sub { |
335
|
|
|
|
|
|
|
my ( $self ) = @_; |
336
|
|
|
|
|
|
|
my %session = ( asp => $self, _is_new => 0 ); |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
# Create a Session object |
339
|
|
|
|
|
|
|
my $session_object = $session_class->new( %session ); |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
# If application has session support through pluging, pass into TIEHASH |
342
|
|
|
|
|
|
|
# to sync values from $Session to $c->session |
343
|
|
|
|
|
|
|
if ( $self->_setup_finished && $self->c->can( 'session' ) ) { |
344
|
|
|
|
|
|
|
tie %session, $session_class, $session_object; |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
# Copy over every key from Session object to tied hash |
347
|
|
|
|
|
|
|
$session{$_} = $session_object->{$_} for ( keys %$session_object ); |
348
|
|
|
|
|
|
|
return bless \%session, $session_class; |
349
|
|
|
|
|
|
|
} else { |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
# Just return a $Session object, however it will not persist across |
352
|
|
|
|
|
|
|
# requests. |
353
|
|
|
|
|
|
|
return $session_object; |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
}, |
356
|
|
|
|
|
|
|
); |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
sub BUILD { |
359
|
6
|
|
|
6
|
0
|
16
|
my ( $self ) = @_; |
360
|
6
|
|
|
|
|
144
|
my $c = $self->c; |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
# Prepend $c->config->{home} if Global is relative and not found |
363
|
6
|
100
|
66
|
|
|
119
|
if ( !$self->Global->exists && $self->Global->is_relative ) { |
364
|
1
|
|
|
|
|
46
|
$self->Global( path( $c->config->{home}, $self->Global ) ); |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
# Go through each IncludeDir and check paths |
368
|
6
|
|
|
|
|
243
|
my @includes_dir; |
369
|
6
|
|
|
|
|
24
|
for ( @{ $self->IncludesDir } ) { |
|
6
|
|
|
|
|
153
|
|
370
|
6
|
100
|
|
|
|
29
|
if ( $_->is_relative ) { |
371
|
1
|
|
|
|
|
13
|
push @includes_dir, path( $c->config->{home}, $_ ); |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
else { |
374
|
5
|
|
|
|
|
197
|
push @includes_dir, $_; |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
} |
377
|
6
|
|
|
|
|
246
|
$self->IncludesDir( \@includes_dir ); |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
# Trigger Application creation now |
380
|
6
|
|
|
|
|
161
|
$self->Application; |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
# Trigger GlobalASA compilation now |
383
|
6
|
|
|
|
|
176
|
$self->GlobalASA->Application_OnStart; |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
# Setup new Session |
386
|
6
|
50
|
0
|
|
|
160
|
$self->GlobalASA->Session_OnStart && $self->Session->_unset_is_new |
387
|
|
|
|
|
|
|
if $self->Session->_is_new; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
=head1 METHODS |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
These are methods available for the C<CatalystX::ASP> object |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
=over |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
=item $self->search_includes_dir($include) |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
Returns the full path to the include if found in IncludesDir |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
=cut |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
sub search_includes_dir { |
403
|
8
|
|
|
8
|
1
|
22
|
my ( $self, $include ) = @_; |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
# Check cache first, and just return path if cached |
406
|
8
|
100
|
|
|
|
283
|
return $self->_include_file_from_cache( $include ) |
407
|
|
|
|
|
|
|
if $self->_include_file_is_cached( $include ); |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
# Look through each IncludesDir |
410
|
4
|
|
|
|
|
11
|
for my $dir ( @{ $self->IncludesDir } ) { |
|
4
|
|
|
|
|
103
|
|
411
|
4
|
|
|
|
|
36
|
my $file = $dir->child( $include ); |
412
|
4
|
50
|
|
|
|
305
|
if ( $file->exists ) { |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
# Don't forget to cache the results |
415
|
4
|
|
|
|
|
361
|
return $self->_cache_include_file( $include => $file ); |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
# For includes of absolute filesystem path |
420
|
0
|
|
|
|
|
0
|
my $file = path( $include ); |
421
|
0
|
0
|
0
|
|
|
0
|
if ( path( $self->c->config->{home} )->subsumes( $file ) && $file->exists ) { |
422
|
0
|
|
|
|
|
0
|
return $self->_cache_include_file( $include => $file ); |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
# Returning undef means file not found. Let calling method handle error |
426
|
0
|
|
|
|
|
0
|
return; |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
=item $self->file_id($file) |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
Returns a file id that can be used a subroutine name when compiled |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
=cut |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
sub file_id { |
436
|
27
|
|
|
27
|
1
|
1321
|
my ( $self, $file, $without_checksum ) = @_; |
437
|
|
|
|
|
|
|
|
438
|
27
|
100
|
|
|
|
251
|
my $checksum = $without_checksum ? $self->_compile_checksum : ''; |
439
|
27
|
|
|
|
|
52
|
my @id; |
440
|
|
|
|
|
|
|
|
441
|
27
|
|
|
|
|
116
|
$file =~ s|/+|/|sg; |
442
|
27
|
|
|
|
|
1156
|
$file =~ s/[\Wx]/_/sg; |
443
|
27
|
100
|
|
|
|
114
|
if ( length( $file ) >= 35 ) { |
444
|
25
|
|
|
|
|
107
|
push @id, substr( $file, length( $file ) - 35, 36 ); |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
# only do the hex of the original file to create a unique identifier for the long id |
447
|
25
|
|
|
|
|
222
|
push @id, 'x', md5_hex( $file . $checksum ); |
448
|
|
|
|
|
|
|
} else { |
449
|
2
|
|
|
|
|
5
|
push @id, $file, 'x', $checksum; |
450
|
|
|
|
|
|
|
} |
451
|
|
|
|
|
|
|
|
452
|
27
|
|
|
|
|
135
|
return join( '', '__ASP_', @id ); |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
=item $self->execute($c, $code) |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
Eval the given C<$code>. Requies the Catalyst C<$context> object to be passed in |
458
|
|
|
|
|
|
|
first. The C<$code> can be a ref to CODE or a SCALAR, ie. a string of code to |
459
|
|
|
|
|
|
|
execute. Alternatively, C<$code> can be the absolute name of a subroutine. |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
=cut |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
sub execute { |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
# shifting @_ because passing through arguments (from $Response->Include) |
466
|
32
|
|
|
32
|
1
|
83
|
my $self = shift; |
467
|
32
|
|
|
|
|
68
|
my $c = shift; |
468
|
32
|
|
|
|
|
69
|
my $code = shift; |
469
|
|
|
|
|
|
|
|
470
|
9
|
|
|
9
|
|
95
|
no strict qw(refs); ## no critic |
|
9
|
|
|
|
|
16
|
|
|
9
|
|
|
|
|
332
|
|
471
|
9
|
|
|
9
|
|
50
|
no warnings; |
|
9
|
|
|
|
|
17
|
|
|
9
|
|
|
|
|
3797
|
|
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
# This is to set up "global" ASP objects available directly in script or |
474
|
|
|
|
|
|
|
# in the "main" namespace |
475
|
32
|
|
|
|
|
97
|
for my $object ( @Objects ) { |
476
|
160
|
|
|
|
|
3535
|
for my $namespace ( 'main', $self->GlobalASA->package ) { |
477
|
320
|
|
|
|
|
705
|
my $var = join( '::', $namespace, $object ); |
478
|
320
|
|
|
|
|
7112
|
$$var = $self->$object; |
479
|
|
|
|
|
|
|
} |
480
|
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
# This will cause STDOUT to be captured and handled by Tie::Handle in the |
483
|
|
|
|
|
|
|
# Response class |
484
|
32
|
|
|
|
|
419
|
tie local *STDOUT, 'CatalystX::ASP::Response'; |
485
|
|
|
|
|
|
|
|
486
|
32
|
50
|
|
|
|
796
|
local $SIG{__WARN__} = \&Carp::cluck if $self->Debug; |
487
|
32
|
50
|
|
|
|
679
|
local $SIG{__DIE__} = \&Carp::confess if $self->Debug; |
488
|
32
|
|
|
|
|
67
|
my @rv; |
489
|
32
|
50
|
|
|
|
94
|
if ( my $reftype = ref $code ) { |
490
|
0
|
0
|
|
|
|
0
|
if ( $reftype eq 'CODE' ) { |
|
|
0
|
|
|
|
|
|
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
# The most common case |
493
|
0
|
|
|
|
|
0
|
@rv = eval { &$code; }; |
|
0
|
|
|
|
|
0
|
|
494
|
|
|
|
|
|
|
} elsif ( $reftype eq 'SCALAR' ) { |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
# If $code is just a ref to a string, just send it to client |
497
|
0
|
|
|
|
|
0
|
$self->Response->WriteRef( $code ); |
498
|
|
|
|
|
|
|
} else { |
499
|
0
|
|
|
|
|
0
|
$c->error( "Could not execute because \$code is a ref, but not CODE or SCALAR!" ); |
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
} else { |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
# Alternatively, execute a function in the ASP context given a string of |
504
|
|
|
|
|
|
|
# the subroutine name |
505
|
|
|
|
|
|
|
# If absolute package already, then no need to set to package namespace |
506
|
32
|
50
|
|
|
|
120
|
my $subid = ( $code =~ /::/ ) ? $code : $self->GlobalASA->package . '::' . $code; |
507
|
32
|
|
|
|
|
63
|
@rv = eval { &$subid; }; |
|
32
|
|
|
|
|
452
|
|
508
|
|
|
|
|
|
|
} |
509
|
32
|
100
|
|
|
|
2059
|
if ( $@ ) { |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
# Record errors if not $c->detach and $Response->End |
512
|
4
|
100
|
66
|
|
|
222
|
$c->error( "Error executing code: $@" ) unless ( |
|
|
|
100
|
|
|
|
|
513
|
|
|
|
|
|
|
blessed( $@ ) |
514
|
|
|
|
|
|
|
&& ( $@->isa( 'Catalyst::Exception::Detach' ) || $@->isa( 'CatalystX::ASP::Exception::End' ) ) |
515
|
|
|
|
|
|
|
); |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
# Passthrough $c->detach |
518
|
4
|
100
|
|
|
|
51
|
$@->rethrow if $@->isa( 'Catalyst::Exception::Detach' ) |
519
|
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
|
|
521
|
30
|
|
|
|
|
242
|
return @rv; |
522
|
|
|
|
|
|
|
} |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
=item $self->cleanup() |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
Cleans up objects that are transient. Get ready for the next request |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
=cut |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
sub cleanup { |
531
|
10
|
|
|
10
|
1
|
31
|
my ( $self ) = @_; |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
# Since cleanup happens at the end of script processing, trigger |
534
|
|
|
|
|
|
|
# Script_OnEnd |
535
|
10
|
100
|
|
|
|
257
|
$self->GlobalASA->Script_OnEnd if $self->_setup_finished; |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
# Clean up abandoned $Session, which marks the end of the $Session and so |
538
|
|
|
|
|
|
|
# trigger Session_OnEnd. Additionally, need to remove session from store. |
539
|
10
|
50
|
|
|
|
297
|
if ( $self->Session->IsAbandoned ) { |
540
|
0
|
|
|
|
|
0
|
$self->GlobalASA->Session_OnEnd; |
541
|
|
|
|
|
|
|
|
542
|
0
|
|
|
|
|
0
|
my $c = $self->c; |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
# By default, assume using Catalyst::Plugin::Session |
545
|
0
|
0
|
|
|
|
0
|
if ( $c->can( 'delete_session' ) ) { |
|
|
0
|
|
|
|
|
|
546
|
0
|
|
|
|
|
0
|
$c->delete_session( 'CatalystX::ASP::Sesssion::Abandon() called' ) |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
# Else assume using Catalyst::Plugin::iParadigms::Session |
549
|
|
|
|
|
|
|
} elsif ( $c->can( 'session_cache' ) ) { |
550
|
0
|
|
|
|
|
0
|
$c->clear_tii_session; |
551
|
0
|
|
|
|
|
0
|
$c->clear_session; |
552
|
0
|
|
|
|
|
0
|
$c->session_cache->delete( $c->sessionid ); |
553
|
|
|
|
|
|
|
} |
554
|
|
|
|
|
|
|
} |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
# Remove more references in order to get things destroyed |
557
|
10
|
|
|
|
|
1357
|
untie ${ \$self->Session }; |
|
10
|
|
|
|
|
242
|
|
558
|
10
|
|
|
|
|
61
|
undef &CatalystX::ASP::Response::TIEHANDLE; |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
# Remove references to global ASP objects |
561
|
9
|
|
|
9
|
|
58
|
no strict qw(refs); ## no critic |
|
9
|
|
|
|
|
23
|
|
|
9
|
|
|
|
|
1457
|
|
562
|
10
|
|
|
|
|
35
|
for my $object ( reverse @Objects ) { |
563
|
50
|
|
|
|
|
1030
|
for my $namespace ( 'main', $self->GlobalASA->package ) { |
564
|
100
|
|
|
|
|
203
|
my $var = join( '::', $namespace, $object ); |
565
|
100
|
|
|
|
|
266
|
undef $$var; |
566
|
|
|
|
|
|
|
} |
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
# Clear transient global objects from ASP object |
570
|
10
|
|
|
|
|
273
|
$self->clear_Session; |
571
|
10
|
|
|
|
|
285
|
$self->clear_Response; |
572
|
10
|
|
|
|
|
268
|
$self->clear_Request; |
573
|
10
|
|
|
|
|
270
|
$self->clear_c; |
574
|
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
# Clear remaining global objects in order |
577
|
|
|
|
|
|
|
sub DEMOLISH { |
578
|
1
|
|
|
1
|
0
|
2
|
my ( $self ) = @_; |
579
|
|
|
|
|
|
|
|
580
|
1
|
|
|
|
|
26
|
$self->clear_Application; |
581
|
1
|
|
|
|
|
24
|
$self->clear_Server; |
582
|
1
|
|
|
|
|
33
|
$self->clear_GlobalASA; |
583
|
|
|
|
|
|
|
} |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
__PACKAGE__->meta->make_immutable; |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
=back |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
=head1 BUGS/CAVEATS |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
Obviously there are no bugs ;-) As of now, every known bug has been addressed. |
592
|
|
|
|
|
|
|
However, a caveat is that not everything from Apache::ASP is implemented here. |
593
|
|
|
|
|
|
|
Though the module touts itself to be a drop-in replacement, don't believe the |
594
|
|
|
|
|
|
|
author and try it out for yourself first. You've been warned :-) |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
=head1 AUTHOR |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
Steven Leung E<lt> sleung@cpan.org E<gt> |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
Joshua Chamas E<lt> asp-dev@chamas.com E<gt> |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
=head1 SEE ALSO |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
=over |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
=item * L<Catalyst> |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
=item * L<Apache::ASP> |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
=back |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
=head1 LICENSE AND COPYRIGHT |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
Copyright (C) 2016 Steven Leung |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it |
617
|
|
|
|
|
|
|
under the terms of either: the GNU General Public License as published |
618
|
|
|
|
|
|
|
by the Free Software Foundation; or the Artistic License. |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
See L<http://dev.perl.org/licenses/> for more information. |