/[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 256 - (show annotations)
Tue Aug 18 21:30:55 2009 UTC (14 years, 6 months ago) by dpavlin
File size: 2838 byte(s)
extract real coller and whole call stack

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

  ViewVC Help
Powered by ViewVC 1.1.26