git.rot13.org Git - ILL-Zotero-RT/blob - CouchDB.pm

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