Merge branch 'master' of https://github.com/norbu09/Store-CouchDB

README.pod

@@ -8,7 +8,7 @@ Store::CouchDB - Store::CouchDB - a simple CouchDB driver
 
 =head1 VERSION
 
-version 3.8
+version 3.9
 
 =head1 SYNOPSIS
 
@@ -285,6 +285,12 @@ Get a file attachement from a CouchDB document.
 
     my $content = $sc->get_file({ id => 'doc_id', filename => 'file.txt' });
 
+=head2 del_file
+
+Delete a file attachement from a CouchDB document.
+
+    my $content = $sc->del_file({ id => 'doc_id', filename => 'file.txt' });
+
 =head2 config
 
 This can be called with a hash of config values to configure the databse

lib/Store/CouchDB.pm

@@ -1,12 +1,16 @@
 package Store::CouchDB;
 
+use strict;
+use warnings;
+
 use Moo;
 use MooX::Types::MooseLike::Base qw(:all);
 
+
+
 # ABSTRACT: Store::CouchDB - a simple CouchDB driver
 
 # VERSION
-
 use JSON;
 use LWP::UserAgent;
 use URI::Escape;
@@ -984,6 +988,49 @@ sub get_file {
     return $self->_call($path);
 }
 
+=head2 del_file
+
+Delete a file attachement from a CouchDB document.
+
+    my $content = $sc->del_file({ id => 'doc_id', filename => 'file.txt' });
+
+=cut
+
+sub del_file {
+    my ($self, $data) = @_;
+
+    unless ($data->{file}) {
+        carp 'File content not defined';
+        return;
+    }
+    unless ($data->{filename}) {
+        carp 'File name not defined';
+        return;
+    }
+
+    $self->_check_db($data);
+
+    my $id  = $data->{id}  || $data->{doc}->{_id};
+    my $rev = $data->{rev} || $data->{doc}->{_rev};
+
+    unless ($id) {
+        carp 'No document specified';
+        return;
+    }
+
+    if (!$rev && $id) {
+        $rev = $self->head_doc($id);
+        $self->_log("delete_file(): rev $rev") if $self->debug;
+    }
+
+    my $path = $self->db . '/' . $id . '/' . $data->{filename} . '?rev=' . $rev;
+    $self->method('DELETE');
+    my $res = $self->_call($path);
+
+    return ($res->{id}, $res->{rev}) if wantarray;
+    return $res->{id};
+}
+
 =head2 config
 
 This can be called with a hash of config values to configure the databse
@@ -1110,7 +1157,11 @@ sub _uri_encode {
             }
         }
 
-        $value = uri_escape($self->json->encode($value));
+        $value = $self->json->encode($value);
+        # remove the quotes from strings Could it be that newer versions of CouchDB do not like it :-(
+        # removing this line will make the $sc->changes test fail :-(
+        $value =~ s/^["]|["]$//g;
+        $value = uri_escape($value);
         $path .= $key . '=' . $value . '&';
     }
 

t/01-example.t

@@ -2,14 +2,16 @@
 
 use strict;
 use warnings;
-use Test::More tests => 29;
+use Test::More tests => 40;
 
 BEGIN { use_ok('Store::CouchDB'); }
 
 use Store::CouchDB;
 use Scalar::Util qw(looks_like_number);
 
 my $sc      = Store::CouchDB->new();
+$sc         = Store::CouchDB->new(host => '127.0.0.1') if ($sc->has_error);
+
 my $db      = 'store_couchdb_' . time;
 my $cleanup = 0;
 
@@ -18,7 +20,7 @@ my $cleanup = 0;
 $sc->delete_db($db);
 
 SKIP: {
-    skip 'needs admin party CouchDB on localhost:5984', 28
+    skip 'needs admin party CouchDB on localhost:5984', 39
         if ($sc->has_error and $sc->error !~ m/Object Not Found/);
 
     # operate on test DB from now on
@@ -220,6 +222,10 @@ SKIP: {
         { file => 'content', content_type => 'text/plain' },
         'get attachment'
     );
+
+    # delete file
+    my ($id2, $rev2) = $sc->del_file({id=>$id, filename => 'file.txt'});
+    ok(($id eq $id2 and $rev ne $rev2 and $rev2 =~ m/3-/), "delete attachment");
 
     # create doc (single variable return)
     my $newid = $sc->put_doc({ doc => { key => 'somevalue' } });
@@ -228,30 +234,24 @@ SKIP: {
     # all_docs
     $result = $sc->all_docs;
     @result = sort { $a->{value}->{rev} cmp $b->{value}->{rev} } @$result;
-    ok((
-                    scalar(@result) == 4
-                and $result[0]->{value}->{rev} =~ m/1-/
-                and $result[1]->{value}->{rev} =~ m/1-/
-                and $result[2]->{value}->{rev} =~ m/2-/
-                and $result[3]->{value}->{rev} =~ m/2-/
-        ),
-        "all docs"
-    );
+    ok((scalar(@result) == 4), "all docs, docs size");
+    ok(($result[0]->{value}->{rev} =~ m/1-/), "all docs, 0: rev of doc 31435");
+    ok((not exists $result[0]->{doc}), "all docs, 0: doc contains no content");
+    ok(($result[1]->{value}->{rev} =~ m/1-/), "all docs, 1: rev of doc _design/test");
+    ok(($result[2]->{value}->{rev} =~ m/2-/), "all docs, 2: rev of doc (random, attachement)");
+    ok(($result[3]->{value}->{rev} =~ m/3-/), "all docs, 3: rev of doc (random, somevalue)");
 
     # all_docs (include_docs)
     $result = $sc->all_docs({ include_docs => 'true' });
     @result = sort { $a->{value}->{rev} cmp $b->{value}->{rev} } @$result;
-    ok((
-                    scalar(@result) == 4
-                and $result[0]->{value}->{rev} =~ m/1-/
-                and $result[1]->{value}->{rev} =~ m/1-/
-                and $result[2]->{value}->{rev} =~ m/2-/
-                and $result[3]->{value}->{rev} =~ m/2-/
-                and exists $result[0]->{doc}
-        ),
-        "all docs (include_docs)"
-    );
-
+    ok((scalar(@result) == 4), "all docs (include_docs), docs size");
+    ok(($result[0]->{value}->{rev} =~ m/1-/), "all docs (include_docs), 0: rev of doc 31435");
+    ok((exists $result[0]->{doc}), "all docs (include_docs), 0: doc contains content");
+    ok(($result[1]->{value}->{rev} =~ m/1-/), "all docs (include_docs), 1: rev of doc _design/test");
+    ok(($result[2]->{value}->{rev} =~ m/2-/), "all docs (include_docs), 2: rev of doc (random, attachement)");
+    ok(($result[3]->{value}->{rev} =~ m/3-/), "all docs (include_docs), 3: rev of doc (random, somevalue)");
+
+    # test the changes feed
     $result = $sc->changes({
         limit        => 100,
         doc_ids      => ['_design/test'],