You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
611 lines
12 KiB
611 lines
12 KiB
package App::WRT::EntryStore;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use 5.10.0;
|
|
|
|
use File::Find;
|
|
use Carp;
|
|
use App::WRT::Sort qw(sort_entries);
|
|
use App::WRT::Util qw(file_get_contents);
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
App::WRT::EntryStore - model the contents of a wrt repo's entry_dir
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use App::WRT::EntryStore;
|
|
my $entries = App::WRT::EntryStore->new('./archives');
|
|
|
|
my @all = $entries->all();
|
|
my @months = $entries->all_months();
|
|
my @years = $entries->all_years();
|
|
my @days = $entries->all_days();
|
|
|
|
# all_* are wrappers for dates_by_depth():
|
|
my @days = $entries->dates_by_depth(
|
|
3 # 1 for years, 2 for months, 3 for days
|
|
);
|
|
|
|
my @recent_days = $entries->recent_days(30);
|
|
my @recent_months = $entries->recent_months(12);
|
|
my @recent_years = $entries->recent_years(10);
|
|
|
|
# recent_* are wrappers for recent_by_depth():
|
|
my @recent_days $entries->recent_by_depth(
|
|
3, # 1 for years, 2 for months, 3 for days
|
|
30 # count
|
|
);
|
|
|
|
=cut
|
|
|
|
# "Constants"
|
|
|
|
my $ENTRYTYPE_FILE = 0;
|
|
my $ENTRYTYPE_DIR = 1;
|
|
my $ENTRYTYPE_VIRT = 2;
|
|
|
|
my %SUBENTRY_IGNORE = ('index' => 1);
|
|
my $SUBENTRY_EXPR = qr{
|
|
^
|
|
[[:lower:][:digit:]_-]+
|
|
(
|
|
[.]
|
|
(tgz|zip|tar[.]gz|gz|txt)
|
|
)?
|
|
$
|
|
}x;
|
|
|
|
# What gets considered a renderable entry path:
|
|
my $RENDERABLE_EXPR = qr{
|
|
^
|
|
(
|
|
[[:lower:][:digit:]_\/-]+
|
|
)
|
|
$
|
|
}x;
|
|
|
|
=head1 METHODS
|
|
|
|
=over
|
|
|
|
=item new($class, $entry_dir)
|
|
|
|
Get a new EntryStore, using a given $entry_dir.
|
|
|
|
Finds a list of entries for the given directory, and builds data structures
|
|
which can be used to index into entries by depth, property, and next/previous
|
|
entry.
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my ($entry_dir) = @_;
|
|
|
|
my %params = (
|
|
entry_dir => $entry_dir
|
|
);
|
|
|
|
my $self = \%params;
|
|
|
|
bless $self, $class;
|
|
|
|
my @entries;
|
|
my %source_files;
|
|
my %entry_properties;
|
|
my %property_entries;
|
|
my %children;
|
|
|
|
find(
|
|
sub {
|
|
return unless $File::Find::name =~ m{^ \Q$entry_dir\E / (.*) $}x;
|
|
|
|
my $target = $1;
|
|
|
|
# Build an ordered array of entries:
|
|
push @entries, $target;
|
|
|
|
# Build a hash indicating:
|
|
# a. that a file exists
|
|
# b. whether it's a flatfile or a directory
|
|
if (-f $_) {
|
|
$source_files{$target} = $ENTRYTYPE_FILE;
|
|
} elsif (-d $_) {
|
|
$source_files{$target} = $ENTRYTYPE_DIR;
|
|
}
|
|
|
|
# Build hashes of all properties of entries, and all entries of properties:
|
|
if ($target =~ m{(.*) / (.*) [.]prop $}x) {
|
|
my ($entry, $property) = ($1, $2);
|
|
|
|
$entry_properties{$entry} //= [];
|
|
push @{ $entry_properties{$entry} }, $property;
|
|
|
|
$property_entries{$property} //= [];
|
|
push @{ $property_entries{$property} }, $entry;
|
|
}
|
|
},
|
|
$entry_dir
|
|
);
|
|
|
|
# Ensure that the entry list for every property is sorted:
|
|
for (keys %property_entries) {
|
|
$property_entries{$_} = [ sort_entries(@{ $property_entries{$_} }) ];
|
|
}
|
|
|
|
# Create virtual entries based on tags, _if there's not already a file
|
|
# there_:
|
|
foreach my $prop (keys %property_entries) {
|
|
if ( $prop =~ m/^ tag[.] (.*)$/x ) {
|
|
my $tag = $1;
|
|
$tag =~ s{[.]}{/}g;
|
|
unless (defined $source_files{$tag}) {
|
|
push @entries, $tag;
|
|
$source_files{$tag} = $ENTRYTYPE_VIRT;
|
|
}
|
|
}
|
|
}
|
|
|
|
# Stash refs for future use:
|
|
$self->{entries} = \@entries;
|
|
$self->{source_files} = \%source_files;
|
|
$self->{property_entries} = \%property_entries;
|
|
$self->{entry_properties} = \%entry_properties;
|
|
|
|
$self->generate_date_hashes();
|
|
$self->store_children();
|
|
|
|
return $self;
|
|
}
|
|
|
|
=item all()
|
|
|
|
Returns a list of all source files for the current entry archive (excepting
|
|
index files, which are a special case - this part could use some work).
|
|
|
|
This was originally in App::WRT::Renderer, so there may be some pitfalls here.
|
|
|
|
=cut
|
|
|
|
sub all {
|
|
my ($self) = shift;
|
|
return @{ $self->{entries} };
|
|
}
|
|
|
|
=item all_renderable()
|
|
|
|
Returns a list of all existing source paths which are considered "renderable".
|
|
|
|
A path should match C<$RENDERABLE_EXPR> and not be an index file.
|
|
|
|
=cut
|
|
|
|
sub all_renderable() {
|
|
my ($self) = shift;
|
|
return grep {
|
|
(index($_, '/index', -6) == -1)
|
|
&&
|
|
m/$RENDERABLE_EXPR/
|
|
} @{ $self->{entries} };
|
|
}
|
|
|
|
=item dates_by_depth($depth)
|
|
|
|
Returns a sorted list of all date-like entries which are at a specified depth.
|
|
Use 1 for years, 2 for months, and 3 for days.
|
|
|
|
Fairly silly, but entertaining in its perverse way. all_years(), all_months(),
|
|
and all_days() are provided for convenience.
|
|
|
|
=cut
|
|
|
|
sub dates_by_depth {
|
|
my ($self) = shift;
|
|
my ($depth) = @_;
|
|
|
|
croak('No $depth given.')
|
|
unless defined $depth;
|
|
|
|
# Check if we already have a value cached:
|
|
return @{ $self->{by_depth}->{$depth} }
|
|
if defined $self->{by_depth}->{$depth};
|
|
|
|
# Build a pattern for matching the given depth of date-like entries. For
|
|
# example, a day would be depth 3, and matched by \d+/\d+/\d+
|
|
my @particles;
|
|
for (my $i = 0; $i < $depth; $i++) {
|
|
push @particles, '\d+';
|
|
}
|
|
my $pattern = join '/', @particles;
|
|
|
|
my @by_depth = sort_entries(
|
|
grep m{^ $pattern $}x, $self->all()
|
|
);
|
|
|
|
# Stash arrayref for future use:
|
|
$self->{by_depth}->{$depth} = \@by_depth;
|
|
|
|
return @by_depth;
|
|
}
|
|
|
|
=item all_years(), all_months(), all_days()
|
|
|
|
Convenience wrappers for dates_by_depth().
|
|
|
|
=cut
|
|
|
|
sub all_years { return $_[0]->dates_by_depth(1); }
|
|
sub all_months { return $_[0]->dates_by_depth(2); }
|
|
sub all_days { return $_[0]->dates_by_depth(3); }
|
|
|
|
=item days_for($month), months_for($year)
|
|
|
|
Convenience wrappers for extracting days or months in a given month
|
|
or year.
|
|
|
|
=cut
|
|
|
|
sub days_for {
|
|
my ($self, $container) = @_;
|
|
return grep { m{^ \Q$container\E / }x } $self->all_days();
|
|
}
|
|
|
|
sub months_for {
|
|
my ($self, $year) = @_;
|
|
return grep { m{^ \Q$year\E / }x } $self->all_months();
|
|
}
|
|
|
|
=item recent_by_depth($depth, $entry_count)
|
|
|
|
Returns the $entry_count most recent dated entries at $depth (1 for year, 2 for
|
|
month, 3 for day). recent_years(), recent_months(), and recent_days() are
|
|
provided for convenience.
|
|
|
|
=cut
|
|
|
|
sub recent_by_depth {
|
|
my ($self) = shift;
|
|
my ($depth, $entry_count) = @_;
|
|
|
|
my @entries;
|
|
for my $entry (reverse $self->dates_by_depth($depth)) {
|
|
last if scalar(@entries) == $entry_count;
|
|
push @entries, $entry;
|
|
}
|
|
|
|
return @entries;
|
|
}
|
|
|
|
=item all_years(), all_months(), all_days()
|
|
|
|
Convenience wrappers for recent_by_depth().
|
|
|
|
=cut
|
|
|
|
sub recent_years { return $_[0]->recent_by_depth(1, $_[1]); }
|
|
sub recent_months { return $_[0]->recent_by_depth(2, $_[1]); }
|
|
sub recent_days { return $_[0]->recent_by_depth(3, $_[1]); }
|
|
|
|
=item generate_date_hashes()
|
|
|
|
Store hashes which map dated entries to their previous and next entries at the
|
|
same depth in the tree. That is, something like:
|
|
|
|
%prev_dates = {
|
|
'2014' => '2013',
|
|
'2014/1' => '2013/12'
|
|
'2014/1/1' => '2013/12/30',
|
|
...
|
|
}
|
|
|
|
%next_dates = {
|
|
'2013' => '2014',
|
|
'2013/12' => '2014/1',
|
|
'2013/12/30' => '2014/1/1',
|
|
...
|
|
}
|
|
|
|
=cut
|
|
|
|
sub generate_date_hashes {
|
|
my $self = shift;
|
|
|
|
my %prev;
|
|
|
|
# Depth 1 is years, 2 is months, 3 is days. Get lists for all:
|
|
for my $depth (1, 2, 3) {
|
|
my @dates = $self->dates_by_depth($depth);
|
|
|
|
my $last_seen;
|
|
foreach my $current_date (@dates) {
|
|
if ($last_seen) {
|
|
$prev{$current_date} = $last_seen;
|
|
}
|
|
$last_seen = $current_date;
|
|
}
|
|
}
|
|
|
|
$self->{prev_dates} = { %prev };
|
|
$self->{next_dates} = { reverse %prev };
|
|
}
|
|
|
|
=item store_children
|
|
|
|
Store hashes of arrayrefs which maps parents to their immediate children.
|
|
|
|
=cut
|
|
|
|
sub store_children {
|
|
my $self = shift;
|
|
|
|
my %child_cache;
|
|
|
|
for my $entry ($self->all()) {
|
|
my $dirname = $self->dirname($entry);
|
|
$child_cache{$dirname} //= [ ];
|
|
push @{ $child_cache{$dirname} }, $entry;
|
|
}
|
|
|
|
$self->{child_cache} = { %child_cache };
|
|
}
|
|
|
|
=item parent($entry)
|
|
|
|
Return an entry's parent, or undef if it's at the top level.
|
|
|
|
=cut
|
|
|
|
sub parent {
|
|
my $self = shift;
|
|
my ($entry) = @_;
|
|
|
|
# Explode unless an entry actually exists in the archives:
|
|
croak("No such entry: $entry") unless $self->is_extant($entry);
|
|
|
|
my (@components) = split '/', $entry;
|
|
pop @components;
|
|
if (@components) {
|
|
return join '/', @components;
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
=item children($entry)
|
|
|
|
Return an entry's (immediate) children, if any.
|
|
|
|
=cut
|
|
|
|
sub children {
|
|
my $self = shift;
|
|
my ($entry) = @_;
|
|
|
|
# Explode unless an entry actually exists in the archives:
|
|
croak("No such entry: $entry") unless $self->is_extant($entry);
|
|
|
|
if (defined $self->{child_cache}{$entry}) {
|
|
return @{ $self->{child_cache}{$entry} };
|
|
}
|
|
return ();
|
|
}
|
|
|
|
=item children_basenames($entry)
|
|
|
|
Returns an entry's immediate children, but just basenames - not full paths.
|
|
|
|
=cut
|
|
|
|
sub children_basenames {
|
|
my $self = shift;
|
|
my ($entry) = @_;
|
|
|
|
return map { $self->basename($_) } $self->children($entry);
|
|
}
|
|
|
|
=item get_sub_entries($entry_loc)
|
|
|
|
Returns "sub entries" based on the C<SUBENTRY_EXPR> regexp.
|
|
|
|
=cut
|
|
|
|
sub get_sub_entries {
|
|
my ($self, $entry) = @_;
|
|
|
|
# index gets special treatment as the text body of an entry, rather
|
|
# than as a sub-entry:
|
|
my @subs = grep { m/$SUBENTRY_EXPR/ } $self->children_basenames($entry);
|
|
return sort grep { ! $SUBENTRY_IGNORE{$_} } @subs;
|
|
|
|
# return grep { ! $SUBENTRY_IGNORE{$_} }
|
|
# grep { m/$SUBENTRY_EXPR/ }
|
|
# $self->children_basenames($entry);
|
|
}
|
|
|
|
=item previous($entry)
|
|
|
|
Return the previous entry at the same depth for the given entry.
|
|
|
|
=cut
|
|
|
|
sub previous {
|
|
return $_[0]->{prev_dates}->{ $_[1] };
|
|
}
|
|
|
|
=item next($entry)
|
|
|
|
Return the next entry at the same depth for the given entry.
|
|
|
|
=cut
|
|
|
|
sub next {
|
|
return $_[0]->{next_dates}->{ $_[1] };
|
|
}
|
|
|
|
=item by_prop($property)
|
|
|
|
Return an array of any entries for the given property.
|
|
|
|
=cut
|
|
|
|
sub by_prop {
|
|
my ($self, $property) = @_;
|
|
|
|
my @entries;
|
|
if (defined $self->{property_entries}{$property}) {
|
|
@entries = @{ $self->{property_entries}{$property} };
|
|
}
|
|
|
|
return @entries;
|
|
}
|
|
|
|
=item props_for($entry)
|
|
|
|
Return an array of any properties for the given entry.
|
|
|
|
=cut
|
|
|
|
sub props_for {
|
|
my ($self, $entry) = @_;
|
|
|
|
my @props;
|
|
if (defined $self->{entry_properties}{$entry}) {
|
|
@props = @{ $self->{entry_properties}{$entry} };
|
|
}
|
|
|
|
return @props;
|
|
}
|
|
|
|
=item has_prop($entry, $prop)
|
|
|
|
Return 1 if the given entry has the given property.
|
|
|
|
=cut
|
|
|
|
sub has_prop {
|
|
my ($self, $entry, $prop) = @_;
|
|
my @props = grep { $_ eq $prop } $self->props_for($entry);
|
|
return (@props == 1);
|
|
}
|
|
|
|
=item prop_value($entry, $prop)
|
|
|
|
Return the value of given property, if it exists. Otherwise return undef.
|
|
|
|
=cut
|
|
|
|
sub prop_value {
|
|
my ($self, $entry, $prop) = @_;
|
|
if ($self->has_prop($entry, $prop)) {
|
|
return file_get_contents(
|
|
$self->{entry_dir} . '/' . $entry . '/' . $prop . '.prop'
|
|
);
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
=item all_props()
|
|
|
|
Return an array of all properties.
|
|
|
|
=cut
|
|
|
|
sub all_props {
|
|
my $self = shift;
|
|
return sort keys %{ $self->{property_entries} };
|
|
}
|
|
|
|
=item is_extant($entry)
|
|
|
|
Check if a given entry exists.
|
|
|
|
=cut
|
|
|
|
sub is_extant {
|
|
my ($self, $entry) = @_;
|
|
return exists($self->{source_files}{$entry});
|
|
}
|
|
|
|
=item is_dir($entry)
|
|
|
|
Check if an entry is a directory.
|
|
|
|
=cut
|
|
|
|
sub is_dir {
|
|
my ($self, $entry) = @_;
|
|
croak("No such entry: $entry") unless $self->is_extant($entry);
|
|
return ($self->{source_files}{$entry} == $ENTRYTYPE_DIR);
|
|
}
|
|
|
|
=item is_file($entry)
|
|
|
|
Check if an entry is a flatfile.
|
|
|
|
=cut
|
|
|
|
sub is_file {
|
|
my ($self, $entry) = @_;
|
|
croak("No such entry: $entry") unless $self->is_extant($entry);
|
|
return ($self->{source_files}{$entry} == $ENTRYTYPE_FILE);
|
|
}
|
|
|
|
=item is_renderable($entry)
|
|
|
|
Check if an entry path is, theoretically, renderable.
|
|
|
|
=cut
|
|
|
|
sub is_renderable {
|
|
my ($self, $entry) = @_;
|
|
return ($entry =~ $RENDERABLE_EXPR);
|
|
}
|
|
|
|
=item has_index($entry)
|
|
|
|
Check if an entry contains an index file.
|
|
|
|
TODO: Should this care about the pathological (?) case where index is a
|
|
directory?
|
|
|
|
=cut
|
|
|
|
sub has_index {
|
|
my ($self, $entry) = @_;
|
|
croak("No such entry: $entry") unless $self->is_extant($entry);
|
|
return $self->is_extant($entry . '/index');
|
|
}
|
|
|
|
=item basename($entry)
|
|
|
|
Get a base name (i.e., filename without path) for a given entry.
|
|
|
|
=cut
|
|
|
|
sub basename {
|
|
my ($self, $entry) = @_;
|
|
my @parts = split '/', $entry;
|
|
return pop @parts;
|
|
}
|
|
|
|
=item dirname($entry)
|
|
|
|
Get a directory name (i.e., directory without filename) for a given entry.
|
|
|
|
=cut
|
|
|
|
sub dirname {
|
|
my ($self, $entry) = @_;
|
|
my @parts = split '/', $entry;
|
|
pop @parts;
|
|
return join '/', @parts;
|
|
}
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
1;
|