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/;
use Carp qw/carp/;
use POSIX;

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 rev {
        my ($self,$url) = @_;
        my $rev = $rev->{$url};
        $rev  ||= eval { $self->get( $url )->{_rev} };
#       warn "# rev $url $rev";
        return $rev;
}

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

        $self->request(DELETE => $url . '?rev=' . $self->rev($url) );
}

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

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

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

        $json->{_rev} = $rev->{$url} if defined $rev->{$url};

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

#       warn "# put ",dump( $data );

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

        carp "# put ",$json;

        do {
                my $json = eval { $self->request(PUT => $url, $json) };
                if ( $@ ) {
                        $rev->{$url} = $self->rev( $url );
                        warn "refresh rev $url = ", $rev->{$url};
                } else {
                        $rev->{$url} = JSON->new->decode( $json )->{rev};
                }
        } until ! $@;
}

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+-\S+//g;   # remove command line options
        $url =~ s/\W+/-/g;

        my $time = $data->{time} = time();

        my @caller_name = ( qw/package file line sub/ );
        my @caller = caller(0);
        $caller[3] = (caller(1))[3];
        $caller[3] =~ s{^.+::}{}; # stip package name from sub
        $data->{ $caller_name[$_] } = $caller[$_] foreach ( 0 .. $#caller_name );

        if ( $ENV{DEBUG} ) {

                my $caller;
                my $depth = 0;
                while ( my @c = caller($depth) ) {
                        push @$caller, [ @c ];
                        $depth++;
                }

                $data->{caller} = $caller;

        }

#       carp 'audit ', dump($data);

#       $time = int($time); # reduce granularity for url
        $time = strftime("%Y-%m-%d.%H:%M:%S", localtime $time);
        my $package = $caller[0];
        $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	221	use Carp qw/carp/;
16	dpavlin	299	use POSIX;
17	dpavlin	205
18			sub new {
19			my ($class, $host, $port, $options) = @_;
20
21			my $ua = LWP::UserAgent->new;
22			$ua->timeout(10);
23			$ua->env_proxy;
24
25			$host \|\|= 'localhost';
26			$port \|\|= 5984;
27
28			return bless {
29			ua => $ua,
30			host => $host,
31			port => $port,
32			base_uri => "http://$host:$port/",
33			}, $class;
34			}
35
36			sub ua { shift->{ua} }
37			sub base { shift->{base_uri} }
38
39			sub request {
40			my ($self, $method, $uri, $content) = @_;
41
42			my $full_uri = $self->base . $uri;
43			my $req;
44
45			if (defined $content) {
46			#Content-Type: application/json
47
48			$req = HTTP::Request->new( $method, $full_uri, undef, $content );
49			$req->header('Content-Type' => 'application/json');
50			} else {
51			$req = HTTP::Request->new( $method, $full_uri );
52			}
53
54			my $response = $self->ua->request($req);
55
56			if ($response->is_success) {
57			return $response->content;
58			} else {
59			die($response->status_line . ":" . $response->content);
60			}
61			}
62
63			our $rev;
64
65	dpavlin	221	sub rev {
66			my ($self,$url) = @_;
67			my $rev = $rev->{$url};
68			$rev \|\|= eval { $self->get( $url )->{_rev} };
69			# warn "# rev $url $rev";
70			return $rev;
71			}
72
73	dpavlin	205	sub delete {
74			my ($self, $url) = @_;
75
76	dpavlin	221	$self->request(DELETE => $url . '?rev=' . $self->rev($url) );
77	dpavlin	205	}
78
79			sub get {
80			my ($self, $url) = @_;
81
82	dpavlin	206	JSON->new->utf8->decode( $self->request(GET => $url) );
83	dpavlin	205	}
84
85			sub put {
86			my ($self, $url, $json) = @_;
87
88	dpavlin	221	$json->{_rev} = $rev->{$url} if defined $rev->{$url};
89	dpavlin	205
90	dpavlin	210	my $data = dclone $json;
91			$data = unbless $data if blessed $data;
92	dpavlin	205
93	dpavlin	221	# warn "# put ",dump( $data );
94	dpavlin	205
95	dpavlin	210	$json = JSON->new->utf8->encode( $data );
96
97	dpavlin	221	carp "# put ",$json;
98	dpavlin	210
99			do {
100	dpavlin	221	my $json = eval { $self->request(PUT => $url, $json) };
101			if ( $@ ) {
102			$rev->{$url} = $self->rev( $url );
103			warn "refresh rev $url = ", $rev->{$url};
104			} else {
105			$rev->{$url} = JSON->new->decode( $json )->{rev};
106			}
107	dpavlin	210	} until ! $@;
108	dpavlin	205	}
109
110			sub post {
111			my ($self, $url, $json) = @_;
112
113			$self->request(POST => $url, $json);
114			}
115
116	dpavlin	206	our $audit = __PACKAGE__->new;
117
118			sub audit {
119			my $data = pop @_;
120
121			my $url = join(' ', @_);
122	dpavlin	209	$url =~ s/\s+-\S+//g; # remove command line options
123	dpavlin	206	$url =~ s/\W+/-/g;
124
125	dpavlin	256	my $time = $data->{time} = time();
126	dpavlin	206
127	dpavlin	256	my @caller_name = ( qw/package file line sub/ );
128			my @caller = caller(0);
129	dpavlin	258	$caller[3] = (caller(1))[3];
130	dpavlin	256	$caller[3] =~ s{^.+::}{}; # stip package name from sub
131			$data->{ $caller_name[$_] } = $caller[$_] foreach ( 0 .. $#caller_name );
132	dpavlin	207
133	dpavlin	258	if ( $ENV{DEBUG} ) {
134
135			my $caller;
136			my $depth = 0;
137			while ( my @c = caller($depth) ) {
138			push @$caller, [ @c ];
139			$depth++;
140			}
141
142			$data->{caller} = $caller;
143
144	dpavlin	256	}
145	dpavlin	206
146	dpavlin	221	# carp 'audit ', dump($data);
147	dpavlin	207
148	dpavlin	299	# $time = int($time); # reduce granularity for url
149			$time = strftime("%Y-%m-%d.%H:%M:%S", localtime $time);
150	dpavlin	256	my $package = $caller[0];
151	dpavlin	208	$audit->put( "pxelator/$time.$package.$url", $data );
152	dpavlin	210
153	dpavlin	206	}
154
155	dpavlin	205	1;