Better support for CouchDB instances requiring authentication

.gitignore

@@ -7,3 +7,4 @@ cover_db
 *.bak
 *.old
 inc
+MYMETA.*

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 () {

debian/changelog

@@ -0,0 +1,5 @@
+libcouchdb-client-perl (0.10-1) trusty; urgency=medium
+
+  * Packaging.
+
+ -- calle <calle@trettontio>  Wed, 12 Feb 2014 15:58:37 +0100

debian/compat

@@ -0,0 +1 @@
+7

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 <[email protected]>
+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.
+ .

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 <[email protected]>
+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.

debian/rules

@@ -0,0 +1,4 @@
+#!/usr/bin/make -f
+
+%:
+	dh $@

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<uri> which specifies the server's URI;
-C<scheme>, C<host>, C<port> which are used if C<uri> isn't provided and default to 'http',
-'localhost', and '5984' respectively; C<json> 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<ua> which is a LWP::UserAgent object and can also be replaced.
+Constructor. Takes a hash or hashref of options: C<uri> which specifies the
+server's URI; C<scheme>, C<host>, C<port> which are used if C<uri> isn't
+provided and default to 'http', 'localhost', and '5984' respectively; C<json>
+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<ua> which is a
+LWP::UserAgent object and can also be replaced. For ease of use you can also
+pass C<username>, C<password> and C<realm>, which will if so be used to add
+login credentials to the LWP::UserAgent object. C<realm> is optional, and will
+if not specified default to "administrator" (which is the default used by
+CouchDB).
 
 =item testConnection
 

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<CouchDB::Client::Doc> 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<CouchDB::Client::Doc> objects or C<undefined>.
+
 =item uriName
 
 Returns the name of the database escaped.

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<total_rows>
 C<offset> keys, as well as a C<rows> 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<key> and C<value>. They may also have C<id> (for
+non-reducing views) and C<doc> (if you set the C<include_docs> argument to
+true). If the view is reducing, C<group=true> will be turned on automatically,
+unless it or C<group_level> is included in the passed-in argument hash.
+
 =back
 
 =head1 AUTHOR

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;