├── README ├── t ├── 05-pod.t ├── 10-pod-coverage.t ├── 00-load.t ├── 12-small-things.t └── 15-client.t ├── MANIFEST.SKIP ├── MANIFEST ├── Makefile.PL └── lib └── CouchDB ├── Client ├── DesignDoc.pm ├── Doc.pm └── DB.pm └── Client.pm /README: -------------------------------------------------------------------------------- 1 | 2 | CouchDB::Client - Simple, correct client for CouchDB 3 | -------------------------------------------------------------------------------- /t/05-pod.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | eval "use Test::Pod 1.14"; 8 | plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; 9 | all_pod_files_ok(); 10 | -------------------------------------------------------------------------------- /t/10-pod-coverage.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | eval "use Test::Pod::Coverage 1.04"; 8 | plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; 9 | all_pod_coverage_ok(); 10 | -------------------------------------------------------------------------------- /t/00-load.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 4; 6 | 7 | BEGIN { 8 | use_ok('CouchDB::Client::Doc'); 9 | use_ok('CouchDB::Client::DesignDoc'); 10 | use_ok('CouchDB::Client::DB'); 11 | use_ok('CouchDB::Client'); 12 | } 13 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | \.sw.$ 2 | \bRCS\b 3 | \bCVS\b 4 | ^_build/ 5 | ^Build$ 6 | ^blib/ 7 | ^Makefile$ 8 | ^MANIFEST.bak$ 9 | ^MANIFEST.SKIP$ 10 | ^pm_to_blib$ 11 | ^Makefile.[a-z]+$ 12 | \.cvsignore$ 13 | \B\.svn\b 14 | ^diff 15 | ^patch 16 | \.patch$ 17 | ^log$ 18 | ^blibdirs$ 19 | \.tar\.gz$ 20 | 21 | cover_db 22 | CouchDB-Deploy.tmproj 23 | example.pl 24 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | inc/Module/Install.pm 2 | inc/Module/Install/Base.pm 3 | inc/Module/Install/Can.pm 4 | inc/Module/Install/Fetch.pm 5 | inc/Module/Install/Makefile.pm 6 | inc/Module/Install/Metadata.pm 7 | inc/Module/Install/Win32.pm 8 | inc/Module/Install/WriteAll.pm 9 | lib/CouchDB/Client.pm 10 | lib/CouchDB/Client/DB.pm 11 | lib/CouchDB/Client/DesignDoc.pm 12 | lib/CouchDB/Client/Doc.pm 13 | Makefile.PL 14 | MANIFEST This list of files 15 | META.yml 16 | README 17 | t/00-load.t 18 | t/05-pod.t 19 | t/10-pod-coverage.t 20 | t/12-small-things.t 21 | t/15-client.t 22 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use inc::Module::Install 0.64; 2 | 3 | name 'CouchDB-Client'; 4 | 5 | perl_version '5.006'; 6 | license 'perl'; 7 | all_from 'lib/CouchDB/Client.pm'; 8 | 9 | requires 'JSON::Any' => '1.17'; 10 | requires 'LWP::UserAgent'; 11 | requires 'HTTP::Request'; 12 | requires 'URI::Escape'; 13 | requires 'MIME::Base64'; 14 | 15 | # we need a JSON module that isn't Syck (no UTF-8 support makes it useless) 16 | sub check_json () { 17 | my @order = qw(XS JSON DWIW); 18 | foreach my $testmod (@order) { 19 | $testmod = "JSON::$testmod" unless $testmod eq "JSON"; 20 | eval "require $testmod"; 21 | return unless $@; 22 | } 23 | requires 'JSON' => '2.02'; 24 | } 25 | check_json(); 26 | 27 | WriteAll; 28 | -------------------------------------------------------------------------------- /t/12-small-things.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Data::Dumper; 7 | 8 | use CouchDB::Client qw(); 9 | use CouchDB::Client::DB qw(); 10 | use CouchDB::Client::Doc qw(); 11 | use CouchDB::Client::DesignDoc qw(); 12 | 13 | use JSON::Any; 14 | use LWP::UserAgent; 15 | 16 | my $cdb = CouchDB::Client->new( uri => $ENV{COUCHDB_CLIENT_URI} || 'http://localhost:5984/' ); 17 | if($cdb->testConnection) { 18 | plan tests => 10; 19 | } 20 | else { 21 | plan skip_all => 'Could not connect to CouchDB, skipping.'; 22 | warn <newDB('blah'); 31 | 32 | ### DESIGN DOC 33 | { 34 | my $dd; 35 | eval { $dd = CouchDB::Client::DesignDoc->new({ 36 | id => '_design/foo', 37 | data => { 38 | language => 'perl', 39 | views => { 40 | all => { map => 'function (doc) {}'}, 41 | }, 42 | }, 43 | db => $DB}); }; 44 | ok !$@, 'different ctor works'; 45 | eval { CouchDB::Client::DesignDoc->new({ id => 'foo', db => $DB }); }; 46 | ok $@, "bad id blows: $@"; 47 | eval { $dd->queryView('all'); }; 48 | ok $@, "no connection blows: $@"; 49 | } 50 | 51 | # CLIENT 52 | { 53 | my $c; 54 | $c = CouchDB::Client->new({uri => 'http://test'}); 55 | ok $c && $c->{uri} =~ m{/$}, "Trailing / added"; 56 | $c = CouchDB::Client->new(); 57 | ok $c && $c->{uri} eq 'http://localhost:5984/', 'Default URI'; 58 | $c = CouchDB::Client->new(scheme => 'https', host => 'example.org', port => '9000'); 59 | ok $c && $c->{uri} eq 'https://example.org:9000/', 'URI by fragments'; 60 | $c = CouchDB::Client->new(json => JSON::Any->new, ua => LWP::UserAgent->new); 61 | ok $c && $c->{json} && $c->{ua}, 'helper objects'; 62 | 63 | # bad address 64 | $c = CouchDB::Client->new(scheme => 'https'); 65 | ok !$c->testConnection, "no connection"; 66 | eval { $c->serverInfo }; 67 | ok $@, "Could not connect for serverInfo: $@"; 68 | eval { $c->listDBNames }; 69 | ok $@, "Could not connect for listDBNames: $@"; 70 | } 71 | 72 | -------------------------------------------------------------------------------- /lib/CouchDB/Client/DesignDoc.pm: -------------------------------------------------------------------------------- 1 | 2 | package CouchDB::Client::DesignDoc; 3 | 4 | use strict; 5 | use warnings; 6 | 7 | our $VERSION = $CouchDB::Client::VERSION; 8 | use base qw(CouchDB::Client::Doc); 9 | 10 | use Carp qw(confess); 11 | 12 | sub new { 13 | my $class = shift; 14 | my %opt = @_ == 1 ? %{$_[0]} : @_; 15 | 16 | my $self = $class->SUPER::new(\%opt); 17 | confess "Design doc ID must start with '_design/'" unless $self->{id} =~ m{^_design/}; 18 | $self->{data}->{language} ||= 'javascript'; 19 | return bless $self, $class; 20 | } 21 | 22 | sub views { @_ == 2 ? $_[0]->{data}->{views} = $_[1] : $_[0]->{data}->{views}; } 23 | 24 | 25 | sub contentForSubmit { 26 | my $self = shift; 27 | my $content = $self->SUPER::contentForSubmit(); 28 | delete $content->{attachments}; 29 | return $content; 30 | } 31 | 32 | sub listViews { 33 | my $self = shift; 34 | return keys %{$self->data->{views}}; 35 | } 36 | 37 | sub queryView { 38 | my $self = shift; 39 | my $view = shift; 40 | my %args = @_; 41 | 42 | confess("No such view: '$view'") unless exists $self->views->{$view}; 43 | my $sn = $self->id; 44 | $sn =~ s{^_design/}{}; 45 | my $qs = %args ? $self->{db}->argsToQuery(%args) : ''; 46 | my $res = $self->{db}->{client}->req('GET', $self->{db}->uriName . "_view/$sn/$view" . $qs); 47 | confess("Connection error: $res->{msg}") unless $res->{success}; 48 | return $res->{json}; 49 | } 50 | 51 | 1; 52 | 53 | =pod 54 | 55 | =head1 NAME 56 | 57 | CouchDB::Client::DesignDoc - CouchDB::Client design documents (views) 58 | 59 | =head1 SYNOPSIS 60 | 61 | $dd->listViews; 62 | # ... 63 | my $res = $dd->queryView('all'); 64 | 65 | =head1 DESCRIPTION 66 | 67 | This module represents design documents (containing views) in the CouchDB database. 68 | 69 | Design documents are basically documents that have some fields interpreted specifically 70 | in CouchDB. Therefore, this is a subclass of C and has all of the 71 | same functionality except that it will not save attachments. 72 | 73 | =head1 METHODS 74 | 75 | =over 8 76 | 77 | =item new 78 | 79 | Constructor. Same as its parent class but only accepts IDs that are valid for design 80 | documents. 81 | 82 | =item views 83 | 84 | Read-write accessor for the views. It needs to be in the format that CouchDB expects. 85 | Note that this only changes the views on the client side, you have to create/update 86 | the object for it to be stored. 87 | 88 | =item contentForSubmit 89 | 90 | Same as its parent class but removes attachments. 91 | 92 | =item listViews 93 | 94 | Returns a list of all the views defined in this design document. 95 | 96 | =item queryView $VIEW_NAME, %ARGS? 97 | 98 | Takes the name of a view in this design document (an exception will be thrown if it isn't 99 | there) and an optional hash of query arguments as supported by CouchDB (e.g. startkey, 100 | descending, count, etc.) and returns the data structure that the server returns. It will 101 | throw exceptions for connection errors too. 102 | 103 | The query parameters are expected to be expressed in a Perlish fashion. For instance if 104 | one has a boolean value you should use Perl truth and it will work; likewise if you are 105 | using multiply-valued keys then simply pass in an arrayref and it will be converted and 106 | quoted properly. 107 | 108 | The data structure that is returned is a hashref that will contain C and 109 | C keys, as well as a C field that contains an array ref being the 110 | resultset. 111 | 112 | =back 113 | 114 | =head1 AUTHOR 115 | 116 | Robin Berjon, 117 | 118 | =head1 BUGS 119 | 120 | Please report any bugs or feature requests to bug-couchdb-client at rt.cpan.org, or through the 121 | web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CouchDB-Client. 122 | 123 | =head1 COPYRIGHT & LICENSE 124 | 125 | Copyright 2008 Robin Berjon, all rights reserved. 126 | 127 | This library is free software; you can redistribute it and/or modify it under the same terms as 128 | Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may 129 | have available. 130 | 131 | =cut 132 | -------------------------------------------------------------------------------- /lib/CouchDB/Client.pm: -------------------------------------------------------------------------------- 1 | 2 | package CouchDB::Client; 3 | 4 | use strict; 5 | use warnings; 6 | 7 | our $VERSION = '0.04'; 8 | 9 | use JSON::Any qw(XS JSON DWIW); 10 | use LWP::UserAgent qw(); 11 | use HTTP::Request qw(); 12 | use Encode qw(encode); 13 | use Carp qw(confess); 14 | 15 | use CouchDB::Client::DB; 16 | 17 | sub new { 18 | my $class = shift; 19 | my %opt = @_ == 1 ? %{$_[0]} : @_; 20 | 21 | my %self; 22 | if ($opt{uri}) { 23 | $self{uri} = $opt{uri}; 24 | $self{uri} .= '/' unless $self{uri} =~ m{/$}; 25 | } 26 | else { 27 | $self{uri} = ($opt{scheme} || 'http') . '://' . 28 | ($opt{host} || 'localhost') . ':' . 29 | ($opt{port} || '5984') . '/'; 30 | } 31 | $self{json} = ($opt{json} || JSON::Any->new(utf8 => 1, allow_blessed => 1)); 32 | $self{ua} = ($opt{ua} || LWP::UserAgent->new(agent => "CouchDB::Client/$VERSION")); 33 | 34 | return bless \%self, $class; 35 | } 36 | 37 | sub testConnection { 38 | my $self = shift; 39 | eval { $self->serverInfo; }; 40 | return 0 if $@; 41 | return 1; 42 | } 43 | 44 | sub serverInfo { 45 | my $self = shift; 46 | my $res = $self->req('GET'); 47 | return $res->{json} if $res->{success}; 48 | confess("Connection error: $res->{msg}"); 49 | } 50 | 51 | sub newDB { 52 | my $self = shift; 53 | my $name = shift; 54 | return CouchDB::Client::DB->new(name => $name, client => $self); 55 | } 56 | 57 | sub listDBNames { 58 | my $self = shift; 59 | my $res = $self->req('GET', '_all_dbs'); 60 | return $res->{json} if $res->{success}; 61 | confess("Connection error: $res->{msg}"); 62 | } 63 | 64 | sub listDBs { 65 | my $self = shift; 66 | return [ map { $self->newDB($_) } @{$self->listDBNames} ]; 67 | } 68 | 69 | sub dbExists { 70 | my $self = shift; 71 | my $name = shift; 72 | $name =~ s{/$}{}; 73 | return (grep { $_ eq $name } @{$self->listDBNames}) ? 1 : 0; 74 | } 75 | 76 | # --- CONNECTION HANDLING --- 77 | sub req { 78 | my $self = shift; 79 | my $meth = shift; 80 | my $path = shift; 81 | my $content = shift; 82 | 83 | if (ref $content) { 84 | $content = encode('utf-8', $self->{json}->encode($content)); 85 | } 86 | my $res = $self->{ua}->request( HTTP::Request->new($meth, $self->uriForPath($path), undef, $content) ); 87 | my $ret = { 88 | status => $res->code, 89 | msg => $res->status_line, 90 | success => 0, 91 | }; 92 | if ($res->is_success) { 93 | $ret->{success} = 1; 94 | $ret->{json} = $self->{json}->decode($res->content); 95 | } 96 | return $ret; 97 | } 98 | 99 | 100 | # --- HELPERS --- 101 | sub uriForPath { 102 | my $self = shift; 103 | my $path = shift() || ''; 104 | return $self->{uri} . $path; 105 | } 106 | 107 | 108 | 1; 109 | 110 | =pod 111 | 112 | =head1 NAME 113 | 114 | CouchDB::Client - Simple, correct client for CouchDB 115 | 116 | =head1 SYNOPSIS 117 | 118 | use CouchDB::Client; 119 | my $c = CouchDB::Client->new(uri => 'https://dbserver:5984/'); 120 | $c->testConnection or die "The server cannot be reached"; 121 | print "Running version " . $c->serverInfo->{version} . "\n"; 122 | my $db = $c->newDB('my-stuff')->create; 123 | 124 | # listing databases 125 | $c->listDBs; 126 | $c->listDBNames; 127 | 128 | 129 | =head1 DESCRIPTION 130 | 131 | This module is a client for the CouchDB database. 132 | 133 | =head1 METHODS 134 | 135 | =over 8 136 | 137 | =item new 138 | 139 | Constructor. Takes a hash or hashref of options: C which specifies the server's URI; 140 | C, C, C which are used if C isn't provided and default to 'http', 141 | 'localhost', and '5984' respectively; C which defaults to a JSON::Any object with 142 | utf8 and allow_blessed turned on but can be replaced with anything with the same interface; 143 | and C which is a LWP::UserAgent object and can also be replaced. 144 | 145 | =item testConnection 146 | 147 | Returns true if a connection can be made to the server, false otherwise. 148 | 149 | =item serverInfo 150 | 151 | Returns a hashref of the server metadata, typically something that looks like 152 | C<<< { couchdb => "Welcome", version => "0.8.0-incubating"} >>>. It throws 153 | an exception if it can't connect. 154 | 155 | =item newDB $NAME 156 | 157 | Returns a new C object for a database of that name. Note that the DB 158 | does not need to exist yet, and will not be created if it doesn't. 159 | 160 | =item listDBNames 161 | 162 | Returns an arrayref of all the database names that the server knows of. Throws an exception 163 | if it cannot connect. 164 | 165 | =item listDBs 166 | 167 | Same as above but returns an arrayref of C objects instead. 168 | 169 | =item dbExists $NAME 170 | 171 | Returns true if a database of that name exists, false otherwise. 172 | 173 | =back 174 | 175 | =head1 INTERNAL METHODS 176 | 177 | You will use these at your own risk 178 | 179 | =over 8 180 | 181 | =item req $METHOD, $PATH, $CONTENT 182 | 183 | $METHOD is the HTTP method to use; $PATH the part of the path that follows C; 184 | and $CONTENT a Perl data structure. The latter, if present, is encoded to JSON and the request 185 | is made using the given method and path. The return value is a hash containing a boolean indicating 186 | C, a C being the HTTP response code, a descriptive C, and a C field 187 | containing the response JSON. 188 | 189 | =item uriForPath $PATH 190 | 191 | Gets a path and returns the complete URI. 192 | 193 | =back 194 | 195 | =head1 AUTHOR 196 | 197 | Robin Berjon, 198 | 199 | =head1 BUGS 200 | 201 | Please report any bugs or feature requests to bug-couchdb-client at rt.cpan.org, or through the 202 | web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CouchDB-Client. 203 | 204 | =head1 COPYRIGHT & LICENSE 205 | 206 | Copyright 2008 Robin Berjon, all rights reserved. 207 | 208 | This library is free software; you can redistribute it and/or modify it under the same terms as 209 | Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may 210 | have available. 211 | 212 | =cut 213 | -------------------------------------------------------------------------------- /t/15-client.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Data::Dumper; 7 | 8 | use CouchDB::Client qw(); 9 | 10 | my $cdb = CouchDB::Client->new( uri => $ENV{COUCHDB_CLIENT_URI} || 'http://localhost:5984/' ); 11 | 12 | # CONFIG 13 | my $dbName = 'test-perl-couchdb-client/'; 14 | my $dbNameNot = 'test-perl-couchdb-client-NOT-EXISTS/'; 15 | my $baseDocName = 'TEST-DOC'; 16 | 17 | if($cdb->testConnection) { 18 | my $v = $cdb->serverInfo->{version}; 19 | my ($maj, $min) = ($v =~ m/^(\d+)\.(\d+)\./); 20 | if ($maj == 0 and $min < 8) { 21 | plan skip_all => "Requires CouchDB version 0.8.0 or better; running $v"; 22 | } 23 | else { 24 | plan tests => 63; 25 | } 26 | } 27 | else { 28 | plan skip_all => 'Could not connect to CouchDB, skipping.'; 29 | warn <serverInfo; 50 | ok $si->{couchdb} eq 'Welcome' && exists $si->{version}, 'serverInfo works'; 51 | } 52 | 53 | # list DBs 54 | { 55 | my $dbs = $cdb->listDBs; 56 | ok ref($dbs) eq 'ARRAY', 'listDBs at least returns a list of something'; 57 | my $dbs2 = $cdb->listDBNames; 58 | ok ref($dbs2) eq 'ARRAY', 'listDBNames at least returns a list of something'; 59 | ok @$dbs == @$dbs2, 'listDBNames and listDBs return the same number of items'; 60 | } 61 | 62 | # new DB & exists 63 | { 64 | my $db = $cdb->newDB($dbName); 65 | ok $db->isa('CouchDB::Client::DB'), 'newDB creates DBs'; 66 | eval { $db->delete; }; 67 | eval { $db->create; }; 68 | SKIP: { 69 | skip("Issue creating a DB: $@", 2) if $@; 70 | ok $cdb->dbExists($dbName), 'dbExists sees an existing DB'; 71 | ok !$cdb->dbExists($dbNameNot), 'dbExists does not see a non-extant DB'; 72 | } 73 | eval { $db->delete; }; 74 | } 75 | 76 | 77 | 78 | ### --- DB TESTS --------------------------------------------------------------- ### 79 | 80 | my $DB; 81 | eval { 82 | $DB = $cdb->newDB($dbName)->create(); 83 | }; 84 | ok $DB, 'DB create'; 85 | 86 | # name validation 87 | { 88 | my $goodName = ''; 89 | $goodName .= $_ for ('a'..'z'); 90 | $goodName .= '_$()+-/'; 91 | $goodName .= $_ for (0..9); 92 | $goodName .= '/'; 93 | ok $DB->validName($goodName), 'Valid names accepted'; 94 | 95 | my $badName1 = $goodName; 96 | $badName1 =~ s{\/$}{}; 97 | ok not($DB->validName($badName1)), 'Trailing slash required'; 98 | 99 | my $badName2 = $goodName; 100 | $badName2 = uc($badName2); 101 | ok not($DB->validName($badName2)), 'Uppercase rejected'; 102 | 103 | my $badName3 = $goodName; 104 | $badName3 =~ s{_\$}{\&}; 105 | ok not($DB->validName($badName3)), 'Invalid character rejected'; 106 | } 107 | 108 | # create & delete, more proper 109 | { 110 | eval { $DB->create; }; 111 | ok $@, "Database could not be created twice"; 112 | 113 | ok $DB->delete, "Database could be deleted after creation"; 114 | eval { $DB->delete; }; 115 | ok $@, "Database cannot be deleted twice"; 116 | 117 | # recreate 118 | ok $DB->create, "Database re-created"; 119 | } 120 | 121 | # dbInfo 122 | { 123 | my $info = $DB->dbInfo; 124 | ok $info, "dbInfo available"; 125 | ok $info->{db_name} . '/' eq $dbName, "Data in dbInfo"; 126 | 127 | } 128 | 129 | # list Docs 130 | { 131 | my $docs = $DB->listDocs; 132 | ok ref($docs) eq 'ARRAY', 'listDocs at least returns a list of something'; 133 | my $docs2 = $DB->listDocIdRevs; 134 | ok ref($docs2) eq 'ARRAY', 'listDocIdRevs at least returns a list of something'; 135 | ok @$docs == @$docs2, 'listDocIdRevs and listDocs return the same number of items'; 136 | } 137 | 138 | # new Doc & exists 139 | { 140 | $docName = docName(); 141 | my $doc = $DB->newDoc($docName); 142 | ok $doc->isa('CouchDB::Client::Doc'), 'newDoc creates Docs'; 143 | eval { $doc->delete; }; 144 | eval { $doc->create; }; 145 | SKIP: { 146 | skip("Issue creating a Doc: $@", 2) if $@; 147 | ok $DB->docExists($docName), 'docExists sees an existing Doc'; 148 | ok !$DB->docExists($docName . '-NOT-EXISTS'), 'docExists does not see a non-extant Doc'; 149 | } 150 | eval { $doc->delete; }; 151 | } 152 | 153 | # list Design Docs 154 | { 155 | my $docs = $DB->listDesignDocs; 156 | ok ref($docs) eq 'ARRAY', 'listDesignDocs at least returns a list of something'; 157 | my $docs2 = $DB->listDesignDocIdRevs; 158 | ok ref($docs2) eq 'ARRAY', 'listDesignDocIdRevs at least returns a list of something'; 159 | ok @$docs == @$docs2, 'listDesignDocIdRevs and listDesignDocs return the same number of items'; 160 | } 161 | 162 | # new Design Doc & exists 163 | { 164 | $docName = docName(); 165 | $docName = "_design/$docName"; 166 | my $doc = $DB->newDesignDoc($docName); 167 | ok $doc->isa('CouchDB::Client::DesignDoc'), 'newDesignDoc creates DesignDocs'; 168 | eval { $doc->delete; }; 169 | eval { $doc->create; }; 170 | SKIP: { 171 | skip("Issue creating a DesignDoc: $@", 2) if $@; 172 | ok $DB->designDocExists($docName), 'designDocExists sees an existing DesignDoc'; 173 | ok !$DB->designDocExists($docName . '-NOT-EXISTS'), 'designDocExists does not see a non-extant DesignDoc'; 174 | } 175 | eval { $doc->delete; }; 176 | } 177 | 178 | 179 | ### --- DOC TESTS --------------------------------------------------------------- ### 180 | 181 | # create 182 | $docName = docName(); 183 | my $DOC = $DB->newDoc($docName); 184 | eval { $DOC->retrieve && $DOC->delete; }; 185 | eval { $DOC = $DOC->create; }; 186 | ok $DOC && !$@, 'Doc created'; 187 | 188 | # fields 189 | { 190 | ok $DOC->id eq $docName, 'ID is good'; 191 | ok $DOC->rev, 'there is a rev'; 192 | $DOC->data({ foo => 'bar' }); 193 | ok $DOC->data->{foo} eq 'bar', 'data works'; 194 | } 195 | 196 | # update 197 | { 198 | my $oldRev = $DOC->rev; 199 | $DOC->update; 200 | ok $DOC->id eq $docName, 'ID is stable after update'; 201 | ok $DOC->rev != $oldRev, 'Rev changes on update'; 202 | ok $DOC->data->{foo} eq 'bar', 'Update maintains data'; 203 | } 204 | 205 | # delete 206 | { 207 | $docName = docName(); 208 | my $d = $DB->newDoc($docName)->create->delete; 209 | ok $d->{deletion_stub_rev}, 'Added deletion_stub_rev'; 210 | } 211 | 212 | # attach 213 | { 214 | $DOC->addAttachment('dahut.txt', 'text/plain', "Dahuts will rule the world!"); 215 | $DOC->addAttachment('page.html', 'application/xhtml+xml', "

