lib/PXElator/CouchDB.pm

package CouchDB;

# http://wiki.apache.org/couchdb/Getting_started_with_Perl

use strict;
use warnings;

use LWP::UserAgent;
use JSON;
use Data::Dump qw/dump/;

sub new {
        my ($class, $host, $port, $options) = @_;

        my $ua = LWP::UserAgent->new;
        $ua->timeout(10);
        $ua->env_proxy;

        $host ||= 'localhost';
        $port ||= 5984;

        return bless {
                ua                       => $ua,
                host             => $host,
                port             => $port,
                base_uri => "http://$host:$port/",
        }, $class;
}

sub ua { shift->{ua} }
sub base { shift->{base_uri} }

sub request {
        my ($self, $method, $uri, $content) = @_;

        my $full_uri = $self->base . $uri;
        my $req;

        if (defined $content) {
                #Content-Type: application/json

                $req = HTTP::Request->new( $method, $full_uri, undef, $content );
                $req->header('Content-Type' => 'application/json');
        } else {
                $req = HTTP::Request->new( $method, $full_uri );
        }

        my $response = $self->ua->request($req);

        if ($response->is_success) {
                return $response->content;
        } else {
                die($response->status_line . ":" . $response->content);
        }
}

our $rev;

sub delete {
        my ($self, $url) = @_;

        $self->request(DELETE => $url);
}

sub get {
        my ($self, $url) = @_;

        from_json $self->request(GET => $url);
}

sub put {
        my ($self, $url, $json) = @_;
        warn "put $url ",dump($json);

        $rev->{$url} ||= eval { $self->get( $url )->{_rev} };

        $json->{_rev} = $rev->{$url} if $rev->{$url};

        $json = to_json $json if $json;

        $self->request(PUT => $url, $json);
}

sub post {
        my ($self, $url, $json) = @_;

        $self->request(POST => $url, $json);
}

1;
1	package CouchDB;
2
3	# http://wiki.apache.org/couchdb/Getting_started_with_Perl
4
5	use strict;
6	use warnings;
7
8	use LWP::UserAgent;
9	use JSON;
10	use Data::Dump qw/dump/;
11
12	sub new {
13	my ($class, $host, $port, $options) = @_;
14
15	my $ua = LWP::UserAgent->new;
16	$ua->timeout(10);
17	$ua->env_proxy;
18
19	$host \|\|= 'localhost';
20	$port \|\|= 5984;
21
22	return bless {
23	ua => $ua,
24	host => $host,
25	port => $port,
26	base_uri => "http://$host:$port/",
27	}, $class;
28	}
29
30	sub ua { shift->{ua} }
31	sub base { shift->{base_uri} }
32
33	sub request {
34	my ($self, $method, $uri, $content) = @_;
35
36	my $full_uri = $self->base . $uri;
37	my $req;
38
39	if (defined $content) {
40	#Content-Type: application/json
41
42	$req = HTTP::Request->new( $method, $full_uri, undef, $content );
43	$req->header('Content-Type' => 'application/json');
44	} else {
45	$req = HTTP::Request->new( $method, $full_uri );
46	}
47
48	my $response = $self->ua->request($req);
49
50	if ($response->is_success) {
51	return $response->content;
52	} else {
53	die($response->status_line . ":" . $response->content);
54	}
55	}
56
57	our $rev;
58
59	sub delete {
60	my ($self, $url) = @_;
61
62	$self->request(DELETE => $url);
63	}
64
65	sub get {
66	my ($self, $url) = @_;
67
68	from_json $self->request(GET => $url);
69	}
70
71	sub put {
72	my ($self, $url, $json) = @_;
73	warn "put $url ",dump($json);
74
75	$rev->{$url} \|\|= eval { $self->get( $url )->{_rev} };
76
77	$json->{_rev} = $rev->{$url} if $rev->{$url};
78
79	$json = to_json $json if $json;
80
81	$self->request(PUT => $url, $json);
82	}
83
84	sub post {
85	my ($self, $url, $json) = @_;
86
87	$self->request(POST => $url, $json);
88	}
89
90	1;