/[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

Diff of /lib/PXElator/CouchDB.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 207 by dpavlin, Wed Aug 12 22:56:45 2009 UTC revision 482 by dpavlin, Sat Jan 23 18:31:14 2010 UTC
# Line 12  use Time::HiRes qw/time/; Line 12  use Time::HiRes qw/time/;
12  use Data::Structure::Util qw(unbless);  use Data::Structure::Util qw(unbless);
13  use Scalar::Util qw/blessed/;  use Scalar::Util qw/blessed/;
14  use Storable qw/dclone/;  use Storable qw/dclone/;
15    use Carp qw/carp/;
16    use POSIX;
17    
18  sub new {  sub new {
19          my ($class, $host, $port, $options) = @_;          my ($class, $host, $port, $options) = @_;
# Line 60  sub request { Line 62  sub request {
62    
63  our $rev;  our $rev;
64    
65    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  sub delete {  sub delete {
74          my ($self, $url) = @_;          my ($self, $url) = @_;
75    
76          $self->request(DELETE => $url);          $self->request(DELETE => $url . '?rev=' . $self->rev($url) );
77  }  }
78    
79  sub get {  sub get {
# Line 75  sub get { Line 85  sub get {
85  sub put {  sub put {
86          my ($self, $url, $json) = @_;          my ($self, $url, $json) = @_;
87    
88          if ( ! defined $json->{_rev} ) {          $json->{_rev} = $rev->{$url} if defined $rev->{$url};
                 my $old = eval { $self->get( $url )->{_rev} };  
                 $rev->{$url} = $json->{_rev} = $old if defined $old;  
         }  
89    
90          $json = unbless dclone $json if blessed $json;          my $data = dclone $json;
91            $data = unbless $data if blessed $data;
92    
93          $json = JSON->new->utf8->encode( $json ) if $json;  #       warn "# put ",dump( $data );
94    
95          $self->request(PUT => $url, $json);          $json = JSON->new->utf8->encode( $data );
96    
97            carp "# put ",$json;
98    
99            do {
100                    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            } until ! $@;
108  }  }
109    
110  sub post {  sub post {
# Line 99  sub audit { Line 119  sub audit {
119          my $data = pop @_;          my $data = pop @_;
120    
121          my $url = join(' ', @_);          my $url = join(' ', @_);
122          $url =~ s/-\S+//g;          $url =~ s/\s+-\S+//g;   # remove command line options
123          $url =~ s/\W+/-/g;          $url =~ s/\W+/-/g;
124    
125          my ( $package, $file, $line, $sub ) = caller(1);          my $time = time();
         ( $package, undef, $line ) = caller(0) if $package eq 'main';  
   
         my $t = time();  
126    
127          $data->{x_meta} = {          my @caller = caller(1); # skip store wrapper
128                  'time' => $t,          $caller[3] = (caller(1))[3];
129                  'package' => $package,          $caller[3] =~ s{^.+::}{}; # stip package name from sub
130                  'line' => $line,          $data->{package} = {
131                  'sub' => $sub,                  time => $time,
132                    name => $caller[0],
133                    line => $caller[2],
134                    caller  => $caller[3],
135          };          };
         $data->{'ident'} = [ @_ ] if @_;  
136    
137          warn 'audit ', dump($data), "at $file +$line\n";          if ( $ENV{DEBUG} ) {
138    
139                    my $caller;
140                    my $depth = 0;
141                    while ( my @c = caller($depth) ) {
142                            push @$caller, [ @c ];
143                            $depth++;
144                    }
145    
146                    $data->{caller} = $caller;
147    
148            }
149    
150    #       carp 'audit ', dump($data);
151    
152    #       $time = int($time); # reduce granularity for url
153            $time = strftime("%Y-%m-%d.%H:%M:%S", localtime $time);
154            my $package = $caller[0];
155            $audit->put( "pxelator/$time.$package.$url", $data );
156    
         $audit->put( "pxelator/$t.$package.$url", $data );  
157  }  }
158    
159  1;  1;
Legend:
Removed from v.207  
changed lines
  Added in v.482
  ViewVC Help
Powered by ViewVC 1.1.26