diff --git a/.gitignore b/.gitignore index fcf9adf..d14e672 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,4 @@ cover_db *.bak *.old inc +MYMETA.* diff --git a/Makefile.PL b/Makefile.PL index 5921459..cb30e71 100755 --- a/Makefile.PL +++ b/Makefile.PL @@ -16,6 +16,7 @@ requires 'LWP::UserAgent'; requires 'HTTP::Request'; requires 'URI::Escape'; requires 'MIME::Base64'; +requires 'Try::Tiny'; # we need a JSON module that isn't Syck (no UTF-8 support makes it useless) sub check_json () { diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..684c63a --- /dev/null +++ b/debian/changelog @@ -0,0 +1,5 @@ +libcouchdb-client-perl (0.10-1) trusty; urgency=medium + + * Packaging. + + -- calle Wed, 12 Feb 2014 15:58:37 +0100 diff --git a/debian/compat b/debian/compat new file mode 100644 index 0000000..7f8f011 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +7 diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..29dcb98 --- /dev/null +++ b/debian/control @@ -0,0 +1,15 @@ +Source: libcouchdb-client-perl +Section: perl +Priority: optional +Build-Depends: debhelper (>= 7.0.50~) +Build-Depends-Indep: libmodule-install-perl,libjson-any-perl,libjson-xs-perl,libtry-tiny-perl,libwww-perl,liburi-perl +Maintainer: Calle Dybedahl +Standards-Version: 3.9.3 +Homepage: https://github.com/cdybedahl/couchdb-client + +Package: libcouchdb-client-perl +Architecture: all +Depends: ${misc:Depends}, ${perl:Depends},libjson-any-perl,libjson-xs-perl,libtry-tiny-perl,libwww-perl,liburi-perl +Description: Client for talking to CouchDB databases. + This packaging is a patched version, not the one on CPAN. + . diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..98f593a --- /dev/null +++ b/debian/copyright @@ -0,0 +1,40 @@ +Format-Specification: http://svn.debian.org/wsvn/dep/web/deps/dep5.mdwn?op=file&rev=135 +Maintainer: Calle Dybedahl +Source: https://github.com/dotse/dnscheck +Name: DNSCheck + +Files: * +Copyright: 2008-2012 Stiftelsen för Internetinfrastruktur +License: BSD + +Files: debian/* +Copyright: 2009-1012, Stiftelsen för Internetinfrastruktur +License: BSD + +License: BSD + Copyright (c) The Regents of the University of California. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..2d33f6a --- /dev/null +++ b/debian/rules @@ -0,0 +1,4 @@ +#!/usr/bin/make -f + +%: + dh $@ diff --git a/lib/CouchDB/Client.pm b/lib/CouchDB/Client.pm index 69f06b1..28c5b2c 100644 --- a/lib/CouchDB/Client.pm +++ b/lib/CouchDB/Client.pm @@ -4,13 +4,14 @@ package CouchDB::Client; use strict; use warnings; -our $VERSION = '0.09'; +our $VERSION = '0.10'; use JSON::Any qw(XS JSON DWIW); use LWP::UserAgent qw(); use HTTP::Request qw(); use Encode qw(encode); use Carp qw(confess); +use URI; use CouchDB::Client::DB; @@ -31,6 +32,16 @@ sub new { $self{json} = ($opt{json} || JSON::Any->new(utf8 => 1, allow_blessed => 1)); $self{ua} = ($opt{ua} || LWP::UserAgent->new(agent => "CouchDB::Client/$VERSION")); + if ($opt{username} and $opt{password}) { + my $uri = URI->new($self{uri}); + $self{ua}->credentials( + $uri->host . ':' . $uri->port, + ($opt{realm} || 'administrator'), + $opt{username}, + $opt{password}, + ); + } + return bless \%self, $class; } @@ -137,11 +148,16 @@ This module is a client for the CouchDB database. =item new -Constructor. Takes a hash or hashref of options: C which specifies the server's URI; -C, C, C which are used if C isn't provided and default to 'http', -'localhost', and '5984' respectively; C which defaults to a JSON::Any object with -utf8 and allow_blessed turned on but can be replaced with anything with the same interface; -and C which is a LWP::UserAgent object and can also be replaced. +Constructor. Takes a hash or hashref of options: C which specifies the +server's URI; C, C, C which are used if C isn't +provided and default to 'http', 'localhost', and '5984' respectively; C +which defaults to a JSON::Any object with utf8 and allow_blessed turned on but +can be replaced with anything with the same interface; and C which is a +LWP::UserAgent object and can also be replaced. For ease of use you can also +pass C, C and C, which will if so be used to add +login credentials to the LWP::UserAgent object. C is optional, and will +if not specified default to "administrator" (which is the default used by +CouchDB). =item testConnection diff --git a/lib/CouchDB/Client/DB.pm b/lib/CouchDB/Client/DB.pm index 23efa26..00f841c 100644 --- a/lib/CouchDB/Client/DB.pm +++ b/lib/CouchDB/Client/DB.pm @@ -1,4 +1,3 @@ - package CouchDB::Client::DB; use strict; @@ -10,6 +9,9 @@ use Carp qw(confess); use URI::Escape qw(uri_escape_utf8); use CouchDB::Client::Doc; use CouchDB::Client::DesignDoc; +use Try::Tiny; + +use B qw[svref_2object SVf_IOK SVf_NOK]; sub new { my $class = shift; @@ -18,7 +20,9 @@ sub new { $opt{name} || confess "CouchDB database requires a name."; $opt{client} || confess "CouchDB database requires a client."; - return bless \%opt, $class; + my $self = bless \%opt, $class; + + return $self; } sub validName { @@ -129,15 +133,30 @@ sub listDocs { return [ map { $self->newDoc($_->{id}, $_->{rev}) } @{$self->listDocIdRevs(%args)} ]; } +sub countDocs { + my $self = shift; + my $qs = $self->argsToQuery(limit => 0); + my $res = $self->{client}->req('GET', $self->uriName . '/_all_docs' . $qs); + confess("Connection error: $res->{msg}") unless $res->{success}; + + return $res->{json}{total_rows}; +} + sub docExists { my $self = shift; my $id = shift; my $rev = shift; - if ($rev) { - return (grep { $_->{id} eq $id and $_->{rev} eq $rev } @{$self->listDocIdRevs}) ? 1 : 0; - } - else { - return (grep { $_->{id} eq $id } @{$self->listDocIdRevs}) ? 1 : 0; + my $doc = $self->newDoc($id, $rev); + eval { + $doc->retrieve; + }; + my $err = $@; + if(!$err) { + return 1; + } elsif($err =~ /Object not found/) { + return 0; + } else { + die $err; } } @@ -152,7 +171,9 @@ sub newDesignDoc { sub listDesignDocIdRevs { my $self = shift; my %args = @_; - return [grep { $_->{id} =~ m{^_design/} } @{$self->listDocIdRevs(%args)}]; + $args{startkey} = '_design'; + $args{endkey} = '_design0'; + return [@{$self->listDocIdRevs(%args)}]; } sub listDesignDocs { @@ -224,6 +245,40 @@ sub bulkDelete { return $res->{json} if $res->{success}; } +sub bulkGet { + my $self = shift; + my $ids = shift; + my @id = map {"$_"} @$ids; + + my $res = $self->{client}->req('POST', $self->uriName . '/_all_docs?include_docs=true', {keys => \@id}); + confess("Connection error: " . $res->{msg}) unless $res->{success}; + $res = $res->{json}{rows}; + + return {map {$_->{key} => $_->{doc}} @$res}; +} + +sub _is_currently_numeric { + # Get a B::-type object from whatever it is + my $ref = svref_2object(\$_[1]); + my $type = ref($ref); + + # It's a pure numeric value + return 1 if ($type eq 'B::NV' or $type eq 'B::IV'); + + # It's a pure string value. + return 0 if $type eq 'B::PV'; + + # It has a current public integer value. + return 1 if $ref->FLAGS & SVf_IOK; + + # It has a current public float value. + return 1 if $ref->FLAGS & SVf_NOK; + + # It's none of the above, so call it not numeric (might still be, due to + # magic). + return 0; +} + # from docs # key=keyvalue # startkey=keyvalue @@ -233,6 +288,7 @@ sub bulkDelete { # update=false # descending=true # skip=rows to skip +# group=do grouping for reducing views sub fixViewArgs { my $self = shift; my %args = @_; @@ -243,12 +299,12 @@ sub fixViewArgs { $args{$k} = $self->{client}->{json}->encode($args{$k}); } else { - unless ($args{$k} =~ /^\d+(?:\.\d+)*$/s) { + unless ($self->_is_currently_numeric($args{$k})) { $args{$k} = '"' . $args{$k} . '"'; } } } - elsif ($k eq 'descending') { + elsif ($k eq 'descending' or $k eq 'group') { if ($args{$k}) { $args{$k} = 'true'; } @@ -376,6 +432,10 @@ of arguments matching those understood by CouchDB queries. The same as above, but returns an arrayref of C objects. Takes an optional hash of arguments matching those understood by CouchDB queries. +=item countDocs + +Returns the total number of documents in the database. + =item docExists $ID, $REV? Takes an ID and an optional revision and returns true if there is a document with that ID @@ -419,6 +479,13 @@ Same as above but performs mass deletion of documents. Note that using bulkStore also obtain the same effect by setting a C<_deleted> field to true on your objects but that is not recommended as fields that begin with an underscore are reserved by CouchDB. +=item bulkGet \@IDS + +Retrieve a large number of documents with one call to the database. The one +argument should be a reference to a list of document ids. It will return a +reference to a hash, where the keys are the given ids and the values are the +corresponding L objects or C. + =item uriName Returns the name of the database escaped. diff --git a/lib/CouchDB/Client/DesignDoc.pm b/lib/CouchDB/Client/DesignDoc.pm index 513e9f5..161532d 100644 --- a/lib/CouchDB/Client/DesignDoc.pm +++ b/lib/CouchDB/Client/DesignDoc.pm @@ -72,6 +72,30 @@ sub queryView { return $res->{json}; } +sub bulkGetView { + my $self = shift; + my $view = shift; + my $keys = shift; + my %args = @_; + + confess("No such view: '$view'") unless exists $self->views->{$view}; + my $sn = $self->id; + $sn =~ s{^_design/}{}; + $sn = uri_escape_utf8($sn); + + my $vp = "/_design/$sn/_view/$view"; + if ($self->views->{$view}{reduce}) { + $args{group} = 'true' unless (exists $args{group} or exists $args{group_level}); + } + my $qs = %args ? $self->{db}->argsToQuery(%args) : ''; + + my $res = $self->{db}{client}->req('POST', $self->{db}->uriName . $vp . $qs, {keys => $keys}); + confess("Connection error: " . $res->{msg}) unless $res->{success}; + $res = $res->{json}{rows}; + + return $res; +} + 1; =pod @@ -133,6 +157,16 @@ The data structure that is returned is a hashref that will contain C C keys, as well as a C field that contains an array ref being the resultset. +=item bulkGetView $VIEW_NAME, $KEYS_AREF, %ARGS? + +Takes the name of a view in this design document, a reference to a list of +keys and an optional hash of query arguments. It will return a reference to a +list of hash references, where each hash is one fetched result. They will have +at least two keys, C and C. They may also have C (for +non-reducing views) and C (if you set the C argument to +true). If the view is reducing, C will be turned on automatically, +unless it or C is included in the passed-in argument hash. + =back =head1 AUTHOR diff --git a/lib/CouchDB/Client/Doc.pm b/lib/CouchDB/Client/Doc.pm index 01671c8..1ad8adf 100644 --- a/lib/CouchDB/Client/Doc.pm +++ b/lib/CouchDB/Client/Doc.pm @@ -71,7 +71,7 @@ sub create { sub contentForSubmit { my $self = shift; my $content = $self->{data}; - $content->{_id} = $self->{id} if $self->{id}; + $content->{_id} = '' . $self->{id} if $self->{id}; # Force stringness of id attribute $content->{_rev} = $self->{rev} if $self->{rev}; $content->{_attachments} = $self->{attachments} if $self->{attachments} and keys %{$self->{attachments}}; return $content; diff --git a/t/12-small-things.t b/t/12-small-things.t index 3a941fa..07ff78d 100644 --- a/t/12-small-things.t +++ b/t/12-small-things.t @@ -15,7 +15,7 @@ use LWP::UserAgent; my $cdb = CouchDB::Client->new( uri => $ENV{COUCHDB_CLIENT_URI} || 'http://localhost:5984/' ); if($cdb->testConnection) { - plan tests => 14; + plan tests => 22; } else { plan skip_all => 'Could not connect to CouchDB, skipping.'; @@ -36,14 +36,16 @@ my $DB = $C->newDB('blah'); endkey => 'foo', descending => 1, update => 1, - keeps => 'me correctly' + keeps => 'me correctly', + group => 1, ); is_deeply(\%encoded, { startkey => '42', endkey => '"foo"', descending => 'true', - keeps => 'me correctly' + keeps => 'me correctly', + group => 'true', }, "fixViewArgs works as expected"); %encoded = $DB->fixViewArgs(descending => 0, update => 0); @@ -58,6 +60,37 @@ my $DB = $C->newDB('blah'); # differences in the various json encoders. ok($encoded{key} =~ /^\s*\[\s*['"]one['"]\s*,\s*['"]two['"]\s*\]\s*$/, "Array encode works"); ok($encoded{startkey} =~ /^\s*\{['"]?key['"]?\s*:\s*['"]value['"]\s*}\s*$/, "Hash encode works"); + +} + +# test _is_currently_numeric +{ + # bare number not assigned to a scalar + is($DB->_is_currently_numeric(10),1,"bare number is numeric"); + + # bare string + is($DB->_is_currently_numeric("string"),0,"bare string is not numeric"); + + my $int = 12; + is($DB->_is_currently_numeric($int),1,"int scalar is numeric"); + + $int = ''.$int; + is($DB->_is_currently_numeric($int),0,"int is not numeric after string concatination"); + + # interesting gotcha. ++ for some reason does *NOT* make it treated like a number again. + $int += 0; + is($DB->_is_currently_numeric($int),1,"int is numeric again after += 0"); + + my $float = 12.34; + is($DB->_is_currently_numeric($float),1,"floating point scalar is numeric"); + + # still just numbers, but I treated it like a string + $float .= '5'; + is($DB->_is_currently_numeric($float),0,"float is not numeric after string concatination"); + + # treated it like a number again + $float++; + is($DB->_is_currently_numeric($float),1,"float is numeric again after ++"); } ### DESIGN DOC diff --git a/t/15-client.t b/t/15-client.t index 8a055c2..b4b2b26 100644 --- a/t/15-client.t +++ b/t/15-client.t @@ -21,7 +21,7 @@ if($cdb->testConnection) { plan skip_all => "Requires CouchDB version 0.8.0 or better; running $v"; } else { - plan tests => 77; + plan tests => 80; } } else { @@ -150,11 +150,19 @@ ok $DB, 'DB create'; # list Design Docs { + my $d1 = $DB->newDoc('test'); + $d1->create; + my $d2 = $DB->newDoc('_design/test'); + $d2->create; my $docs = $DB->listDesignDocs; ok ref($docs) eq 'ARRAY', 'listDesignDocs at least returns a list of something'; my $docs2 = $DB->listDesignDocIdRevs; ok ref($docs2) eq 'ARRAY', 'listDesignDocIdRevs at least returns a list of something'; ok @$docs == @$docs2, 'listDesignDocIdRevs and listDesignDocs return the same number of items'; + ok @$docs > 0, 'listDesignDocs returned more than zero items'; + ok ((grep {$_->{id} !~ /^_design/} @$docs) == 0, 'listDesignDocs returned only design docs'); + $d1->delete; + $d2->delete; } # new Design Doc & exists @@ -367,6 +375,16 @@ my $REP_DB; } } + +### Test for numeric id bug + +{ + my $numeric_id_doc = $DB->newDoc(17, undef, {some_data => 4711}); + eval {$numeric_id_doc->create}; + ok($numeric_id_doc && !$@, 'doc with numeric id created'); + eval {$numeric_id_doc->delete}; # cleanup +} + ### --- THE CLEANUP AT THE END $DD->delete;