File Coverage

blib/lib/Catalyst/Controller/AutoAssets/Handler/Directory.pm
Criterion Covered Total %
statement 67 91 73.6
branch 9 28 32.1
condition 3 9 33.3
subroutine 15 18 83.3
pod 0 7 0.0
total 94 153 61.4


line stmt bran cond sub pod time code
1             package Catalyst::Controller::AutoAssets::Handler::Directory;
2 1     1   686 use strict;
  1         2  
  1         47  
3 1     1   4 use warnings;
  1         2  
  1         36  
4              
5             # VERSION
6              
7 1     1   3 use Moose;
  1         2  
  1         7  
8 1     1   4479 use namespace::autoclean;
  1         1  
  1         11  
9              
10             with 'Catalyst::Controller::AutoAssets::Handler';
11              
12 1     1   81 use Path::Class 0.32 qw( dir file );
  1         30  
  1         61  
13 1     1   438 use MIME::Types;
  1         3686  
  1         1184  
14              
15              
16             sub BUILD {
17             my $self = shift;
18            
19             # init dir_root:
20             $self->dir_root;
21             }
22              
23             sub asset_request {
24 3     3 0 6 my ( $self, $c, $sha1, @args ) = @_;
25            
26             # Only subfiles are valid with Directory assets:
27 3 50       8 return $self->unknown_asset($c) unless (scalar @args > 0);
28            
29 3         8 my $path = join('/',@args);
30 3         7 $self->prepare_asset($path);
31              
32             return $self->unknown_asset($c) unless (
33             $sha1 eq $self->asset_name
34 3 50 33     17 && exists $self->subfile_meta->{$path}
35             );
36              
37 3         106 my $meta = $self->subfile_meta->{$path};
38 3         17 return $self->_set_file_response($c,$meta->{file},$meta->{content_type});
39             }
40              
41             sub _set_file_response {
42 3     3   4 my ($self, $c, $file, $content_type) = @_;
43            
44 3         60 $c->response->header(
45             'Content-Type' => $content_type,
46             'Cache-Control' => $self->cache_control_header
47             );
48              
49 3         758 my $f= $file->openr;
50 3         349 binmode $f;
51 3         91 return $c->response->body( $f );
52             }
53              
54              
55             sub _resolve_subfile_content_type {
56 0     0   0 my $self = shift;
57 0         0 my $File = shift;
58             my $content_type = $self->subfile_meta->{$File}->{content_type}
59 0 0       0 or die "content_type not found in subfile_meta for $File!";
60 0         0 return $content_type;
61             }
62              
63             # CodeRef used to determine the Content-Type of each 'directory' subfile
64             has 'content_type_resolver', is => 'ro', isa => 'CodeRef', default => sub{ \&_ext_to_type };
65              
66             has 'MimeTypes', is => 'ro', isa => 'MIME::Types', lazy => 1, default => sub {
67             my $self = shift;
68             return MIME::Types->new( only_complete => 1 );
69             };
70              
71             # looks up the correct MIME type for the current file extension
72             # (adapted from Static::Simple)
73             sub _ext_to_type {
74 5     5   7 my ( $self, $full_path ) = @_;
75 5         19 my $c = $self->_app;
76              
77 5 50       172 if ( $full_path =~ /.*\.(\S{1,})$/xms ) {
78 5         118 my $ext = $1;
79 5         157 my $type = $self->MimeTypes->mimeTypeOf( $ext );
80 5 50       225 if ( $type ) {
81 5 50       25 return ( ref $type ) ? $type->type : $type;
82             }
83             else {
84 0         0 return 'text/plain';
85             }
86             }
87             else {
88 0         0 return 'text/plain';
89             }
90             }
91              
92             # subfile_meta applies only to 'directory' assets. It is a cache of mtimes of
93             # individual files within the directory since 'inc_mtimes' only conatins the top
94             # directory. This is used to check for mtime changes on individual subfiles when
95             # they are requested. This is for performance since it would be too expensive to
96             # attempt to check all the mtimes on every request
97             has 'subfile_meta', is => 'rw', isa => 'HashRef', default => sub {{}};
98             sub set_subfile_meta {
99 1     1 0 1 my $self = shift;
100 1         2 my $list = shift;
101             $self->subfile_meta({
102 1         3 map { join('/', grep { $_ ne '.' } $_->relative($self->dir_root)->components) => {
  5         210  
  10         832  
103             file => $_,
104             mtime => $_->stat->mtime,
105             content_type => $self->content_type_resolver->($self,$_)
106             } } @$list
107             });
108             }
109              
110             has '_persist_attrs', is => 'ro', isa => 'ArrayRef', default => sub{[qw(
111             built_mtime
112             inc_mtimes
113             last_fingerprint_calculated
114             subfile_meta
115             _excluded_paths
116             )]};
117              
118              
119             has 'dir_root', is => 'ro', isa => 'Path::Class::Dir', lazy => 1, default => sub {
120             my $self = shift;
121              
122             die "'directory' assets must have exactly one include path"
123             unless (scalar @{$self->includes} == 1);
124              
125             my $dir = $self->includes->[0]->absolute;
126             die "include path '$dir' is not a directory" unless (-d $dir);
127              
128             return $dir;
129             };
130              
131             sub _subfile_mtime_verify {
132 8     8   13 my ($self, $path) = @_;
133 8         268 my $File = $self->dir_root->file($path);
134            
135             # If the file doesn't exist on disk or is in the excluded paths there
136             # is no need to clear the asset. We already know it will return a 404
137 8 50 33     959 return if ($self->_excluded_paths->{$path} || ! -f $File);
138              
139             # Check the mtime of the requested file to see if it has changed
140             # and force a rebuild if it has. This is done because it is too
141             # expensive to check all the subfile mtimes on every request, and
142             # changes within files would not otherwise be caught since file
143             # content changes do not update the parent directory mtime
144             $self->clear_asset unless (
145             exists $self->subfile_meta->{$path} &&
146             $File->stat->mtime eq $self->subfile_meta->{$path}->{mtime}
147 8 50 33     763 );
148             }
149              
150             # Provides a mechanism for preparing a set of subfiles all at once. This
151             # is a critical pre-step whenever multiple subfiles are being used together
152             # because if any have changed the asset path for *all* will be updated as
153             # soon as the changed file is detected. If this happens halfway through the list,
154             # the asset path of earlier processed items will retroactively change.
155             sub prepare_asset_subfiles {
156 0     0 0 0 my ($self, @files) = @_;
157 0         0 $self->_subfile_mtime_verify($_) for (@files);
158 0         0 $self->prepare_asset;
159             }
160              
161             around asset_path => sub {
162             my ($orig, $self, @subpath) = @_;
163            
164             my $base = $self->$orig(@subpath);
165             return $base unless (scalar @subpath > 0);
166              
167             my $File = $self->dir_root->file(@subpath);
168             Catalyst::Exception->throw("sub file $File not found") unless (-f $File);
169              
170             return join('/',$base,@subpath);
171             };
172              
173             sub before_prepare_asset {
174 12     12 0 22 my ($self, @args) = @_;
175 12         30 my $path = join('/',@args);
176            
177             # Special code path: if this is associated with a sub file request
178             # in a 'directory' type asset, clear the asset to force a rebuild
179             # below if the *subfile* mtime has changed
180 12 100       45 $self->_subfile_mtime_verify($path) if (scalar @args > 0);
181             }
182              
183             sub get_prepare_data {
184 12     12 0 18 my $self = shift;
185            
186             # For 'directory' only consider the mtime of the top directory and don't
187             # read in all the files (yet... we will read them in only if we need to rebuild)
188             # WARNING: this means that changes *within* sub files will not be detected here
189             # because that doesn't update the directory mtime; only filename changes will be seen.
190             # Update: That is what _subfile_mtime_verify above is for... to inexpensively catch
191             # this case for individual sub files
192 12         414 my $files = $self->includes;
193 12         38 my $inc_mtimes = $self->get_inc_mtime_concat($files);
194 12         1828 my $built_mtime = $self->get_built_mtime;
195            
196             return {
197 12         1414 files => $files,
198             inc_mtimes => $inc_mtimes,
199             built_mtime => $built_mtime
200             };
201             }
202              
203             around build_asset => sub {
204             my ($orig, $self, $d) = @_;
205            
206             # Get the real list of files that we put off in get_prepare_data()
207             $d->{files} = $self->get_include_files;
208              
209             # update the mtime cache of all directory subfiles
210             $self->set_subfile_meta($d->{files});
211              
212             return $self->$orig($d);
213             };
214              
215             # Keep track of excluded files so we can return a 404 without rebuilding
216             # the asset
217             has '_excluded_paths', is => 'rw', isa => 'HashRef', default => sub {{}};
218             sub _record_excluded_files {
219 1     1   2 my ($self, $files) = @_;
220 1         8 my @relative = map { join('/', grep { $_ ne '.' } file($_)->relative($self->dir_root)->components) } @$files;
  3         8  
  6         445  
221 1         2 my %hash = map { $_ => 1 } map { "$_" } @relative;
  3         10  
  3         4  
222 1         39 $self->_excluded_paths(\%hash);
223             }
224              
225             sub write_built_file {
226 1     1 0 2 my ($self, $fd, $files) = @_;
227             # The built file is just a placeholder in the case of 'directory' type
228             # asset whose data is served from the original files
229 1         2 my @relative = map { join('/', grep { $_ ne '.' } file($_)->relative($self->dir_root)->components) } @$files;
  5         10  
  10         662  
230 1         12 $fd->write(join("\r\n",@relative) . "\r\n");
231             }
232              
233              
234             # These apply only to 'directory' asset type
235             has 'html_head_css_subfiles', is => 'ro', isa => 'ArrayRef', default => sub {[]};
236             has 'html_head_js_subfiles', is => 'ro', isa => 'ArrayRef', default => sub {[]};
237              
238             # --------------------
239             # html_head_tags()
240             #
241             # Convenience method to generate a set of CSS <link> and JS <script> tags
242             # suitable to drop into the <head> section of an HTML document.
243             #
244             # For 'css' and 'js' assets this will be a single tag pointing at the current
245             # valid asset path. For 'directory' asset types this will be a listing of
246             # css and/or js tags pointing at subfile asset paths supplied in the attrs:
247             # 'html_head_css_subfiles' and 'html_head_js_subfiles', or, supplied in a
248             # hash(ref) argument with 'css' and/or 'js' keys and arrayref values.
249             #
250             # ### More about the 'directory' asset type:
251             #
252             # This could be considered a violation of separation of concerns, but the main
253             # reason this method is provided at all, besides the fact that it is a common
254             # use case, is that it handles the preprocessing required to ensure the dir asset
255             # is in an atomic/consistent state by calling prepare_asset_subfiles() on all
256             # supplied subfiles as a group to catch any content changes before rendering/returning
257             # the active asset paths. This is something that users might not realize they
258             # need to do if they don't read the docs closely. So, it is a common use case
259             # and this provides a simple and easy to understand interface that spares the user
260             # from needing to know about details they might not want to know about. It's
261             # practical/useful, self-documenting, and doesn't have to be used...
262             #
263             # The only actual "risk" if this the preprocessing step is missed, and the user builds
264             # head tags themselves with multiple calls to asset_path('path/to/subfile') [such as in
265             # a TT file] is that during a request where the content of one of the subfiles has changed,
266             # the asset paths of all the subfiles processed/returned prior to hitting the changed file
267             # will already be invalid (retroactively) because the sha1 will have changed. This is
268             # because the sha1/fingerprint is based on the asset as *whole*, and for performance, subfile
269             # content changes are not detected until they are accessed. This is only an issue when the
270             # content changes *in-place*, which shouldn't happen in a production environment. And, it
271             # only effects the first request immediately after the change. This issue can also be avoided
272             # altogether by using static 'current' alias redirect URLs instead off calling asset_path(),
273             # but this is *slightly* less efficient, as discussed in the documentation.
274             #
275             # This long-winded explanation is more about documenting/explaining the internal design
276             # for development purposes (and to be a reminder for me) than it is anything else. Also,
277             # it is intentionally in a comment rather than the POD for the sake of avoiding information
278             # overload since from the user perspective this is barely an issue (but very useful for
279             # developers who need to understand the internals of this module)
280             #
281             # Note: This has nothing to do with 'css' or 'js' asset types which are always atomic
282             # (because they are single files and have no "subfiles"). This *only* applies to
283             # the 'directory' asset type
284             #
285             sub html_head_tags {
286 0     0 0   my ($self, @args) = @_;
287              
288             # get the files from either supplied arguments or defaults in object attrs:
289             my %cnf = scalar @args > 0
290 0 0         ? ( (ref($args[0]) eq 'HASH') ? %{ $args[0] } : @args ) # <-- arg as hash or hashref
  0 0          
291             : ( css => $self->html_head_css_subfiles, js => $self->html_head_js_subfiles );
292            
293             # note that we're totally trusting the caller to know that these files are
294             # in fact js/css files. We're just generating the correct tags for each type
295 0 0         my @css = $cnf{css} ? @{$cnf{css}} : ();
  0            
296 0 0         my @js = $cnf{js} ? @{$cnf{js}} : ();
  0            
297              
298             # This is the line that ensures any content changes are detected before we start
299             # building the tags/urls:
300 0           $self->prepare_asset_subfiles(@css,@js);
301              
302             # This spares repeating the stat/mtime calls by asset_path() below.
303             # Maybe overkill, but every little bit of performance helps (and I'm OCD)...
304 0           $self->_asset_path_skip_prepare(1);
305            
306 0           my @tags = ();
307            
308             push @tags, '<link rel="stylesheet" type="text/css" href="' .
309 0           $self->asset_path($_) . '" />' for (@css);
310              
311             push @tags, '<script type="text/javascript" src="' .
312 0           $self->asset_path($_) . '"></script>' for (@js);
313              
314             # FIXME: shame on me
315 0           $self->_asset_path_skip_prepare(0);
316            
317 0 0         my $html =
318             "<!-- AUTO GENERATED BY " . ref($self->Controller) . " (/" .
319             $self->action_namespace($self->_app) . ") -->\r\n" .
320             ( scalar @tags > 0 ?
321             join("\r\n",@tags) : '<!-- NO ASSETS AVAILABLE -->'
322             ) .
323             "\r\n<!-- ---- END AUTO GENERATED ASSETS ---- -->\r\n";
324              
325 0           return $html;
326             }
327             # --------------------
328              
329             1;
330              
331             __END__
332              
333             =pod
334              
335             =head1 NAME
336              
337             Catalyst::Controller::AutoAssets::Handler::Directory - Directory type handler
338              
339             =head1 DESCRIPTION
340              
341             This is the Handler class for the 'Directory' asset type. This is a core type and is
342             documented in L<Catalyst::Controller::AutoAssets>.
343              
344             =head1 SEE ALSO
345              
346             =over
347              
348             =item L<Catalyst::Controller::AutoAssets::Handler>
349              
350             =back
351              
352             =head1 AUTHOR
353              
354             Henry Van Styn <vanstyn@cpan.org>
355              
356             =head1 COPYRIGHT AND LICENSE
357              
358             This software is copyright (c) 2013 by IntelliTree Solutions llc.
359              
360             This is free software; you can redistribute it and/or modify it under
361             the same terms as the Perl 5 programming language system itself.
362              
363             =cut
364