File Coverage

blib/lib/Statocles/Store.pm
Criterion Covered Total %
statement 157 158 99.3
branch 57 60 95.0
condition 16 20 80.0
subroutine 25 25 100.0
pod 12 14 85.7
total 267 277 96.3


line stmt bran cond sub pod time code
1             package Statocles::Store;
2             our $VERSION = '0.086';
3             # ABSTRACT: The source for data documents and files
4              
5 68     68   422 use Statocles::Base 'Class';
  68         142  
  68         643  
6 68     68   485817 use Scalar::Util qw( weaken blessed );
  68         163  
  68         4082  
7 68     68   409 use Statocles::Util qw( derp );
  68         140  
  68         2960  
8 68     68   26874 use Statocles::Document;
  68         262  
  68         2131  
9 68     68   17469 use YAML;
  68         324749  
  68         3225  
10 68     68   504 use JSON::PP;
  68         136  
  68         3787  
11 68     68   18805 use File::Spec::Functions qw( splitdir );
  68         45683  
  68         3818  
12 68     68   484 use Module::Runtime qw( use_module );
  68         141  
  68         640  
13              
14             # A hash of PATH => COUNT for all the open store paths. Stores are not allowed to
15             # discover the files or documents of other stores (unless the two stores have the same
16             # path)
17             my %FILE_STORES = ();
18              
19             #pod =attr path
20             #pod
21             #pod The path to the directory containing the L<documents|Statocles::Document>.
22             #pod
23             #pod =cut
24              
25             has path => (
26             is => 'ro',
27             isa => AbsPath,
28             coerce => AbsPath->coercion,
29             required => 1,
30             );
31              
32             #pod =attr document_extensions
33             #pod
34             #pod An array of file extensions that should be considered documents. Defaults to
35             #pod "markdown" and "md".
36             #pod
37             #pod =cut
38              
39             has document_extensions => (
40             is => 'ro',
41             isa => ArrayRef[Str],
42             default => sub { [qw( markdown md )] },
43             coerce => sub {
44             my ( $ext ) = @_;
45             if ( !ref $ext ) {
46             return [ split /[, ]/, $ext ];
47             }
48             return $ext;
49             },
50             );
51              
52             #pod =attr documents
53             #pod
54             #pod All the L<documents|Statocles::Document> currently read by this store.
55             #pod
56             #pod =method clear
57             #pod
58             #pod $store->clear;
59             #pod
60             #pod Clear the cached documents in this Store.
61             #pod
62             #pod =cut
63              
64             has documents => (
65             is => 'rw',
66             isa => ArrayRef[InstanceOf['Statocles::Document']],
67             lazy => 1,
68             builder => 'read_documents',
69             clearer => 'clear',
70             );
71              
72             # Cache our realpath in case it disappears before we get demolished
73             has _realpath => (
74             is => 'ro',
75             isa => Path,
76             lazy => 1,
77             default => sub { $_[0]->path->realpath },
78             );
79              
80             # If true, we've already checked if this store's path exists. We need to
81             # check this lazily to ensure the site is created and the logger is
82             # ready to go.
83             #
84             # XXX: Making sure the logger is ready before the thing that needs it is
85             # the entire reason that dependency injection exists. We should use the
86             # container to make sure the logger is wired up with every object that
87             # needs it...
88             has _check_exists => (
89             is => 'rw',
90             isa => Bool,
91             lazy => 1,
92             default => sub {
93             my ( $self ) = @_;
94             if ( !$self->path->exists ) {
95             site->log->warn( sprintf qq{Store path "%s" does not exist}, $self->path );
96             }
97             return 1;
98             },
99             );
100              
101             sub BUILD {
102 908     908 0 231133 my ( $self ) = @_;
103 908         15422 $FILE_STORES{ $self->_realpath }++;
104             }
105              
106             sub DEMOLISH {
107 613     613 0 662229 my ( $self, $in_global_destruction ) = @_;
108 613 50       2005 return if $in_global_destruction; # We're ending, we don't need to care anymore
109 613 100       9208 if ( --$FILE_STORES{ $self->_realpath } <= 0 ) {
110 505         17556 delete $FILE_STORES{ $self->_realpath };
111             }
112             }
113              
114             #pod =method read_documents
115             #pod
116             #pod my $docs = $store->read_documents;
117             #pod
118             #pod Read the directory C<path> and create the L<document
119             #pod objects|Statocles::Document> inside. Returns an arrayref of document objects.
120             #pod
121             #pod =cut
122              
123             sub read_documents {
124 12     12 1 343298 my ( $self ) = @_;
125 12         188 $self->_check_exists;
126 12         274 my $root_path = $self->path;
127 12         30 my @docs;
128 12         73 my $iter = $root_path->iterator( { recurse => 1, follow_symlinks => 1 } );
129 12         389 while ( my $path = $iter->() ) {
130 116 100       11196 next unless $path->is_file;
131 86 100       929 next unless $self->_is_owned_path( $path );
132 82 50       209 next unless $self->is_document( $path );
133 82         692 my $rel_path = rootdir->child( $path->relative( $root_path ) );
134 82         18602 push @docs, $self->read_document( $rel_path );
135             }
136 6         297 return \@docs;
137             }
138              
139             sub _is_owned_path {
140 3247     3247   5560 my ( $self, $path ) = @_;
141 3247         67430 my $self_path = $self->_realpath;
142 3247         25907 $path = $path->realpath;
143 3247         453757 my $dir = $path->parent;
144 3247         159109 for my $store_path ( keys %FILE_STORES ) {
145             # This is us!
146 23367 100       111338 next if $store_path eq $self_path;
147             # If our store is contained inside this store's path, we win
148 20232 100       217944 next if $self_path =~ /^\Q$store_path/;
149 19565 100       204152 return 0 if $path =~ /^\Q$store_path/;
150             }
151 2734         18699 return 1;
152             }
153              
154             #pod =method read_document
155             #pod
156             #pod my $doc = $store->read_document( $path )
157             #pod
158             #pod Read a single L<document|Statocles::Document> in Markdown with optional YAML
159             #pod or JSON frontmatter.
160             #pod
161             #pod =cut
162              
163             sub read_document {
164 583     583 1 13259 my ( $self, $path ) = @_;
165 583         3302 site->log->debug( "Read document: " . $path );
166 583         26375 my $full_path = $self->path->child( $path );
167 583         21218 my $relative_path = $full_path->relative( cwd );
168 583         130819 my %doc = $self->parse_frontmatter( $relative_path, $full_path->slurp_utf8 );
169 579 100       2166 my $class = $doc{class} ? use_module( delete $doc{class} ) : 'Statocles::Document';
170 579         1250 my $obj = eval { $class->new( %doc, path => $path, store => $self ) };
  579         15031  
171 579 100       29166 if ( $@ ) {
172 2 50 33     28 if ( ref $@ && $@->isa( 'Error::TypeTiny::Assertion' ) ) {
173 2 100       8 if ( $@->attribute_name eq 'date' ) {
174 1         7 die sprintf qq{Could not parse date "%s" in "%s": Does not match "YYYY-MM-DD" or "YYYY-MM-DD HH:MM:SS"\n},
175             $@->value,
176             $relative_path;
177             }
178              
179 1         7 die sprintf qq{Error creating document in "%s": Value "%s" is not valid for attribute "%s" (expected "%s")\n},
180             $relative_path,
181             $@->value,
182             $@->attribute_name,
183             $@->type;
184             }
185             else {
186 0         0 die sprintf qq{Error creating document in "%s": %s\n},
187             $@;
188             }
189             }
190 577         4386 return $obj;
191             }
192              
193             #pod =method parse_frontmatter
194             #pod
195             #pod my %doc_attrs = $store->parse_frontmatter( $from, $content )
196             #pod
197             #pod Parse a document with YAML frontmatter. $from is a string identifying where the
198             #pod content comes from (a path or other identifier). $content is the content to
199             #pod parse for frontmatter.
200             #pod
201             #pod =cut
202              
203             sub parse_frontmatter {
204 592     592 1 89659 my ( $self, $from, $content ) = @_;
205 592 100       1618 return unless $content;
206 586         850 my $doc;
207              
208 586         5022 my @lines = split /\n/, $content;
209 586 100 100     4131 if ( @lines && $lines[0] =~ /^---/ ) {
    100 100        
210 566         995 shift @lines;
211              
212             # The next --- is the end of the YAML frontmatter
213 566         1704 my ( $i ) = grep { $lines[ $_ ] =~ /^---/ } 0..$#lines;
  6582         11137  
214              
215             # If we did not find the marker between YAML and Markdown
216 566 100       1533 if ( !defined $i ) {
217 1         5 die qq{Could not find end of YAML front matter (---) in "$from"\n};
218             }
219              
220             # Before the marker is YAML
221 565         909 eval {
222 565         3553 $doc = YAML::Load( join "\n", splice( @lines, 0, $i ), "" );
223             };
224 565 100       1179336 if ( $@ ) {
225 1         7 die qq{Error parsing YAML in "$from"\n$@};
226             }
227              
228             # Remove the last '---' mark
229 564         1273 shift @lines;
230             }
231             elsif ( @lines && $lines[0] =~ /^{/ ) {
232 12         20 my $json;
233 12 100       42 if ( $lines[0] =~ /\}$/ ) {
234             # The JSON is all on a single line
235 5         11 $json = shift @lines;
236             }
237             else {
238             # The } on a line by itself is the last line of JSON
239 7         19 my ( $i ) = grep { $lines[ $_ ] =~ /^}$/ } 0..$#lines;
  33         71  
240             # If we did not find the marker between YAML and Markdown
241 7 100       25 if ( !defined $i ) {
242 1         5 die qq{Could not find end of JSON front matter (\}) in "$from"\n};
243             }
244 6         29 $json = join "\n", splice( @lines, 0, $i+1 );
245             }
246 11         22 eval {
247 11         51 $doc = decode_json( $json );
248             };
249 11 100       6131 if ( $@ ) {
250 1         6 die qq{Error parsing JSON in "$from"\n$@};
251             }
252             }
253              
254 582         2852 $doc->{content} = join "\n", @lines, "";
255              
256 582         4439 return %$doc;
257             }
258              
259             #pod =method write_document
260             #pod
261             #pod $store->write_document( $path, $doc );
262             #pod
263             #pod Write a L<document|Statocles::Document> to the store at the given store path.
264             #pod
265             #pod The document is written in Frontmatter format.
266             #pod
267             #pod =cut
268              
269             sub write_document {
270 10     10 1 17609 my ( $self, $path, $doc ) = @_;
271 10         59 $path = Path->coercion->( $path ); # Allow stringified paths, $path => $doc
272 10 100       922 if ( $path->is_absolute ) {
273 1         27 die "Cannot write document '$path': Path must not be absolute";
274             }
275 9         350 site->log->debug( "Write document: " . $path );
276              
277 9         1064 $doc = { %{ $doc } }; # Shallow copy for safety
  9         54  
278 9   100     52 my $content = delete( $doc->{content} ) // '';
279 9         49 my $header = YAML::Dump( $self->_freeze_document( $doc ) );
280 9         39448 chomp $header;
281              
282 9         77 my $full_path = $self->path->child( $path );
283 9         478 $full_path->touchpath->spew_utf8( join "\n", $header, '---', $content );
284              
285 9 100       9877 if ( defined wantarray ) {
286 2         13 derp "Statocles::Store->write_document returning a value is deprecated and will be removed in v1.0. Use Statocles::Store->path to find the full path to the document.";
287             }
288 9         52 return $full_path;
289             }
290              
291             sub _freeze_document {
292 9     9   25 my ( $self, $doc ) = @_;
293 9         23 delete $doc->{path}; # Path should not be in the document
294 9         21 delete $doc->{store};
295 9 100       31 if ( exists $doc->{date} ) {
296 3         17 $doc->{date} = $doc->{date}->strftime('%Y-%m-%d %H:%M:%S');
297             }
298 9         287 for my $hash_type ( qw( links images ) ) {
299 18 100 66     67 if ( exists $doc->{ $hash_type } && !keys %{ $doc->{ $hash_type } } ) {
  2         8  
300 2         5 delete $doc->{ $hash_type };
301             }
302             }
303 9         55 return $doc;
304             }
305              
306             #pod =method is_document
307             #pod
308             #pod my $bool = $store->is_document( $path );
309             #pod
310             #pod Returns true if the path looks like a document path (matches the L</document_extensions>).
311             #pod
312             #pod =cut
313              
314             sub is_document {
315 2023     2023 1 4966 my ( $self, $path ) = @_;
316 2023         2961 my $match = join "|", @{ $self->document_extensions };
  2023         6126  
317 2023         10454 return $path =~ /[.](?:$match)$/;
318             }
319              
320             #pod =method read_file
321             #pod
322             #pod my $content = $store->read_file( $path )
323             #pod
324             #pod Read the file from the given C<path>.
325             #pod
326             #pod =cut
327              
328             sub read_file {
329 378     378 1 12888 my ( $self, $path ) = @_;
330 378         2199 site->log->debug( "Read file: " . $path );
331 378         18689 return $self->path->child( $path )->slurp_utf8;
332             }
333              
334             #pod =method has_file
335             #pod
336             #pod my $bool = $store->has_file( $path )
337             #pod
338             #pod Returns true if a file exists with the given C<path>.
339             #pod
340             #pod NOTE: This should not be used to check for directories, as not all stores have
341             #pod directories.
342             #pod
343             #pod =cut
344              
345             sub has_file {
346 292     292 1 1053 my ( $self, $path ) = @_;
347 292         825 return $self->path->child( $path )->is_file;
348             }
349              
350             #pod =method files
351             #pod
352             #pod my $iter = $store->files
353             #pod
354             #pod Returns an iterator which iterates over I<all> files in the store,
355             #pod regardless of type of file. The iterator returns a L<Path::Tiny>
356             #pod object or undef if no files remain. It is used by L<find_files>.
357             #pod
358             #pod =cut
359              
360             sub files {
361 190     190 1 512 my ( $self ) = @_;
362 190         1428 return $self->path->iterator({ recurse => 1 });
363             }
364              
365              
366             #pod =method find_files
367             #pod
368             #pod my $iter = $store->find_files( %opt )
369             #pod while ( my $path = $iter->() ) {
370             #pod # ...
371             #pod }
372             #pod
373             #pod Returns an iterator that, when called, produces a single path suitable to be passed
374             #pod to L<read_file>.
375             #pod
376             #pod Available options are:
377             #pod
378             #pod include_documents - If true, will include files that look like documents.
379             #pod Defaults to false.
380             #pod
381             #pod It obtains its list of files from L<files>.
382             #pod
383             #pod =cut
384              
385             sub find_files {
386 190     190 1 83131 my ( $self, %opt ) = @_;
387 190         4051 $self->_check_exists;
388 190         4806 my $iter = $self->files;
389             return sub {
390 2835     2835   516899 my $path;
391 2835         6169 while ( $path = $iter->() ) {
392 5580 100       513818 next if $path->is_dir;
393 3161 100       29894 next if !$self->_is_owned_path( $path );
394 2652 100 100     7125 next if !$opt{include_documents} && $self->is_document( $path );
395 2645         4058 last;
396             }
397 2835 100       13267 return unless $path; # iterator exhausted
398 2645         9702 return $path->relative( $self->path )->absolute( '/' );
399 190         7394 };
400             }
401              
402             #pod =method open_file
403             #pod
404             #pod my $fh = $store->open_file( $path )
405             #pod
406             #pod Open the file with the given path. Returns a filehandle.
407             #pod
408             #pod The filehandle opened is using raw bytes, not UTF-8 characters.
409             #pod
410             #pod =cut
411              
412             sub open_file {
413 1     1 1 212 my ( $self, $path ) = @_;
414 1         4 return $self->path->child( $path )->openr_raw;
415             }
416              
417             #pod =method write_file
418             #pod
419             #pod $store->write_file( $path, $content );
420             #pod
421             #pod Write the given C<content> to the given C<path>. This is mostly used to write
422             #pod out L<page objects|Statocles::Page>.
423             #pod
424             #pod C<content> may be a simple string or a filehandle. If given a string, will
425             #pod write the string using UTF-8 characters. If given a filehandle, will write out
426             #pod the raw bytes read from it with no special encoding.
427             #pod
428             #pod =cut
429              
430             sub write_file {
431 1457     1457 1 1302071 my ( $self, $path, $content ) = @_;
432 1457         10993 site->log->debug( "Write file: " . $path );
433 1457         80473 my $full_path = $self->path->child( $path );
434              
435 1457 100 66     73369 if ( ref $content eq 'GLOB' ) {
    100          
436 2         8 my $fh = $full_path->touchpath->openw_raw;
437 2         751 while ( my $line = <$content> ) {
438 25         142 $fh->print( $line );
439             }
440             }
441             elsif ( blessed $content && $content->isa( 'Path::Tiny' ) ) {
442 485         1567 $content->copy( $full_path->touchpath );
443             }
444             else {
445 970         3875 $full_path->touchpath->spew_utf8( $content );
446             }
447              
448 1457         1093582 return;
449             }
450              
451             #pod =method remove
452             #pod
453             #pod $store->remove( $path )
454             #pod
455             #pod Remove the given path from the store. If the path is a directory, the entire
456             #pod directory is removed.
457             #pod
458             #pod =cut
459              
460             sub remove {
461 2     2 1 369 my ( $self, $path ) = @_;
462 2         8 $self->path->child( $path )->remove_tree;
463 2         1003 return;
464             }
465              
466             1;
467              
468             __END__
469              
470             =pod
471              
472             =encoding UTF-8
473              
474             =head1 NAME
475              
476             Statocles::Store - The source for data documents and files
477              
478             =head1 VERSION
479              
480             version 0.086
481              
482             =head1 DESCRIPTION
483              
484             A Statocles::Store reads and writes L<documents|Statocles::Document> and
485             files (mostly L<pages|Statocles::Page>).
486              
487             This class also handles the parsing and inflating of
488             L<"document objects"|Statocles::Document>.
489              
490             =head2 Frontmatter Document Format
491              
492             Documents are formatted with a YAML document on top, and Markdown content
493             on the bottom, like so:
494              
495             ---
496             title: This is a title
497             author: preaction
498             ---
499             # This is the markdown content
500            
501             This is a paragraph
502              
503             =head1 ATTRIBUTES
504              
505             =head2 path
506              
507             The path to the directory containing the L<documents|Statocles::Document>.
508              
509             =head2 document_extensions
510              
511             An array of file extensions that should be considered documents. Defaults to
512             "markdown" and "md".
513              
514             =head2 documents
515              
516             All the L<documents|Statocles::Document> currently read by this store.
517              
518             =head1 METHODS
519              
520             =head2 clear
521              
522             $store->clear;
523              
524             Clear the cached documents in this Store.
525              
526             =head2 read_documents
527              
528             my $docs = $store->read_documents;
529              
530             Read the directory C<path> and create the L<document
531             objects|Statocles::Document> inside. Returns an arrayref of document objects.
532              
533             =head2 read_document
534              
535             my $doc = $store->read_document( $path )
536              
537             Read a single L<document|Statocles::Document> in Markdown with optional YAML
538             or JSON frontmatter.
539              
540             =head2 parse_frontmatter
541              
542             my %doc_attrs = $store->parse_frontmatter( $from, $content )
543              
544             Parse a document with YAML frontmatter. $from is a string identifying where the
545             content comes from (a path or other identifier). $content is the content to
546             parse for frontmatter.
547              
548             =head2 write_document
549              
550             $store->write_document( $path, $doc );
551              
552             Write a L<document|Statocles::Document> to the store at the given store path.
553              
554             The document is written in Frontmatter format.
555              
556             =head2 is_document
557              
558             my $bool = $store->is_document( $path );
559              
560             Returns true if the path looks like a document path (matches the L</document_extensions>).
561              
562             =head2 read_file
563              
564             my $content = $store->read_file( $path )
565              
566             Read the file from the given C<path>.
567              
568             =head2 has_file
569              
570             my $bool = $store->has_file( $path )
571              
572             Returns true if a file exists with the given C<path>.
573              
574             NOTE: This should not be used to check for directories, as not all stores have
575             directories.
576              
577             =head2 files
578              
579             my $iter = $store->files
580              
581             Returns an iterator which iterates over I<all> files in the store,
582             regardless of type of file. The iterator returns a L<Path::Tiny>
583             object or undef if no files remain. It is used by L<find_files>.
584              
585             =head2 find_files
586              
587             my $iter = $store->find_files( %opt )
588             while ( my $path = $iter->() ) {
589             # ...
590             }
591              
592             Returns an iterator that, when called, produces a single path suitable to be passed
593             to L<read_file>.
594              
595             Available options are:
596              
597             include_documents - If true, will include files that look like documents.
598             Defaults to false.
599              
600             It obtains its list of files from L<files>.
601              
602             =head2 open_file
603              
604             my $fh = $store->open_file( $path )
605              
606             Open the file with the given path. Returns a filehandle.
607              
608             The filehandle opened is using raw bytes, not UTF-8 characters.
609              
610             =head2 write_file
611              
612             $store->write_file( $path, $content );
613              
614             Write the given C<content> to the given C<path>. This is mostly used to write
615             out L<page objects|Statocles::Page>.
616              
617             C<content> may be a simple string or a filehandle. If given a string, will
618             write the string using UTF-8 characters. If given a filehandle, will write out
619             the raw bytes read from it with no special encoding.
620              
621             =head2 remove
622              
623             $store->remove( $path )
624              
625             Remove the given path from the store. If the path is a directory, the entire
626             directory is removed.
627              
628             =head1 AUTHOR
629              
630             Doug Bell <preaction@cpan.org>
631              
632             =head1 COPYRIGHT AND LICENSE
633              
634             This software is copyright (c) 2016 by Doug Bell.
635              
636             This is free software; you can redistribute it and/or modify it under
637             the same terms as the Perl 5 programming language system itself.
638              
639             =cut