git.rot13.org Git - pxelator/blob - lib/PXElator/CouchDB.pm

   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;