lib/PXElator/CouchDB.pm

package CouchDB;

# http://wiki.apache.org/couchdb/Getting_started_with_Perl

use strict;
use warnings;

use LWP::UserAgent;
use JSON;
use Data::Dump qw/dump/;
use Time::HiRes qw/time/;
use Data::Structure::Util qw(unbless);
use Scalar::Util qw/blessed/;
use Storable qw/dclone/;

sub new {
        my ($class, $host, $port, $options) = @_;

        my $ua = LWP::UserAgent->new;
        $ua->timeout(10);
        $ua->env_proxy;

        $host ||= 'localhost';
        $port ||= 5984;

        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) = @_;

        my $full_uri = $self->base . $uri;
        my $req;

        if (defined $content) {
                #Content-Type: application/json

                $req = HTTP::Request->new( $method, $full_uri, undef, $content );
                $req->header('Content-Type' => 'application/json');
        } else {
                $req = HTTP::Request->new( $method, $full_uri );
        }

        my $response = $self->ua->request($req);

        if ($response->is_success) {
                return $response->content;
        } else {
                die($response->status_line . ":" . $response->content);
        }
}

our $rev;

sub delete {
        my ($self, $url) = @_;

        $self->request(DELETE => $url);
}

sub get {
        my ($self, $url) = @_;

        JSON->new->utf8->decode( $self->request(GET => $url) );
}

sub put {
        my ($self, $url, $json) = @_;

        if ( ! defined $json->{_rev} ) {
                my $old = eval { $self->get( $url )->{_rev} };
                $rev->{$url} = $json->{_rev} = $old if defined $old;
        }

        $json = unbless dclone $json if blessed $json;

        $json = JSON->new->utf8->encode( $json ) if $json;

        $self->request(PUT => $url, $json);
}

sub post {
        my ($self, $url, $json) = @_;

        $self->request(POST => $url, $json);
}

our $audit = __PACKAGE__->new;

sub audit {
        my $data = pop @_;

        my $url = join(' ', @_);
        $url =~ s/-\S+//g;
        $url =~ s/\W+/-/g;

        my ( $package, $file, $line, $sub ) = caller(1);
        ( $package, undef, $line ) = caller(0) if $package eq 'main';

        my $time = time();

        $data->{$_} = eval '$' . $_ foreach ( qw/time package line sub/ );

        warn 'audit ', dump($data), "at $file +$line\n";

        $time = int($time); # reduce granularity
        $audit->put( "pxelator/$time.$package.$url", $data );
}

1;
1	dpavlin	205	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	dpavlin	206	use Time::HiRes qw/time/;
12			use Data::Structure::Util qw(unbless);
13			use Scalar::Util qw/blessed/;
14			use Storable qw/dclone/;
15	dpavlin	205
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 delete {
64			my ($self, $url) = @_;
65
66			$self->request(DELETE => $url);
67			}
68
69			sub get {
70			my ($self, $url) = @_;
71
72	dpavlin	206	JSON->new->utf8->decode( $self->request(GET => $url) );
73	dpavlin	205	}
74
75			sub put {
76			my ($self, $url, $json) = @_;
77
78	dpavlin	206	if ( ! defined $json->{_rev} ) {
79			my $old = eval { $self->get( $url )->{_rev} };
80			$rev->{$url} = $json->{_rev} = $old if defined $old;
81			}
82	dpavlin	205
83	dpavlin	206	$json = unbless dclone $json if blessed $json;
84	dpavlin	205
85	dpavlin	206	$json = JSON->new->utf8->encode( $json ) if $json;
86	dpavlin	205
87			$self->request(PUT => $url, $json);
88			}
89
90			sub post {
91			my ($self, $url, $json) = @_;
92
93			$self->request(POST => $url, $json);
94			}
95
96	dpavlin	206	our $audit = __PACKAGE__->new;
97
98			sub audit {
99			my $data = pop @_;
100
101			my $url = join(' ', @_);
102			$url =~ s/-\S+//g;
103			$url =~ s/\W+/-/g;
104
105	dpavlin	207	my ( $package, $file, $line, $sub ) = caller(1);
106	dpavlin	206	( $package, undef, $line ) = caller(0) if $package eq 'main';
107
108	dpavlin	208	my $time = time();
109	dpavlin	207
110	dpavlin	208	$data->{$_} = eval '$' . $_ foreach ( qw/time package line sub/ );
111	dpavlin	206
112	dpavlin	207	warn 'audit ', dump($data), "at $file +$line\n";
113
114	dpavlin	208	$time = int($time); # reduce granularity
115			$audit->put( "pxelator/$time.$package.$url", $data );
116	dpavlin	206	}
117
118	dpavlin	205	1;