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 $t = time();

        $data->{x_meta} = {
                'time' => $t,
                'package' => $package,
                'line' => $line,
                'sub' => $sub,
        };
        $data->{'ident'} = [ @_ ] if @_;

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

        $audit->put( "pxelator/$t.$package.$url", $data );
}

1;
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 Time::HiRes qw/time/;
12	use Data::Structure::Util qw(unbless);
13	use Scalar::Util qw/blessed/;
14	use Storable qw/dclone/;
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 delete {
64	my ($self, $url) = @_;
65
66	$self->request(DELETE => $url);
67	}
68
69	sub get {
70	my ($self, $url) = @_;
71
72	JSON->new->utf8->decode( $self->request(GET => $url) );
73	}
74
75	sub put {
76	my ($self, $url, $json) = @_;
77
78	if ( ! defined $json->{_rev} ) {
79	my $old = eval { $self->get( $url )->{_rev} };
80	$rev->{$url} = $json->{_rev} = $old if defined $old;
81	}
82
83	$json = unbless dclone $json if blessed $json;
84
85	$json = JSON->new->utf8->encode( $json ) if $json;
86
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	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	my ( $package, $file, $line, $sub ) = caller(1);
106	( $package, undef, $line ) = caller(0) if $package eq 'main';
107
108	my $t = time();
109
110	$data->{x_meta} = {
111	'time' => $t,
112	'package' => $package,
113	'line' => $line,
114	'sub' => $sub,
115	};
116	$data->{'ident'} = [ @_ ] if @_;
117
118	warn 'audit ', dump($data), "at $file +$line\n";
119
120	$audit->put( "pxelator/$t.$package.$url", $data );
121	}
122
123	1;