added writers

git-svn-id: svn://luxion/repos/WebCoso/trunk@282 fcb26f47-9200-0410-b104-b98ab5b095f3

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)=@_;
 
diff --git a/t/fcp-01.t b/t/fcp-01.t
index 9570b58..4d52258 100644
--- a/t/fcp-01.t
+++ b/t/fcp-01.t
@@ -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)');
+}