Changeset 18660 for lang/perl

Timestamp:

09/02/08 21:43:53 (5 years ago)

Author:

masaki

Message:

Database#query 追加，テストも追加，Utils やめて Role にした

Location:

lang/perl/CouchDB-Object/trunk

Files:

• Makefile.PL (modified) (2 diffs)
• lib/CouchDB/Object.pm (modified) (3 diffs)
• lib/CouchDB/Object/Database.pm (modified) (7 diffs)
• lib/CouchDB/Object/Document.pm (modified) (2 diffs)
• lib/CouchDB/Object/Documents.pm (modified) (3 diffs)
• lib/CouchDB/Object/Response.pm (modified) (2 diffs)
• lib/CouchDB/Object/Role (added)
• lib/CouchDB/Object/Role/Client.pm (added)
• lib/CouchDB/Object/Server.pm (deleted)
• lib/CouchDB/Object/UserAgent.pm (modified) (3 diffs)
• lib/CouchDB/Object/Utils.pm (deleted)
• t/01_server.t (modified) (1 diff)
• t/02_database.t (modified) (2 diffs)
• t/03_document.t (deleted)
• t/03_save_doc.t (added)
• t/04_open_doc.t (added)
• t/05_remove_doc.t (added)
• t/06_all_docs.t (moved) (moved from lang/perl/CouchDB-Object/trunk/t/04_all_docs.t) (1 diff)
• t/07_query.t (added)
• t/CouchDB.pm (modified) (1 diff)
• t/docs.json (added)

lang/perl/CouchDB-Object/trunk/Makefile.PL

@@ -6 +6 @@
 requires 'MooseX::AttributeHelpers';
 requires 'MooseX::Types::URI';
-requires 'Class::Inspector';
-requires 'Exporter';
+requires 'Data::Dump::Streamer';
 requires 'Hash::AsObject';
 requires 'Hash::Merge';
-requires 'HTTP::Request::Common' => 5.814; # for DELETE
-requires 'HTTP::Response';
+requires 'HTTP::Headers';
+requires 'HTTP::Request';
 requires 'JSON::XS';
 requires 'LWP::UserAgent';
@@ -20 +19 @@
 
 test_requires 'Test::More';
+test_requires 'JSON::XS';
 test_requires 'String::Random';
+test_requires 'String::TT';
+test_requires 'URI';
+
 use_test_base;
 auto_include;

lang/perl/CouchDB-Object/trunk/lib/CouchDB/Object.pm

@@ -1 +1 @@
 package CouchDB::Object;
 
-use strict;
-use warnings;
+use Moose;
+use URI;
+use CouchDB::Object::Database;
+
+with 'CouchDB::Object::Role::Client';
+
+has 'scheme' => (is => 'rw', isa => 'Str', default => sub { 'http' });
+has 'host'   => (is => 'rw', isa => 'Str', default => sub { 'localhost' });
+has 'port'   => (is => 'rw', isa => 'Num', default => sub { 5984 });
+
+no Moose;
 
 our $VERSION = '0.01';
+
+sub uri {
+    my $self = shift;
+    return URI->new(sprintf '%s://%s:%d/', $self->scheme, $self->host, $self->port);
+}
+
+sub db {
+    my ($self, $name) = @_;
+    return CouchDB::Object::Database->new(
+        name   => $name,
+        server => $self->uri,
+        agent  => $self->agent,
+    );
+}
+
+sub all_dbs {
+    my ($self, $args) = @_;
+
+    my $res = $self->request(GET => $self->uri_for('_all_dbs'));
+    return $self->ping ? map { $self->db($_) } @{ $res->parsed_content } : ();
+}
+
+sub info {
+    my $self = shift;
+    return $self->request(GET => $self->uri);
+}
+
+sub ping {
+    my $self = shift;
+    return eval { $self->info->is_success };
+}
+
+sub replicate {
+    # TODO: implements
+}
+
+__PACKAGE__->meta->make_immutable;
 
 1;
@@ -11 +57 @@
 
 CouchDB::Object - Yet another CouchDB client
+
+=head1 SYNOPSIS
+
+  use CouchDB::Object;
+
+  my $couch = CouchDB::Object->new(host => 'localhost', port => 5984);
+
+  if ($couch->ping) {
+      print "connect CouchDB";
+
+      my $db = $couch->db('dbname');
+      my @dbs = $couch->all_dbs;
+  }
+
+=head1 METHODS
+
+=head2 new(host => $host, port => $port [, scheme => $scheme ])
+
+Returns the CouchDB server object.
+
+=head2 ping
+
+Returns true if a connection can be made to the server, false otherwise.
+
+=head2 db($dbname)
+
+Returns the L<CouchDB::Object::Database> object of that name.
+
+=head2 all_dbs
+
+Returns L<CouchDB::Object::Database> objects that the server knows of.
+
+=head2 info
+
+Returns the L<CouchDB::Object::Response> object for server.
+
+=head2 replicate
+
+Not implemented yet.
 
 =head1 AUTHOR