Dahuts will rule the world!

"); 216 | ok keys %{$DOC->attachments} && keys %{$DOC->attachments} == 2, 'Attachments were added'; 217 | $DOC->update; 218 | ok $DOC->fetchAttachment('dahut.txt') eq 'Dahuts will rule the world!', "Attachment 1 worked"; 219 | ok $DOC->fetchAttachment('page.html') eq '

Dahuts will rule the world!

', "Attachment 2 worked"; 220 | eval { $DOC->fetchAttachment('NOT-THERE'); }; 221 | ok $@, 'Non-extant attachments are not returned'; 222 | } 223 | 224 | ### --- DESIGN DOC TESTS --------------------------------------------------------- ### 225 | 226 | # create 227 | $docName = '_design/' . docName(); 228 | my $DD = $DB->newDesignDoc($docName); 229 | eval { $DD->retrieve && $DD->delete; }; 230 | eval { $DD = $DD->create; }; 231 | ok $DD && !$@, 'DesignDoc created'; 232 | 233 | # fields 234 | { 235 | ok $DD->id eq $docName, 'ID is good'; 236 | ok $DD->rev, 'there is a rev'; 237 | $DD->views({ all => { map => 'function (doc) {}'} }); 238 | ok $DD->views->{all}->{map} eq 'function (doc) {}', 'views works'; 239 | } 240 | 241 | # update 242 | { 243 | $DD->update; 244 | ok $DD->views->{all}->{map} eq 'function (doc) {}', 'Update maintains views'; 245 | } 246 | 247 | # list 248 | { 249 | my @ls = $DD->listViews; 250 | ok @ls == 1 && $ls[0] eq 'all', 'listViews works'; 251 | } 252 | 253 | # query 254 | { 255 | $DD->views({ 256 | all => { 257 | map => 'function (doc) { emit(null, doc); }' 258 | }, 259 | foo => { 260 | map => 'function (doc) { if (doc.foo == "bar") emit(doc.foo, doc); }' 261 | }, 262 | }); 263 | $DD->update; 264 | my @ls = $DD->listViews; 265 | ok @ls == 2, 'multiple listViews works'; 266 | my $res; 267 | $res = $DD->queryView('all'); 268 | ok $res && @{$res->{rows}} == 1, "queryView for all works"; 269 | $res = $DD->queryView('foo', key => 'bar'); 270 | ok $res && @{$res->{rows}} == 1, "queryView for foo?key=bar works"; 271 | $res = $DD->queryView('foo', key => 'bar', descending => 1); 272 | ok $res && @{$res->{rows}} == 1, "queryView for foo?key=bar descending works"; 273 | $res = $DD->queryView('foo', key => 'bar', count => 0); 274 | ok $res && @{$res->{rows}} == 0, "queryView for foo?key=bar count=0 works"; 275 | $res = $DD->queryView('foo', key => 'not-there'); 276 | ok $res && @{$res->{rows}} == 0, "queryView for foo?key=not-there works"; 277 | eval { $DD->queryView('not-there'); }; 278 | ok $@, "Non-extant view doesn't work"; 279 | } 280 | 281 | 282 | ### --- BULK TESTS --------------------------------------------------------- ### 283 | my @docs; 284 | for my $n (1..10) { 285 | push @docs, $DB->newDoc("foo-$n", undef, { bulky => 1 }); 286 | } 287 | ok $DB->bulkStore(\@docs), 'bulk store'; 288 | my $res = $DD->queryView('all'); 289 | ok $res && @{$res->{rows}} == 11, "bulk was inserted"; 290 | ok $DB->bulkDelete(\@docs), 'bulk delete'; 291 | $res = $DD->queryView('all'); 292 | ok $res && @{$res->{rows}} == 1, "bulk was deleted"; 293 | 294 | 295 | ### --- TEMP VIEWS --------------------------------------------------------- ### 296 | { 297 | my $res = $DB->tempView({ map => 'function (doc) { if (doc.foo == "bar") emit(doc.foo, doc); }' }); 298 | ok $res && @{$res->{rows}} == 1, "temp view works"; 299 | } 300 | 301 | 302 | ### --- DOC REVISIONS --------------------------------------------------------- ### 303 | { 304 | my $ri = $DOC->revisionsInfo; 305 | ok $ri && @$ri == 3, "Revision info ok"; 306 | ok $ri->[0]->{status} eq 'available' && $ri->[0]->{rev} == $DOC->rev, "revisions are good"; 307 | ok $DOC->retrieveFromRev($ri->[1]->{rev}), "old version ok"; 308 | } 309 | 310 | 311 | ### --- THE CLEANUP AT THE END 312 | 313 | $DD->delete; 314 | $DOC->delete; 315 | $DB->delete; 316 | 317 | -------------------------------------------------------------------------------- /lib/CouchDB/Client/Doc.pm: -------------------------------------------------------------------------------- 1 | 2 | package CouchDB::Client::Doc; 3 | 4 | use strict; 5 | use warnings; 6 | 7 | our $VERSION = $CouchDB::Client::VERSION; 8 | 9 | use HTTP::Request qw(); 10 | use URI::Escape qw(uri_escape_utf8); 11 | use MIME::Base64 qw(encode_base64); 12 | use Carp qw(confess); 13 | 14 | sub new { 15 | my $class = shift; 16 | my %opt = @_ == 1 ? %{$_[0]} : @_; 17 | 18 | confess "Doc needs a database" unless $opt{db}; 19 | 20 | my %self = ( 21 | id => $opt{id} || '', 22 | rev => $opt{rev} || '', 23 | attachments => $opt{attachments} || {}, 24 | data => $opt{data} || {}, 25 | db => $opt{db}, 26 | ); 27 | return bless \%self, $class; 28 | } 29 | 30 | sub id { return $_[0]->{id}; } 31 | sub rev { return $_[0]->{rev}; } 32 | 33 | sub data { 34 | my $self = shift; 35 | if (@_) { 36 | my $data = shift; 37 | $self->{attachments} = delete($data->{_attachments}) || {}; 38 | $self->{data} = $data; 39 | } 40 | else { 41 | return $self->{data}; 42 | } 43 | } 44 | sub attachments { @_ == 2 ? $_[0]->{attachments} = $_[1] : $_[0]->{attachments}; } 45 | 46 | sub uriName { 47 | my $self = shift; 48 | return undef unless $self->{id}; 49 | return $self->{db}->uriName . $self->{id}; 50 | } 51 | 52 | sub create { 53 | my $self = shift; 54 | 55 | confess("Object already had a revision") if $self->{rev}; 56 | 57 | my $content = $self->contentForSubmit; 58 | my $res; 59 | if ($self->{id}) { 60 | $res = $self->{db}->{client}->req('PUT', $self->uriName, $content); 61 | } 62 | else { 63 | $res = $self->{db}->{client}->req('POST', $self->{db}->uriName, $content); 64 | } 65 | confess("Storage error: $res->{msg}") unless $res->{success}; 66 | $self->{rev} = $res->{json}->{rev}; 67 | $self->{id} = $res->{json}->{id} unless $self->{id}; 68 | return $self; 69 | } 70 | 71 | sub contentForSubmit { 72 | my $self = shift; 73 | my $content = $self->{data}; 74 | $content->{_id} = $self->{id} if $self->{id}; 75 | $content->{_rev} = $self->{rev} if $self->{rev}; 76 | $content->{_attachments} = $self->{attachments} if $self->{attachments} and keys %{$self->{attachments}}; 77 | return $content; 78 | } 79 | 80 | sub retrieve { 81 | my $self = shift; 82 | 83 | my $res = $self->{db}->{client}->req('GET', $self->uriName); 84 | confess("Object not found: $res->{msg}") if $res->{status} == 404; 85 | confess("Connection error: $res->{msg}") unless $res->{success}; 86 | my $data = $res->{json}; 87 | my %private; 88 | my @keys = keys %$data; # need to two-step this due to delete() 89 | for my $k (@keys) { 90 | if ($k =~ m/^_(.+)/) { 91 | $private{$1} = delete $data->{$k}; 92 | } 93 | } 94 | $self->{data} = $data; 95 | $self->{id} = $private{id}; 96 | $self->{rev} = $private{rev}; 97 | $self->{attachments} = $private{attachments} if exists $private{attachments}; 98 | return $self; 99 | } 100 | 101 | sub retrieveFromRev { 102 | my $self = shift; 103 | my $rev = shift; 104 | 105 | my $res = $self->{db}->{client}->req('GET', $self->uriName . '?rev=' . $rev); 106 | confess("Object not found: $res->{msg}") if $res->{status} == 404; 107 | confess("Connection error: $res->{msg}") unless $res->{success}; 108 | my $data = $res->{json}; 109 | my %private; 110 | my @keys = keys %$data; # need to two-step this due to delete() 111 | for my $k (@keys) { 112 | if ($k =~ m/^_(.+)/) { 113 | $private{$1} = delete $data->{$k}; 114 | } 115 | } 116 | return ref($self)->new({ 117 | id => $self->id, 118 | rev => $rev, 119 | attachments => $private{attachments}, 120 | data => $data, 121 | db => $self->{db}, 122 | }); 123 | } 124 | 125 | sub revisionsInfo { 126 | my $self = shift; 127 | 128 | my $res = $self->{db}->{client}->req('GET', $self->uriName . '?revs_info=true'); 129 | confess("Object not found: $res->{msg}") if $res->{status} == 404; 130 | confess("Connection error: $res->{msg}") unless $res->{success}; 131 | return $res->{json}->{_revs_info}; 132 | } 133 | 134 | sub update { 135 | my $self = shift; 136 | 137 | confess("Object hasn't been retrieved") unless $self->{id} and $self->{rev}; 138 | my $content = $self->contentForSubmit; 139 | my $res = $self->{db}->{client}->req('PUT', $self->uriName, $content); 140 | confess("Storage error: $res->{msg}") unless $res->{success}; 141 | $self->{rev} = $res->{json}->{rev}; 142 | return $self; 143 | } 144 | 145 | sub delete { 146 | my $self = shift; 147 | 148 | confess("Object hasn't been retrieved") unless $self->{id} and $self->{rev}; 149 | my $res = $self->{db}->{client}->req('DELETE', $self->uriName . "?rev=" . $self->rev); 150 | confess("Object not found: $res->{msg}") if $res->{status} == 404; 151 | confess("Connection error: $res->{msg}") unless $res->{success}; 152 | $self->{deletion_stub_rev} = $res->{json}->{rev}; 153 | $self->{rev} = ''; 154 | $self->{data} = {}; 155 | $self->{attachments} = {}; 156 | return $self; 157 | } 158 | 159 | sub fetchAttachment { 160 | my $self = shift; 161 | my $attName = shift; 162 | 163 | confess("No such attachment: '$attName'") unless exists $self->{attachments}->{$attName}; 164 | my $res = $self->{db}->{client}->{ua}->request( 165 | HTTP::Request->new('GET', $self->{db}->{client}->uriForPath($self->uriName . '/' . uri_escape_utf8($attName))) 166 | ); 167 | return $res->content if $res->is_success; 168 | confess("Object not found: $res->{msg}"); 169 | } 170 | 171 | sub addAttachment { 172 | my $self = shift; 173 | my $name = shift; 174 | my $ctype = shift; 175 | my $data = shift; 176 | 177 | $self->{attachments}->{$name} = { 178 | content_type => $ctype, 179 | data => $self->toBase64($data), 180 | }; 181 | return $self; 182 | } 183 | 184 | sub toBase64 { 185 | my $self = shift; 186 | my $data = shift; 187 | 188 | my $ret = encode_base64 $data; 189 | $ret =~ s/\n//g; 190 | return $ret; 191 | } 192 | 193 | 1; 194 | 195 | =pod 196 | 197 | =head1 NAME 198 | 199 | CouchDB::Client::Doc - CouchDB::Client document 200 | 201 | =head1 SYNOPSIS 202 | 203 | $doc->data->{foo} = 'new bar'; 204 | $doc->addAttachment('file.xml', 'application/xml', '); 205 | $doc->update; 206 | $doc->delete; 207 | 208 | =head1 DESCRIPTION 209 | 210 | This module represents documents in the CouchDB database. 211 | 212 | We don't yet deal with a number of options such as retrieving revisions and 213 | revision status. 214 | 215 | =head1 METHODS 216 | 217 | =over 8 218 | 219 | =item new 220 | 221 | Constructor. Takes a hash or hashref of options: C which is the parent 222 | C object and is required; the document's C and C 223 | if known; a hashref of C being the content; and a hashref of C 224 | if present. 225 | 226 | The C field must be a valid document name (CouchDB accepts anything, but 227 | things that are not URI safe have not been tested yet). 228 | 229 | The C field must be a valid CouchDB revision, it is recommended that you 230 | only touch it if you know what you're doing. 231 | 232 | The C field is a normal Perl hashref that can have nested content. Its 233 | keys must not contain fields that being with an underscore (_) as those are 234 | reserved for CouchDB. 235 | 236 | The C field must be structured in the manner that CouchDB expects. 237 | It is a hashref with attachment names as its keys and hashrefs as values. The 238 | latter have C and C fields which are the MIME media type 239 | of the content, and the data in single-line Base64. It is recommended that you 240 | manipulate this through the helpers instead. 241 | 242 | It is not recommended that this constructor be used directly, but rather that 243 | C<<newDoc>>> be used instead. 244 | 245 | =item id 246 | 247 | Read-only accessor for the ID. 248 | 249 | =item rev 250 | 251 | Read-only accessor for the revision. 252 | 253 | =item data 254 | 255 | Read-write accessor for the content. See above for the constraints on this hasref. 256 | Note that this only changes the data on the client side, you have to create/update 257 | the object for it to be stored. 258 | 259 | =item attachments 260 | 261 | Read-write accessor for the attachments. See above for the constraints on this hasref. 262 | Note that this only changes the attachments on the client side, you have to create/update 263 | the object for it to be stored. 264 | 265 | =item uriName 266 | 267 | Returns the path part for this object (if it has an ID, otherwise undef). 268 | 269 | =item create 270 | 271 | Causes the document to be created in the DB. It will throw an exception if the object already 272 | has a revision (since that would indicate that it's already in the DB) or if the actual 273 | storage operation fails. 274 | 275 | If the object has an ID it will PUT it to the URI, otherwise it will POST it and set its ID based 276 | on the result. It returns itself, with the C field updated. 277 | 278 | =item contentForSubmit 279 | 280 | A helper that returns a data structure matching that of the JSON that will be submitted as part 281 | of a create/update operation. 282 | 283 | =item retrieve 284 | 285 | Loads the document from the database, initialising all its fields in the process. Will 286 | throw an exception if the document cannot be found, or for connection issues. It returns 287 | the object. 288 | 289 | Note that the attachments field if defined will contain stubs and not the full content. 290 | Retrieving the actual data is done using C. 291 | 292 | =item update 293 | 294 | Same as C but only operates on documents already in the DB. 295 | 296 | =item delete 297 | 298 | Deletes the document and resets the object (updating its C). Returns the object (which 299 | is still perfectly usable). Throws an exception if the document isn't found, or for 300 | connection issues. 301 | 302 | =item fetchAttachment $NAME 303 | 304 | Fetches the attachment with the given name and returns its content. Throws an exception if 305 | the attachment cannot be retrieved, or if the object had no knowledge of such an attachment. 306 | 307 | =item addAttachment $NAME, $CONTENT_TYPE, $DATA 308 | 309 | Adds an attachment to the document with a given name, MIME media type, and data. The 310 | data is the original, not the Base64 version which is handled internally. The object 311 | is returned. 312 | 313 | =item toBase64 $DATA 314 | 315 | A simple helper that returns data in Base64 of a form acceptable to CouchDB (on a single 316 | line). 317 | 318 | =item retrieveFromRev $REV 319 | 320 | Fetches a specific revision of a document, and returns it I. This is 321 | to avoid destroying your own Doc object. Throws exceptions if it can't connect or find the 322 | document. 323 | 324 | =item revisionsInfo 325 | 326 | Returns an arrayref or hashresf indicating the C of previous revisions and their 327 | C (being C, C, C). Throws exceptions if it can't connect 328 | or find the document. 329 | 330 | =back 331 | 332 | =head1 TODO 333 | 334 | Handling of attachments could be improved by not forcing the data into memory at all 335 | times. Also, an option to turn the attachments into stubs after they have been saved 336 | would be good. 337 | 338 | =head1 AUTHOR 339 | 340 | Robin Berjon, 341 | 342 | =head1 BUGS 343 | 344 | Please report any bugs or feature requests to bug-couchdb-client at rt.cpan.org, or through the 345 | web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CouchDB-Client. 346 | 347 | =head1 COPYRIGHT & LICENSE 348 | 349 | Copyright 2008 Robin Berjon, all rights reserved. 350 | 351 | This library is free software; you can redistribute it and/or modify it under the same terms as 352 | Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may 353 | have available. 354 | 355 | =cut 356 | -------------------------------------------------------------------------------- /lib/CouchDB/Client/DB.pm: -------------------------------------------------------------------------------- 1 | 2 | package CouchDB::Client::DB; 3 | 4 | use strict; 5 | use warnings; 6 | 7 | our $VERSION = $CouchDB::Client::VERSION; 8 | 9 | use Carp qw(confess); 10 | use URI::Escape qw(uri_escape_utf8); 11 | use CouchDB::Client::Doc; 12 | use CouchDB::Client::DesignDoc; 13 | 14 | sub new { 15 | my $class = shift; 16 | my %opt = @_ == 1 ? %{$_[0]} : @_; 17 | 18 | $opt{name} || confess "CouchDB database requires a name."; 19 | $opt{client} || confess "CouchDB database requires a client."; 20 | $opt{name} .= '/' unless $opt{name} =~ m{/$}; 21 | 22 | return bless \%opt, $class; 23 | } 24 | 25 | sub validName { 26 | shift; 27 | my $name = shift; 28 | return $name =~ m{^[a-z0-9_\$\(\)\+/-]+/$}; 29 | } 30 | 31 | sub uriName { 32 | my $self = shift; 33 | my $sn = $self->{name}; 34 | $sn =~ s{/(.)}{%2F$1}g; 35 | return "$sn"; 36 | } 37 | 38 | sub dbInfo { 39 | my $self = shift; 40 | my $res = $self->{client}->req('GET', $self->uriName); 41 | return $res->{json} if $res->{success}; 42 | confess("Connection error: $res->{msg}"); 43 | } 44 | 45 | sub create { 46 | my $self = shift; 47 | my $res = $self->{client}->req('PUT', $self->uriName); 48 | return $self if $res->{success} and $res->{json}->{ok}; 49 | confess("Database '$self->{name}' exists: $res->{msg}") if $res->{status} == 409; 50 | confess("Connection error: $res->{msg}"); 51 | } 52 | 53 | sub delete { 54 | my $self = shift; 55 | my $res = $self->{client}->req('DELETE', $self->uriName); 56 | return 1 if $res->{success} and $res->{json}->{ok}; 57 | confess("Database '$self->{name}' not found: $res->{msg}") if $res->{status} == 404; 58 | confess("Connection error: $res->{msg}"); 59 | } 60 | 61 | sub newDoc { 62 | my $self = shift; 63 | my $id = shift; 64 | my $rev = shift; 65 | my $data = shift; 66 | my $att = shift; 67 | return CouchDB::Client::Doc->new(id => $id, rev => $rev, data => $data, attachments => $att, db => $self); 68 | } 69 | 70 | sub listDocIdRevs { 71 | my $self = shift; 72 | my %args = @_; 73 | my $qs = %args ? $self->argsToQuery(%args) : ''; 74 | my $res = $self->{client}->req('GET', $self->uriName . '_all_docs' . $qs); 75 | confess("Connection error: $res->{msg}") unless $res->{success}; 76 | return [map { { id => $_->{id}, rev => $_->{value}->{_rev} } } @{$res->{json}->{rows}}]; 77 | } 78 | 79 | sub listDocs { 80 | my $self = shift; 81 | my %args = @_; 82 | return [ map { $self->newDoc($_->{id}, $_->{rev}) } @{$self->listDocIdRevs(%args)} ]; 83 | } 84 | 85 | sub docExists { 86 | my $self = shift; 87 | my $id = shift; 88 | my $rev = shift; 89 | if ($rev) { 90 | return (grep { $_->{id} eq $id and $_->{rev} eq $rev } @{$self->listDocIdRevs}) ? 1 : 0; 91 | } 92 | else { 93 | return (grep { $_->{id} eq $id } @{$self->listDocIdRevs}) ? 1 : 0; 94 | } 95 | } 96 | 97 | sub newDesignDoc { 98 | my $self = shift; 99 | my $id = shift; 100 | my $rev = shift; 101 | my $data = shift; 102 | return CouchDB::Client::DesignDoc->new(id => $id, rev => $rev, data => $data, db => $self); 103 | } 104 | 105 | sub listDesignDocIdRevs { 106 | my $self = shift; 107 | my %args = @_; 108 | return [grep { $_->{id} =~ m{^_design/} } @{$self->listDocIdRevs(%args)}]; 109 | } 110 | 111 | sub listDesignDocs { 112 | my $self = shift; 113 | my %args = @_; 114 | return [ map { $self->newDesignDoc($_->{id}, $_->{rev}) } @{$self->listDesignDocIdRevs(%args)} ]; 115 | } 116 | 117 | sub designDocExists { 118 | my $self = shift; 119 | my $id = shift; 120 | my $rev = shift; 121 | $id = "_design/$id" unless $id =~ m{^_design/}; 122 | if ($rev) { 123 | return (grep { $_->{id} eq $id and $_->{rev} eq $rev } @{$self->listDesignDocIdRevs}) ? 1 : 0; 124 | } 125 | else { 126 | return (grep { $_->{id} eq $id } @{$self->listDesignDocIdRevs}) ? 1 : 0; 127 | } 128 | } 129 | 130 | sub tempView { 131 | my $self = shift; 132 | my $view = shift; 133 | my $res = $self->{client}->req('POST', $self->uriName . '_temp_view', $view); 134 | return $res->{json} if $res->{success}; 135 | confess("Connection error: $res->{msg}"); 136 | } 137 | 138 | use Data::Dumper; 139 | sub bulkStore { 140 | my $self = shift; 141 | my $docs = shift; 142 | my $json = { docs => [map { $_->contentForSubmit } @$docs] }; 143 | my $res = $self->{client}->req('POST', $self->uriName . '_bulk_docs', $json); 144 | confess("Connection error: $res->{msg}") unless $res->{success}; 145 | my $i = 0; 146 | for my $ok (@{$res->{json}->{new_revs}}) { 147 | my $doc = $docs->[$i]; 148 | $doc->{id} = $ok->{id} unless $doc->{id}; 149 | $doc->{rev} = $ok->{rev}; 150 | $i++; 151 | } 152 | return $res->{json} if $res->{success}; 153 | } 154 | 155 | sub bulkDelete { 156 | my $self = shift; 157 | my $docs = shift; 158 | my $json = { docs => [map { my $cnt = $_->contentForSubmit; $cnt->{_deleted} = $self->{client}->{json}->true; $cnt; } @$docs] }; 159 | my $res = $self->{client}->req('POST', $self->uriName . '_bulk_docs', $json); 160 | confess("Connection error: $res->{msg}") unless $res->{success}; 161 | my $i = 0; 162 | for my $ok (@{$res->{json}->{new_revs}}) { 163 | my $doc = $docs->[$i]; 164 | $doc->{deletion_stub_rev} = $ok->{rev}; 165 | $doc->{rev} = ''; 166 | $doc->data({}); 167 | $doc->attachments({}); 168 | $i++; 169 | } 170 | return $res->{json} if $res->{success}; 171 | } 172 | 173 | # from docs 174 | # key=keyvalue 175 | # startkey=keyvalue 176 | # startkey_docid=docid 177 | # endkey=keyvalue 178 | # count=max rows to return 179 | # update=false 180 | # descending=true 181 | # skip=rows to skip 182 | sub fixViewArgs { 183 | my $self = shift; 184 | my %args = @_; 185 | 186 | for my $k (keys %args) { 187 | if ($k eq 'key' or $k eq 'startkey' or $k eq 'endkey') { 188 | if (ref($args{$k}) eq 'ARRAY' or ref($args{$k}) eq 'HASH') { 189 | $args{$k} = $self->server->json->encode($args{$k}); 190 | } 191 | else { 192 | $args{$k} = '"' . $args{$k} . '"'; 193 | } 194 | } 195 | elsif ($k eq 'descending') { 196 | if ($args{$k}) { 197 | $args{$k} = 'true'; 198 | } 199 | else { 200 | delete $args{$k}; 201 | } 202 | } 203 | elsif ($k eq 'update') { 204 | if ($args{$k}) { 205 | delete $args{$k}; 206 | } 207 | else { 208 | $args{$k} = 'false'; 209 | } 210 | } 211 | } 212 | return %args; 213 | } 214 | 215 | sub argsToQuery { 216 | my $self = shift; 217 | my %args = @_; 218 | %args = $self->fixViewArgs(%args); 219 | return '?' . 220 | join '&', 221 | map { uri_escape_utf8($_) . '=' . uri_escape_utf8($args{$_}) } 222 | keys %args; 223 | } 224 | 225 | 1; 226 | 227 | =pod 228 | 229 | =head1 NAME 230 | 231 | CouchDB::Client::DB - CouchDB::Client database 232 | 233 | =head1 SYNOPSIS 234 | 235 | use CouchDB::Client; 236 | my $c = CouchDB::Client->new(uri => 'https://dbserver:5984/'); 237 | my $db = $c->newDB('my-stuff')->create; 238 | $db->dbInfo; 239 | my $doc = $db->newDoc('dahut.svg', undef, { foo => 'bar' })->create; 240 | my $dd = $db->newDesignDoc('dahut.svg', undef, $myViews)->create; 241 | #... 242 | $db->delete; 243 | 244 | =head1 DESCRIPTION 245 | 246 | This module represents databases in the CouchDB database. 247 | 248 | We don't currently handle the various options available on listing all documents. 249 | 250 | =head1 METHODS 251 | 252 | =over 8 253 | 254 | =item new 255 | 256 | Constructor. Takes a hash or hashref of options, both of which are required: 257 | C being the name of the DB (do not escape it, that is done internally, 258 | however the name isn't validated, you can use C for that) and C 259 | being a reference to the parent C. It is not expected that 260 | you would use this constructor directly, but rather that would would go through 261 | C<<< Couch::Client->newDB >>>. 262 | 263 | =item validName $NAME 264 | 265 | Returns true if the name is a valid CouchDB database name, false otherwise. 266 | 267 | =item dbInfo 268 | 269 | Returns metadata that CouchDB maintains about its databases as a Perl structure. 270 | It will throw an exception if it can't connect. Typically it will look like: 271 | 272 | { 273 | db_name => "dj", 274 | doc_count => 5, 275 | doc_del_count => 0, 276 | update_seq => 13, 277 | compact_running => 0, 278 | disk_size => 16845, 279 | } 280 | 281 | =item create 282 | 283 | Performs the actual creation of a database. Returns the object itself upon success. 284 | Throws an exception if it already exists, or for connection problems. 285 | 286 | =item delete 287 | 288 | Deletes the database. Returns true on success. Throws an exception if 289 | the DB can't be found, or for connection problems. 290 | 291 | =item newDoc $ID?, $REV?, $DATA?, $ATTACHMENTS? 292 | 293 | Returns a new C object, optionally with the given ID, revision, data, 294 | and attachments. Note that this does not create the actual document, simply the object. For 295 | constraints on these fields please look at C<<new>>> 296 | 297 | =item listDocIdRevs %ARGS? 298 | 299 | Returns an arrayref containing the ID and revision of all documents in this DB as hashrefs 300 | with C and C keys. Throws an exception if there's a problem. Takes an optional hash 301 | of arguments matching those understood by CouchDB queries. 302 | 303 | =item listDocs %ARGS? 304 | 305 | The same as above, but returns an arrayref of C objects. 306 | Takes an optional hash of arguments matching those understood by CouchDB queries. 307 | 308 | =item docExists $ID, $REV? 309 | 310 | Takes an ID and an optional revision and returns true if there is a document with that ID 311 | in this DB, false otherwise. If the revision is provided, note that this will match only if 312 | there is a document with the given ID B its latest revision is the same as the given 313 | one. 314 | 315 | =item newDesignDoc $ID?, $REV?, $DATA? 316 | 317 | Same as above, but instantiates design documents. 318 | 319 | =item listDesignDocIdRevs %ARGS? 320 | 321 | Same as above, but only matches design documents. 322 | 323 | =item listDesignDocs %ARGS? 324 | 325 | Same as above, but only matches design documents. 326 | 327 | =item designDocExists $ID, $REV? 328 | 329 | Same as above, but only matches design documents. 330 | 331 | =item tempView $VIEW 332 | 333 | Given a view (defined as a hash with the fields that CouchDB expects from the corresponding 334 | JSON), will run it and return the CouchDB resultset. Throws an exception if there is a 335 | connection error. 336 | 337 | =item bulkStore \@DOCS 338 | 339 | Takes an arrayref of Doc objects and stores them on the server (creating or updating them 340 | depending on whether they exist or not). Returns the data structure that CouchDB returns 341 | on success (which is of limited interest as this client already updates all documents so 342 | that their ID and revisions are correct after this operation), and throws an exception 343 | upon failure. 344 | 345 | =item bulkDelete \@DOCS 346 | 347 | Same as above but performs mass deletion of documents. Note that using bulkStore you could 348 | also obtain the same effect by setting a C<_deleted> field to true on your objects but 349 | that is not recommended as fields that begin with an underscore are reserved by CouchDB. 350 | 351 | =item uriName 352 | 353 | Returns the name of the database escaped. 354 | 355 | =item fixViewArgs %ARGS 356 | 357 | Takes a hash of view parameters expressed in a Perlish fashion (e.g. 1 for true or an arrayref 358 | for multi-valued keys) and returns a hash with the same options turned into what CouchDB 359 | understands. 360 | 361 | =item argsToQuery %ARGS 362 | 363 | Takes a hash of view parameters, runs them through C, and returns a query 364 | string (complete with leading '?') to pass on to CouchDB. 365 | 366 | =back 367 | 368 | =head1 AUTHOR 369 | 370 | Robin Berjon, 371 | 372 | =head1 BUGS 373 | 374 | Please report any bugs or feature requests to bug-couchdb-client at rt.cpan.org, or through the 375 | web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CouchDB-Client. 376 | 377 | =head1 COPYRIGHT & LICENSE 378 | 379 | Copyright 2008 Robin Berjon, all rights reserved. 380 | 381 | This library is free software; you can redistribute it and/or modify it under the same terms as 382 | Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may 383 | have available. 384 | 385 | =cut 386 | --------------------------------------------------------------------------------