1 files changed, 314 insertions, 0 deletions
diff --git a/lib/Test/StagedFileProducer.pm b/lib/Test/StagedFileProducer.pm
new file mode 100644
index 0000000..ada9069
--- /dev/null
+++ b/lib/Test/StagedFileProducer.pm
@@ -0,0 +1,314 @@
+# Copyright (C) 2018 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA
+
+package Test::StagedFileProducer;
+
+=head1 NAME
+
+Test::StagedFileProducer -- mtime-based file production engine
+
+=head1 SYNOPSIS
+
+  use Test::StagedFileProducer;
+
+  my $wherever = '/your/test/directory';
+
+  my $producer = Test::StagedFileProducer->new(path => $wherever);
+  $producer->exclude("$wherever/log", "$wherever/build-stamp");
+
+  my $output = "$wherever/file.out";
+  $producer->add_stage(
+        products => [$output],
+        build =>sub {
+            print encode_utf8("Building $output.\n");
+        },
+        skip =>sub {
+            print encode_utf8("Skipping $output.\n");
+        }
+  );
+
+  $producer->run(minimum_epoch => time, verbose => 1);
+
+=head1 DESCRIPTION
+
+Provides a way to define and stack file production stages that all
+depend on subsets of the same group of files.
+
+After the stages are defined, the processing engine takes an inventory
+of all files in a target directory. It excludes some files, like logs,
+that should not be considered.
+
+Each stage adds its own products to the list of files to be excluded
+before deciding whether to produce them. The decision is based on
+relative file modification times, in addition to a systemic rebuilding
+threshold. Before rebuilding, each stage asks a lower stage to make
+the same determination.
+
+The result is an engine with file production stages that depend on
+successively larger sets of files.
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp;
+use Const::Fast;
+use File::Find::Rule;
+use File::Spec::Functions qw(abs2rel);
+use File::stat;
+use List::Util qw(min max);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Test::Lintian::Helper qw(rfc822date);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item new(path => PATH)
+
+Create a new instance focused on files in directory PATH.
+
+=cut
+
+sub new {
+    my ($class, %params) = @_;
+
+    my $self = bless {}, $class;
+
+    croak encode_utf8('Cannot proceed without a path.')
+      unless exists $params{path};
+    $self->{path} = $params{path};
+
+    $self->{exclude} = [];
+    $self->{stages} = [];
+
+    return $self;
+}
+
+=item exclude(LIST)
+
+Excludes all absolute paths in LIST from all mtime comparisons.
+This is especially useful for logs. Calls to Path::Tiny->realpath
+are made to ensure the elements are canonical and have a chance
+of matching something returned by File::Find::Rule.
+
+=cut
+
+sub exclude {
+    my ($self, @list) = @_;
+
+    push(@{$self->{exclude}}, grep { defined } @list);
+
+    return;
+}
+
+=item add_stage(HASH)
+
+Add a stage defined by HASH to the processing engine for processing
+after stages previously added. HASH can define the following keys:
+
+$HASH{products} => LIST; a list of full-path filenames to be
+produced.
+
+$HASH{minimum_epoch} => EPOCH; an integer threshold for maximum age
+
+$HASH{build} => SUB; a sub executed when production is required.
+
+$HASH{skip} => SUB; a sub executed when production is not required.
+
+=cut
+
+sub add_stage {
+    my ($self, %stage) = @_;
+
+    push(@{$self->{stages}}, \%stage);
+
+    return;
+}
+
+=item run(PARAMETERS)
+
+Runs the defined engine using the given parameters, which are
+arranged in a matching list suitable for assignment to a hash.
+The following two parameters are currently available:
+
+minimum_epoch => EPOCH; a systemic threshold, in epochs, below
+which rebuilding is mandatory for any product.
+
+verbose => BOOLEAN; an option to enable more verbose reporting
+
+=cut
+
+sub run {
+    my ($self, %params) = @_;
+
+    $self->{minimum_epoch} = $params{minimum_epoch} // 0;
+    $self->{verbose} = $params{verbose} // 0;
+
+    # take an mtime inventory of all files in path
+    $self->{mtimes}
+      = { map { $_ => path($_)->stat->mtime }
+          File::Find::Rule->file->in($self->{path}) };
+
+    say encode_utf8(
+        'Found the following file modification times (most recent first):')
+      if $self->{verbose};
+
+    my @ordered= reverse sort { $self->{mtimes}{$a} <=> $self->{mtimes}{$b} }
+      keys %{$self->{mtimes}};
+    foreach my $file (@ordered) {
+        my $relative = abs2rel($file, $self->{path});
+        say encode_utf8(rfc822date($self->{mtimes}{$file}) . " : $relative")
+          if $self->{verbose};
+    }
+
+    $self->_process_remaining_stages(@{$self->{exclude}});
+
+    return;
+}
+
+=item _process_remaining_stages(LIST)
+
+An internal subroutine that is used recursively to execute
+the stages. The list passed describes the list of files to
+be excluded from subsequent mtime calculations.
+
+Please note that the bulk of the execution takes place
+after calling the next lower stage. That is to ensure that
+any lower build targets (or products, in our parlance) are
+met before the present stage attempts to do its job.
+
+=cut
+
+sub _process_remaining_stages {
+    my ($self, @exclude) = @_;
+
+    if (scalar @{$self->{stages}}) {
+
+        # get the next processing stage
+        my %stage = %{ pop(@{$self->{stages}}) };
+
+        # add our products to the list of files excluded
+        my @products = grep { defined } @{$stage{products}//[]};
+        push(@exclude, @products);
+
+        # pass to next lower stage for potential rebuilding
+        $self->_process_remaining_stages(@exclude);
+
+        # get good paths that will match those of File::Find
+        @exclude = map { path($_)->realpath } @exclude;
+
+        say encode_utf8($EMPTY) if $self->{verbose};
+
+        my @relative = sort map { abs2rel($_, $self->{path}) } @products;
+        say encode_utf8(
+            'Considering production of: ' . join($SPACE, @relative))
+          if $self->{verbose};
+
+        say encode_utf8('Excluding: '
+              . join($SPACE, sort map { abs2rel($_, $self->{path}) } @exclude))
+          if $self->{verbose};
+
+        my %relevant = %{$self->{mtimes}};
+        delete @relevant{@exclude};
+
+# my @ordered= reverse sort { $relevant{$a} <=> $relevant{$b} }
+#   keys %relevant;
+# foreach my $file (@ordered) {
+#   say encode_utf8(rfc822date($relevant{$file}) . ' : ' . abs2rel($file, $self->{path}))
+#     if $self->{verbose};
+# }
+
+        say encode_utf8($EMPTY) if $self->{verbose};
+
+        my $file_epoch = (max(values %relevant))//time;
+        say encode_utf8(
+            'Input files modified on      : '. rfc822date($file_epoch))
+          if $self->{verbose};
+
+        my $systemic_minimum_epoch = $self->{minimum_epoch} // 0;
+        say encode_utf8('Systemic minimum epoch is    : '
+              . rfc822date($systemic_minimum_epoch))
+          if $self->{verbose};
+
+        my $stage_minimum_epoch = $stage{minimum_epoch} // 0;
+        say encode_utf8('Stage minimum epoch is       : '
+              . rfc822date($stage_minimum_epoch))
+          if $self->{verbose};
+
+        my $threshold
+          = max($stage_minimum_epoch, $systemic_minimum_epoch, $file_epoch);
+        say encode_utf8(
+            'Rebuild threshold is         : '. rfc822date($threshold))
+          if $self->{verbose};
+
+        say encode_utf8($EMPTY) if $self->{verbose};
+
+        my $product_epoch
+          = min(map { -e ? path($_)->stat->mtime : 0 } @products);
+        if($product_epoch) {
+            say encode_utf8(
+                'Products modified on         : '. rfc822date($product_epoch))
+              if $self->{verbose};
+        } else {
+            say encode_utf8('At least one product is not present.')
+              if $self->{verbose};
+        }
+
+        # not producing if times are equal; resolution 1 sec
+        if ($product_epoch < $threshold) {
+
+            say encode_utf8('Producing: ' . join($SPACE, @relative))
+              if $self->{verbose};
+
+            $stage{build}->() if exists $stage{build};
+
+            # sometimes the products are not the newest files
+            path($_)->touch(time) for @products;
+
+        } else {
+
+            say encode_utf8(
+                'Skipping production of: ' . join($SPACE, @relative))
+              if $self->{verbose};
+
+            $stage{skip}->() if exists $stage{skip};
+        }
+    }
+
+    return;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et