File Coverage

blib/lib/App/WRT/EntryStore.pm

Criterion	Covered	Total	%
statement	185	187	98.9
branch	34	42	80.9
condition	5	6	83.3
subroutine	39	41	95.1
pod	30	33	90.9
total	293	309	94.8

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 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;