@@ -23 +108 @@
 =head1 SEE ALSO
 
-L<CouchDB::Object::Server>, L<CouchDB::Object::Database>
+L<CouchDB::Object::Database>, L<CouchDB::Object::Response>
 
 =cut

lang/perl/CouchDB-Object/trunk/lib/CouchDB/Object/Database.pm

@@ -3 +3 @@
 use Moose;
 use MooseX::Types::URI qw(Uri);
-use CouchDB::Object;
-use CouchDB::Object::UserAgent;
-use CouchDB::Object::Utils qw(uri_for);
+use Data::Dump::Streamer;
+use HTTP::Headers;
+use JSON::XS ();
+use URI::Escape qw(uri_escape_utf8);
+
+with 'CouchDB::Object::Role::Client';
 
 has 'name' => (
-    is       => 'ro',
+    is       => 'rw',
     isa      => 'Str',
     required => 1,
 );
 
-has 'uri' => (
-    is       => 'ro',
+has 'server' => (
+    is       => 'rw',
     isa      => Uri,
     coerce   => 1,
@@ -20 +23 @@
 );
 
-has 'agent' => (
-    is       => 'ro',
-    isa      => 'CouchDB::Object::UserAgent',
-    required => 1,
-    default  => sub { CouchDB::Object::UserAgent->new },
-);
-
 no Moose;
 
-our $VERSION = CouchDB::Object->VERSION;
+our $VERSION = '0.01';
 
-sub BUILD {
-    my ($self, $args) = @_;
-    $self->uri->$_(undef) for qw(query fragment);
+sub uri {
+    my $self = shift;
+
+    my $uri = $self->server->clone;
+    $uri->path_segments($self->name, '');
+    $uri->canonical;
 }
 
 sub create {
     my $self = shift;
-    return $self->agent->put($self->uri);
+    return $self->request(PUT => $self->uri);
 }
 
 sub drop {
     my $self = shift;
-    return $self->agent->delete($self->uri);
+    return $self->request(DELETE => $self->uri);
 }
 
 sub info {
     my $self = shift;
-    return $self->agent->get($self->uri);
+    return $self->request(GET => $self->uri);
 }
 
@@ -57 +56 @@
 sub all_docs {
     my ($self, $args) = @_;
-    return $self->agent->get($self->uri_for('_all_docs', $args));
+    return $self->request(GET => $self->uri_for('_all_docs', $args));
 }
 
 sub open_doc {
     my ($self, $id, $args) = @_;
-    return $self->agent->get($self->uri_for($id, $args));
+    return $self->request(GET => $self->uri_for($id, $args));
 }
 
@@ -68 +67 @@
     my ($self, $doc, $args) = @_;
 
-    my $agent   = $self->agent;
-    my $content = $doc->to_json;
-    my $res     = $doc->has_id
-        ? $agent->put($self->uri_for($doc->id), Content => $content)
-        : $agent->post($self->uri, Content => $content);
+    my $header = HTTP::Headers->new('Content-Type' => 'application/json');
+    my $res = $doc->has_id
+        ? $self->request(PUT => $self->uri_for($doc->id), $header, $doc->to_json)
+        : $self->request(POST => $self->uri, $header, $doc->to_json);
 
     # merge
@@ -90 +88 @@
 
     my $params = { rev => $doc->rev, %{ $args || {} } };
-    return $self->agent->delete($self->uri_for($doc->id, $params));
+    return $self->request(DELETE => $self->uri_for($doc->id, $params));
 }
 
@@ -98 +96 @@
 
 sub query {
-    # TODO: implements
+    my ($self, $map, $reduce, $lang, $args) = @_;
+
+    my $body = {
+        language => $lang || (ref $map eq 'CODE') ? 'text/perl' : 'javascript',
+        map      => _code2str($map),
+    };
+    $body->{reduce} = _code2str($reduce) if defined $reduce;
+    $body = JSON::XS->new->encode($body);
+
+    my $header = HTTP::Headers->new('Content-Type' => 'application/json');
+    return $self->request(POST => $self->uri_for('_temp_view', $args), $header, $body);
 }
 
 sub view {
     # TODO: implements
+}
+
+# from CouchDB::View::Document
+sub _code2str {
+    ref $_[0]
+        ? sprintf 'do { my $CODE1; %s; $CODE1 }', Data::Dump::Streamer->new->Data($_[0])->Out
+        : $_[0];
 }
 
@@ -117 +132 @@
 =head1 METHODS
 
-=head2 new(name => $dbname, uri => $uri)
+=head2 new(name => $dbname, server => $uri)
 
 Returns the L<CouchDB::Object::Database> object

lang/perl/CouchDB-Object/trunk/lib/CouchDB/Object/Document.pm

@@ -5 +5 @@
 use Hash::Merge ();
 use JSON::XS ();
-use CouchDB::Object;
 
 has 'id' => (
@@ -28 +27 @@
 no Moose;
 
-our $VERSION = CouchDB::Object->VERSION;
+our $VERSION = '0.01';
 
 sub new_from_json {

lang/perl/CouchDB-Object/trunk/lib/CouchDB/Object/Documents.pm

@@ -3 +3 @@
 use Moose;
 use MooseX::AttributeHelpers;
-use CouchDB::Object;
 use CouchDB::Object::Document;
 
@@ -28 +27 @@
 no Moose;
 
-our $VERSION = CouchDB::Object->VERSION;
+our $VERSION = '0.01';
 
 sub new_from_json {
@@ -46 +45 @@
     );
 }
+
+sub all { shift->docs } # readonly
 
 __PACKAGE__->meta->make_immutable;

lang/perl/CouchDB-Object/trunk/lib/CouchDB/Object/Response.pm

@@ -5 +5 @@
 use Hash::AsObject;
 use JSON::XS ();
-use CouchDB::Object;
 use CouchDB::Object::Document;
 use CouchDB::Object::Documents;
@@ -36 +35 @@
 no Moose;
 
-our $VERSION = CouchDB::Object->VERSION;
+our $VERSION = '0.01';
 
 sub new_from_response {

lang/perl/CouchDB-Object/trunk/lib/CouchDB/Object/UserAgent.pm

@@ -2 +2 @@
 
 use Moose;
-use HTTP::Request::Common 5.814 qw(PUT DELETE);
 use CouchDB::Object;
-use CouchDB::Object::Response;
 
 extends 'LWP::UserAgent';
@@ -10 +8 @@
 no Moose;
 
-our $VERSION = CouchDB::Object->VERSION;
+our $VERSION = '0.01';
 
 sub BUILD {
@@ -26 +24 @@
     $req->header(Content_Type => 'application/json') if $req->content;
 
-    my $res = $self->SUPER::request($req);
-    return CouchDB::Object::Response->new_from_response($res);
-}
-
-sub put {
-    my ($self, @params) = @_;
-    my @suff = $self->_process_colonic_headers(\@params, ref $params[1] ? 2 : 1);
-    return $self->request(PUT(@params), @suff);
-}
-
-sub delete {
-    my ($self, @params) = @_;
-    my @suff = $self->_process_colonic_headers(\@params, 1);
-    return $self->request(DELETE(@params), @suff);
+    # TODO: super()
+    return $self->SUPER::request($req);
 }
 

lang/perl/CouchDB-Object/trunk/t/01_server.t

@@ -2 +2 @@
 use t::CouchDB;
 
-my $server = server();
-my $couch  = CouchDB::Object::Server->new(uri => $server);
+my $couch = test_couch();
 
-plan skip_all => "Can't connect CouchDB server: $server" unless $couch->ping;
-plan tests => 3 if $couch->ping;
+unless ($couch->ping) {
+    plan skip_all => "Can't connect CouchDB server: " . test_server();
+}
+else {
+    plan tests => 2;
+}
 
-# server info
-is $couch->uri => $server;
-ok $couch->info->is_success;
-
-# replicate
-TODO: {
-    local $TODO = 'replicate(): not implemented yet';
-    ok $couch->replicate;
-};
+is $couch->uri => test_server();
+isa_ok $couch->db(test_dbname()) => 'CouchDB::Object::Database';

lang/perl/CouchDB-Object/trunk/t/02_database.t

@@ -2 +2 @@
 use t::CouchDB;
 
-my $server = server();
-my $couch  = CouchDB::Object::Server->new(uri => $server);
+my $couch = test_couch();
 
-plan skip_all => "Can't connect CouchDB server: $server" unless $couch->ping;
-plan tests => 7 if $couch->ping;
+unless ($couch->ping) {
+    plan skip_all => "Can't connect CouchDB server: " . test_server();
+}
+else {
+    plan tests => 7;
+}
 
-my $name = random_name();
-my $uri  = $server . $name;
-my $db   = $couch->db($name);
+my $server = test_server();
+my $name   = test_dbname();
 
-# info
-is $db->name => $name;
-is $db->uri  => $uri;
+my $uri = $server->clone;
+$uri->path_segments($name, '');
+
+my $db = CouchDB::Object::Database->new(name => $name, server => $server);
+
+is $db->uri => $uri;
 
 # create
@@ -20 +25 @@
 ok $db->create->is_success; # 201
 ok $db->info->is_success;   # 200
+is $db->info->content->db_name => $name;
 
 # drop

lang/perl/CouchDB-Object/trunk/t/06_all_docs.t

@@ -2 +2 @@
 use t::CouchDB;
 
-my $server = server();
-my $couch  = CouchDB::Object::Server->new(uri => $server);
+my $couch = test_couch();
 
-plan skip_all => "Can't connect CouchDB server: $server" unless $couch->ping;
-plan tests => 22 if $couch->ping;
-
-my $dbname = random_name();
-my $dburi  = $server . $dbname;
-
-my $db = $couch->db($dbname);
-$db->create;
-END {
-    $db->drop if $couch->ping;
+unless ($couch->ping) {
+    plan skip_all => "Can't connect CouchDB server: " . test_server();
+}
+else {
+    plan tests => 24;
 }
 
-my @docs = ();
-for (1..5) {
-    my $doc = CouchDB::Object::Document->new;
-    $doc->id(sprintf '%03d', $_);
-    $db->save_doc($doc);
-    push @docs, $doc;
+my ($name, $db) = deploy_db();
+END { $db->drop if $couch->ping }
+
+{
+    my $res = $db->all_docs;
+    ok $res->is_success;
+
+    my $docs = $res->to_document;
+    is $docs->total_docs => 5;
+    is $docs->offset => 0;
+
+    is $docs->count => 5;
+    for my $doc ($docs->all) { # 2 x 5 = 10
+        ok $doc->id;
+        ok $doc->rev;
+    }
 }
 
-my $all_docs = $db->all_docs->to_document;
-is $all_docs->total_docs => 5;
-is $all_docs->count => 5;
-is $all_docs->offset => 0;
-my @all_docs = $all_docs->docs;
-for (0..4) {
-    is $all_docs[$_]->id,  $docs[$_]->id;
-    is $all_docs[$_]->rev, $docs[$_]->rev;
+{
+    my $res = $db->all_docs({ count => 3 });
+    ok $res->is_success;
+
+    my $docs = $res->to_document;
+    is $docs->total_docs => 5;
+    is $docs->offset => 0;
+
+    is $docs->count => 3;
+    for my $doc ($docs->all) { # 2 x 3 = 6
+        ok $doc->id;
+        ok $doc->rev;
+    }
 }
-
-my $counted_docs = $db->all_docs({ count => 3 })->to_document;
-is $counted_docs->total_docs => 5;
-is $counted_docs->count => 3;
-is $counted_docs->offset => 0;
-my @counted_docs = $counted_docs->docs;
-for (0..2) {
-    is $counted_docs[$_]->id,  $docs[$_]->id;
-    is $counted_docs[$_]->rev, $docs[$_]->rev;
-}

lang/perl/CouchDB-Object/trunk/t/CouchDB.pm

@@ -1 +1 @@
 package t::CouchDB;
 
+use strict;
 use Test::Base -Base;
-use String::Random;
-use CouchDB::Object::Server;
-use CouchDB::Object::Database;
+use JSON::XS ();
+use String::Random ();
+use URI;
+use CouchDB::Object;
 use CouchDB::Object::Document;
 
-our @EXPORT = qw(server random_name);
+our @EXPORT = qw(test_server test_dbname test_couch deploy_db);
 
-sub server {
-    my $server = $ENV{TEST_COUCHDB} || 'http://localhost:5984/';
-    $server =~ s{(?<!/)$}{/};
-    $server;
+sub test_server {
+    my $uri = URI->new($ENV{TEST_COUCHDB} || 'http://localhost:5984/');
+    $uri->path('/');
+    $uri;
 }
 
-sub random_name {
+sub test_dbname {
     String::Random->new->randregex('[a-z]{20}');
 }
 
+sub test_couch {
+    my $uri = test_server();
+    CouchDB::Object->new(scheme => $uri->scheme, host => $uri->host, port => $uri->port);
+}
+
+sub deploy_db {
+    my $couch = test_couch();
+    my $name  = test_dbname();
+
+    my $db = $couch->db($name);
+    $db->create;
+
+    my $data = do {
+        open my $fh, '<', 't/docs.json' or die $!;
+        local $/; <$fh>;
+    };
+    my $json = JSON::XS->new->decode($data);
+    for (@$json) {
+        my $doc = CouchDB::Object::Document->new;
+        $doc->id(delete $_->{id});
+        while (my ($key, $value) = each %$_) {
+            $doc->$key($value);
+        }
+        $db->save_doc($doc);
+    }
+
+    ($name, $db);
+}
+
 1;