/[Frey]/branches/zimbardo/lib/Frey/CouchAPI.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 /branches/zimbardo/lib/Frey/CouchAPI.pm

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

revision 1057 by dpavlin, Thu Apr 23 22:18:46 2009 UTC revision 1060 by dpavlin, Fri Apr 24 17:41:45 2009 UTC
# Line 65  sub ok { Line 65  sub ok {
65    
66  sub file_rev { (stat($_[0]))[9] } # mtime  sub file_rev { (stat($_[0]))[9] } # mtime
67    
68    sub data_from_tx {
69            my $tx = shift;
70            my $data = $tx->req->content->file->slurp;
71            $data = JSON->new->allow_nonref->decode( $data );
72            warn "## data ",dump( $data );
73            return $data;
74    }
75    
76  sub dispatch {  sub dispatch {
77          my ($self,$tx) = @_;          my ($self,$tx) = @_;
78    
# Line 97  sub dispatch { Line 105  sub dispatch {
105                          $part =~ s!/!'}->{'!;                          $part =~ s!/!'}->{'!;
106                          $part =~ s/$/'}/;                          $part =~ s/$/'}/;
107    
108                          my $data = $tx->req->content->file->slurp;                          my $data = data_from_tx( $tx );
                         $data = JSON->new->allow_nonref->decode( $data );  
                         warn "## data ",dump( $data );  
109                          # poor man's transaction :-)                          # poor man's transaction :-)
110                          my $code = "\$json$part = \$data; \$config$part = \$data;";                          my $code = "\$json$part = \$data; \$config$part = \$data;";
111                          eval $code;                          eval $code;
# Line 118  warn "json ",dump( $json ), " config ", Line 124  warn "json ",dump( $json ), " config ",
124                          $status = 501;                          $status = 501;
125                  }                  }
126    
         } elsif ( $url =~ m{($regex_dbs)/$} ) {  
   
127  =head2 Database  =head2 Database
128    
129  L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction  L<http://wiki.apache.org/couchdb/HTTP_database_API> except compaction
130    
131  =cut  =cut
132    
133            } elsif (
134                       $url =~ m{($regex_dbs)/$}
135                    # DELETE doesn't have trailing slash
136                    || $method eq 'DELETE' && $url =~ m{($regex_dbs)$}
137            ) {
138    
139                  my $database = $1;                  my $database = $1;
140    
141                  my $dir = "$path/$database";                  my $dir = "$path/$database";
# Line 157  L<http://wiki.apache.org/couchdb/HTTP_da Line 167  L<http://wiki.apache.org/couchdb/HTTP_da
167                          }                          }
168                  }                  }
169    
170                    warn "## database $database $status ",dump( $json );
171    
172          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {          } elsif ( $url =~ m{($regex_dbs)/([^?]+)\??(.+)?$} ) {
173                  my ($database,$id,$args) = ($1,$2,$3);                  my ($database,$id,$args) = ($1,$2,$3);
174    
# Line 188  L<http://wiki.apache.org/couchdb/HTTP_Do Line 200  L<http://wiki.apache.org/couchdb/HTTP_Do
200                          my $startkey = delete $arg->{startkey};                          my $startkey = delete $arg->{startkey};
201                          my $endkey   = delete $arg->{endkey};                          my $endkey   = delete $arg->{endkey};
202                          my $limit    = delete $arg->{limit};                          my $limit    = delete $arg->{limit};
203                            my $skip     = delete $arg->{skip};
204                          my $total_rows = 0;                          my $total_rows = 0;
205    
206                          my @docs = grep { length $_ } map {                          my @docs = grep { length $_ } map {
# Line 216  L<http://wiki.apache.org/couchdb/HTTP_Do Line 229  L<http://wiki.apache.org/couchdb/HTTP_Do
229    
230                          } glob( "$path/$database/*" );                          } glob( "$path/$database/*" );
231    
232                            $offset += $skip if $skip;
233    
234                          warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;                          warn "## docs $startkey -> $endkey limit $limit ", dump( @docs ); # if $debug;
235    
# Line 260  L<http://wiki.apache.org/couchdb/HTTP_Do Line 274  L<http://wiki.apache.org/couchdb/HTTP_Do
274    
275                  } elsif ( $method eq 'PUT' ) {                  } elsif ( $method eq 'PUT' ) {
276                    
277                          warn "## ",dump( $tx->req ); # if $debug;                          warn "## ",dump( $tx->req ) if $debug;
278    
279                          my $data = $tx->req->content->file->slurp;                          my $data = $tx->req->content->file->slurp;
280    
281                            my $db_path = "$path/$database";
282                            make_path $db_path unless -e $db_path;
283    
284                          Storable::store( from_json($data), $p );                          Storable::store( from_json($data), $p );
285                          my $rev = file_rev $p;                          my $rev = file_rev $p;
286                          warn "store $p $rev size ", -s $p, " bytes | $data\n";                          warn "store $p $rev size ", -s $p, " bytes | $data\n";
# Line 298  L<http://wiki.apache.org/couchdb/HTTP_Do Line 315  L<http://wiki.apache.org/couchdb/HTTP_Do
315                                  $status = 404;                                  $status = 404;
316                          }                          }
317                  } elsif ( $method eq 'POST' ) {                  } elsif ( $method eq 'POST' ) {
318                            my $data = data_from_tx( $tx );
319    
320                            # FIXME implement real view server and return 200
321                          $json = { total_rows => 0, offset => 0 };                          $json = { total_rows => 0, offset => 0 };
322                          $status = 202; # FIXME implement real view server and return 200                          $status = 202;
323    
324                  } else {                  } else {
325                          $status = 501;                          $status = 501;
326                  }                  }
327    
328                  warn "WARNING: arg left from $url = ",dump( $arg ),$/ if keys %$arg;                  if ( keys %$arg ) {
329                            warn "WARNING: arg left from $url = ",dump( $arg ),$/;
330                            $status = 501;
331                    }
332    
333          }          }
334    
Legend:
Removed from v.1057  
changed lines
  Added in v.1060
  ViewVC Help
Powered by ViewVC 1.1.26