diff options
-rw-r--r-- | lib/File/Cache/Parsed.pm | 30 | ||||
-rw-r--r-- | t/fcp-01.t | 43 |
2 files changed, 73 insertions, 0 deletions
diff --git a/lib/File/Cache/Parsed.pm b/lib/File/Cache/Parsed.pm index 9e980ef..7792cf1 100644 --- a/lib/File/Cache/Parsed.pm +++ b/lib/File/Cache/Parsed.pm @@ -4,12 +4,14 @@ use warnings; use List::Util qw(first); use List::MoreUtils qw(firstidx); use Path::Class; +use Carp; sub new { my ($class)=@_; return bless { parsers=>[], + writers=>[], cache=>{}, }=>$class; } @@ -27,6 +29,19 @@ sub add_parser { 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)=@_; @@ -56,6 +71,21 @@ sub get { } } +sub put { + my ($self,$filename,$contents)=@_; + + my $ww=first {$filename =~ m{$_->[0]}} @{$self->{writers}}; + if ($ww) { + return $ww->[1]->($filename,$contents); + } + elsif (!ref($contents)) { + return print {file($filename)->openw} $contents; + } + else { + croak "'$contents' is not a scalar, and no writer defined for the name '$filename'"; + } +} + sub invalidate { my ($self,$rx)=@_; @@ -2,7 +2,9 @@ use strict; use warnings; use Test::More qw(no_plan); +use Test::Exception; use Path::Class; +use File::Temp; BEGIN { use_ok('File::Cache::Parsed') or die } @@ -10,8 +12,12 @@ my $fc=File::Cache::Parsed->new(); my %calls; $fc->add_parser(qr{\.t$} => sub { $calls{t}++;return ['t',@_] }); $fc->add_parser(qr{\.pm$} => sub { $calls{pm}++;return ['pm',@_] }); +$fc->add_writer(qr{\.stuff$} => sub { $calls{stuff}++; + print {file($_[0])->openw} "gino\n",$_[1]; }); my $base=file(__FILE__)->parent->parent; + +{ my $module_file=$base->file('lib','File','Cache','Parsed.pm'); my $module_contents=$module_file->slurp; my $test_file=$base->file('t','fcp-01.t'); @@ -37,3 +43,40 @@ is($fc->get($test_file->stringify), is($fc->get($test_file), $test_contents, 'cache ok 2'); +} + +{ +my $wr_tfile=File::Temp->new(SUFFIX=>'.stuff'); +my $wr_file=file("$wr_tfile"); +my $wr_contents="something\nor\nother\n"; + +$fc->put($wr_file->stringify,$wr_contents); +is($calls{stuff},1,'called ok 3'); +is($wr_file->slurp,"gino\n$wr_contents",'written ok'); +$fc->put($wr_file->stringify,$wr_contents.2); +is($calls{stuff},2,'no caching on write'); +is($wr_file->slurp,"gino\n${wr_contents}2",'written ok 2'); +} + +{ +my $wr_tfile=File::Temp->new(SUFFIX=>'.none'); +my $wr_file=file("$wr_tfile"); +my $wr_contents="something\nor\nother\n"; + +$fc->put($wr_file->stringify,$wr_contents); +is($calls{stuff},2,'defaulh writer'); +is($wr_file->slurp,$wr_contents,'written ok passthrough'); +$wr_contents={bad=>'stuff'}; +throws_ok(sub {$fc->put($wr_file->stringify,$wr_contents)}, + qr/not a scalar/i, + 'exception on putting a ref with the default writer'); +} +{ +my $wr_tfile=File::Temp->new(SUFFIX=>'.stuff'); +my $wr_file=file("$wr_tfile"); +my $wr_contents={good=>'stuff'}; + +$fc->put($wr_file->stringify,$wr_contents); +is($calls{stuff},3,'called ok 4'); +is($wr_file->slurp,"gino\n${wr_contents}",'written ok 3 (ref)'); +} |