File Coverage

blib/lib/CatalystX/ASP.pm
Criterion Covered Total %
statement 104 120 86.6
branch 25 42 59.5
condition 7 15 46.6
subroutine 18 18 100.0
pod 4 6 66.6
total 158 201 78.6


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.