package File::Cache::Parsed;
use strict;
use warnings;
use List::Util qw(first);
use List::MoreUtils qw(firstidx);
use Cwd 'abs_path';
use Path::Class;
use Carp;
use Try::Tiny;
sub new {
my ($class,%opts)=@_;
return bless {
parsers=>[],
writers=>[],
cache=>{},
follow=>$opts{follow},
}=>$class;
}
sub add_parser {
my ($self,$rx,$parser)=@_;
my $old_parser=first {$_->[0] eq $rx} @{$self->{parsers}};
if ($old_parser) {
$old_parser->[1]=$parser;
}
else {
push @{$self->{parsers}},[$rx,$parser];
}
$self->invalidate($rx);
return;
}
sub add_writer {
my ($self,$rx,$writer)=@_;
my $old_writer=first {$_->[0] eq $rx} @{$self->{writers}};
if ($old_writer) {
$old_writer->[1]=$writer;
}
else {
push @{$self->{writers}},[$rx,$writer];
}
return;
}
sub del_parser {
my ($self,$rx)=@_;
my $i=firstidx {$_->[0] eq $rx} @{$self->{parsers}};
return if $i<0;
splice @{$self->{parsers}},$i,1;
$self->invalidate($rx);
return;
}
sub del_writer {
my ($self,$rx)=@_;
my $i=firstidx {$_->[0] eq $rx} @{$self->{writers}};
return if $i<0;
splice @{$self->{writers}},$i,1;
return;
}
sub get {
my ($self,$filename)=@_;
if ($self->{follow}) {
$filename=abs_path($filename);
}
return unless $filename;
return $self->{cache}{$filename} if exists $self->{cache}{$filename};
my $contents=try {file($filename)->slurp} catch {return};
my $pp=first {$filename =~ m{$_->[0]}} @{$self->{parsers}};
if ($pp) {
return $self->{cache}{$filename}=$pp->[1]->($filename,$contents);
}
else {
return $self->{cache}{$filename}=$contents;
}
}
sub stat {
my ($self,$filename)=@_;
if ($self->{follow}) {
$filename=abs_path($filename);
}
return file($filename)->stat;
}
sub put {
my ($self,$filename,$contents)=@_;
my $err;
my $ww=first {$filename =~ m{$_->[0]}} @{$self->{writers}};
if ($ww) {
my $ret=try {$ww->[1]->($filename,$contents)} catch {$err=$_};
unless ($err) {
$self->{cache}{$filename}=$contents;
return $ret;
}
}
if (!ref($contents)) {
my $pp=first {$filename =~ m{$_->[0]}} @{$self->{parsers}};
if ($pp) {
$self->{cache}{$filename}=$pp->[1]->($filename,$contents);
}
else {
$self->{cache}{$filename}=$contents;
}
return print {file($filename)->openw} $contents;
}
else {
if ($err) {
croak "'$contents' is not a scalar, and the writer for the name '$filename' died with: $err";
}
else {
croak "'$contents' is not a scalar, and no writer defined for the name '$filename'";
}
}
}
sub invalidate {
my ($self,$rx)=@_;
my $count=0;
for my $filename (keys %{$self->{cache}}) {
if ($filename =~ m{$rx}) {
delete $self->{cache}{$filename};
++$count;
}
}
return $count;
}
1;
