/[pxelator]/lib/PXElator/CouchDB.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /lib/PXElator/CouchDB.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 485 - (show annotations)
Sat Jan 23 19:46:19 2010 UTC (14 years, 2 months ago) by dpavlin
File size: 2219 byte(s)
store data in MongoDB

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 use Data::Structure::Util qw(unbless);
12 use Scalar::Util qw/blessed/;
13 use Storable qw/dclone/;
14 use Carp qw/carp/;
15
16 sub new {
17 my ($class, $host, $port, $options) = @_;
18
19 my $ua = LWP::UserAgent->new;
20 $ua->timeout(10);
21 $ua->env_proxy;
22
23 $host ||= 'localhost';
24 $port ||= 5984;
25
26 return bless {
27 ua => $ua,
28 host => $host,
29 port => $port,
30 base_uri => "http://$host:$port/",
31 }, $class;
32 }
33
34 sub ua { shift->{ua} }
35 sub base { shift->{base_uri} }
36
37 sub request {
38 my ($self, $method, $uri, $content) = @_;
39
40 my $full_uri = $self->base . $uri;
41 my $req;
42
43 if (defined $content) {
44 #Content-Type: application/json
45
46 $req = HTTP::Request->new( $method, $full_uri, undef, $content );
47 $req->header('Content-Type' => 'application/json');
48 } else {
49 $req = HTTP::Request->new( $method, $full_uri );
50 }
51
52 my $response = $self->ua->request($req);
53
54 if ($response->is_success) {
55 return $response->content;
56 } else {
57 die($response->status_line . ":" . $response->content);
58 }
59 }
60
61 our $rev;
62
63 sub rev {
64 my ($self,$url) = @_;
65 my $rev = $rev->{$url};
66 $rev ||= eval { $self->get( $url )->{_rev} };
67 # warn "# rev $url $rev";
68 return $rev;
69 }
70
71 sub delete {
72 my ($self, $url) = @_;
73
74 $self->request(DELETE => $url . '?rev=' . $self->rev($url) );
75 }
76
77 sub get {
78 my ($self, $url) = @_;
79
80 JSON->new->utf8->decode( $self->request(GET => $url) );
81 }
82
83 sub put {
84 my ($self, $url, $json) = @_;
85
86 $json->{_rev} = $rev->{$url} if defined $rev->{$url};
87
88 my $data = dclone $json;
89 $data = unbless $data if blessed $data;
90
91 # warn "# put ",dump( $data );
92
93 $json = JSON->new->utf8->encode( $data );
94
95 carp "# put ",$json;
96
97 do {
98 my $json = eval { $self->request(PUT => $url, $json) };
99 if ( $@ ) {
100 $rev->{$url} = $self->rev( $url );
101 warn "refresh rev $url = ", $rev->{$url};
102 } else {
103 $rev->{$url} = JSON->new->decode( $json )->{rev};
104 }
105 } until ! $@;
106 }
107
108 sub post {
109 my ($self, $url, $json) = @_;
110
111 $self->request(POST => $url, $json);
112 }
113
114 our $audit = __PACKAGE__->new;
115
116 sub _store_audit {
117 my ( $id, $data ) = @_;
118 $audit->put( "pxelator/$id", $data );
119 }
120
121 1;

  ViewVC Help
Powered by ViewVC 1.1.26