X-Git-Url: http://git.rot13.org/?p=ILL-Zotero-RT;a=blobdiff_plain;f=CouchDB.pm;h=016a7d803651032612556f033e9cb4aefb484694;hp=8b13b36002974f8bf299271e256b6b40e20ef888;hb=HEAD;hpb=71ffa85cdd50cf657eee7d2b4ab1c60f65c70283

diff --git a/CouchDB.pm b/CouchDB.pm
index 8b13b36..016a7d8 100644
--- a/CouchDB.pm
+++ b/CouchDB.pm
@@ -5,6 +5,11 @@ use warnings;
 
 use LWP::UserAgent;
 use JSON;
+use Digest::MD5 qw(md5_hex);
+use Data::Dump qw(dump);
+use Encode;
+use Carp;
+use Clone qw(clone);
 
 sub new {
   my ($class, $host, $port, $options) = @_;
@@ -13,6 +18,11 @@ sub new {
   $ua->timeout(10);
   $ua->env_proxy;
 
+  if ( $ENV{DEBUG} ) {
+	$ua->add_handler("request_send",  sub { shift->dump; return });
+	$ua->add_handler("response_done", sub { shift->dump; return });
+  }
+
   return bless {
                 ua       => $ua,
                 host     => $host,
@@ -25,16 +35,20 @@ sub ua { shift->{ua} }
 sub base { shift->{base_uri} }
 
 sub request {
-  my ($self, $method, $uri, $content) = @_;
+  my ($self, $method, $uri, $content, $content_type) = @_;
+  $content_type ||= 'application/json';
 
   my $full_uri = $self->base . $uri;
   my $req;
 
-  if (defined $content) {
-    #Content-Type: application/json
+  warn "# request $method $full_uri ", $content ? length($content) : '-' , " $content_type\n";
 
-    $req = HTTP::Request->new( $method, $full_uri, undef, encode_json $content );
-    $req->header('Content-Type' => 'application/json');
+  if (defined $content) {
+    $req = HTTP::Request->new( $method, $full_uri, undef );
+    $req->header( 'Content-Type' => $content_type );
+    my $bytes = ref($content) ? encode_json($content) : $content;
+    $req->content( $bytes ); # convert to bytes
+    warn "### ",dump($bytes);
   } else {
     $req = HTTP::Request->new( $method, $full_uri );
   }
@@ -57,14 +71,12 @@ sub delete {
 sub get {
   my ($self, $url) = @_;
 
-  warn "## GET $url";
   $self->request(GET => $url);
 }
 
 sub put {
   my ($self, $url, $json) = @_;
 
-  warn "## PUT $url";
   $self->request(PUT => $url, $json);
 }
 
@@ -74,4 +86,56 @@ sub post {
   $self->request(POST => $url, $json);
 }
 
+sub x_sync {
+	my ($json,$old) = @_;
+	$json->{$_} = $old->{$_} foreach keys %{ $old->{x_meta} }; # special persistent x_meta fields
+	my $json_md5 = md5_hex encode_json $json;
+	$json->{x_sync}->{json_md5} = $json_md5;
+	my $o =  $old->{x_sync}->{json_md5};
+	my $n = $json->{x_sync}->{json_md5};
+	warn "## x_sync $o ", $o eq $n ? '==' : '!=', " $n\n";
+	return $json;
+}
+
+
+sub modify {
+	my ($self, $url, $json) = @_;
+
+	carp "# modify $url ", ref $json;
+
+	my $ret;
+
+	if ( my $old = eval { $self->get( $url ) } ) {
+		warn "# old ", $old->{_rev}, dump($old);
+
+		if ( ref $json eq 'CODE' ) {
+			$json = $json->( clone $old );
+			warn "# json CODE ",dump($json);
+		} else {
+			warn "# overwrite old";
+			$json->{_rev} = $old->{_rev};
+		}
+
+		$json = x_sync($json, $old);
+
+		if ( $json->{x_sync}->{json_md5} ne $old->{x_sync}->{json_md5} ) {
+			warn "# modify $url";
+			$ret = $self->put( $url => $json );
+		} else {
+			warn "# unchanged $url";
+			$ret->{rev} = $old->{_rev};
+			$ret->{id}  = $old->{_id};
+		}
+	} else {
+		$json = $json->({}) if ref $json eq 'CODE';
+
+		$json = x_sync($json);
+
+		warn "# insert $url ", dump($json);
+		$ret = $self->put( $url => $json );
+	}
+
+	return $ret;
+}
+
 1;