package CouchDB; use strict; 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) = @_; my $ua = LWP::UserAgent->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, port => $port, base_uri => "http://$host:$port/", }, $class; } sub ua { shift->{ua} } sub base { shift->{base_uri} } sub request { my ($self, $method, $uri, $content, $content_type) = @_; $content_type ||= 'application/json'; my $full_uri = $self->base . $uri; my $req; warn "# request $method $full_uri ", $content ? length($content) : '-' , " $content_type\n"; 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 ); } my $response = $self->ua->request($req); if ($response->is_success) { return decode_json $response->content; } else { die($response->status_line . ":" . $response->content); } } sub delete { my ($self, $url) = @_; $self->request(DELETE => $url); } sub get { my ($self, $url) = @_; $self->request(GET => $url); } sub put { my ($self, $url, $json) = @_; $self->request(PUT => $url, $json); } sub post { my ($self, $url, $json) = @_; $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;