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	dpavlin	205	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;