/[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 1060 by dpavlin, Fri Apr 24 17:41:45 2009 UTC revision 1116 by dpavlin, Mon Jun 29 18:50:27 2009 UTC
# Line 4  package Frey::CouchAPI; Line 4  package Frey::CouchAPI;
4    
5  This is REST wrapper using following L<Mojo> implement Apache's CouchDB API  This is REST wrapper using following L<Mojo> implement Apache's CouchDB API
6    
7    You can access it using normal C</_utils/> URI, just like on real CouchDB and
8    it will bring up partially functional Futon interface against this module.
9    
10  L<Mojo::URL>  L<Mojo::URL>
11    
# Line 20  use strict; Line 22  use strict;
22  use JSON;  use JSON;
23  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
24  use URI::Escape;  use URI::Escape;
25  use File::Path qw(make_path remove_tree);  use File::Path;
26  use Storable;  use Storable;
27    
28  our $VERSION = '0.2';  our $VERSION = '0.3';
29  $VERSION .= " (Frey $Frey::VERSION)" if $Frey::VERSION;  $VERSION .= " (Frey $Frey::VERSION)" if $Frey::VERSION;
30    
31  our $debug = $Frey::debug || 0;  our $debug = $Frey::debug || 0;
# Line 43  sub rewrite_urls { Line 45  sub rewrite_urls {
45  }  }
46    
47  our $config = {  our $config = {
48          path => '/data/webpac2/var/row',          database => {
49                    path => '/data/webpac2/var/row',
50                    name_glob => '/*/*',
51            }
52  };  };
53    
 my $p = $config->{path};  
 my @all_dbs = map {  
         s{^\Q$p\E/*}{};  
         $_;  
 } glob "$p/*/*";  
   
54  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
55    
56  our $json = {};  our $json = {};
# Line 81  sub dispatch { Line 80  sub dispatch {
80          my $url = $tx->req->url->to_string;          my $url = $tx->req->url->to_string;
81          $url = uri_unescape( $url );          $url = uri_unescape( $url );
82          my $method = $tx->req->method;          my $method = $tx->req->method;
83          my $path = $config->{path};          my $path = $config->{database}->{path};
84                    
85          if ( $url eq '/' ) {          if ( $url eq '/' ) {
86                  $json = {                  $json = {
# Line 90  sub dispatch { Line 89  sub dispatch {
89                  };                  };
90                  $status = 200;                  $status = 200;
91          } elsif ( $url eq '/_all_dbs' ) {          } elsif ( $url eq '/_all_dbs' ) {
92                  $json = [ @all_dbs ];                  $json = [
93                            map {
94                                    my $db = $_;
95                                    $db =~ s{^\Q$path\E/*}{};
96                                    $db;
97                            } glob $path . $config->{database}->{name_glob}
98                    ];
99                  $status = 200;                  $status = 200;
100          } elsif ( $url =~ m{^/_config/?(.+)} ) {          } elsif ( $url =~ m{^/_config/?(.+)} ) {
101    
102                  $json = { CouchAPI => $config };                  $json = $config;
103    
104                  if ( $method eq 'PUT' ) {                  if ( $method eq 'PUT' ) {
105    
106                          my $part = $1;                          my $part = $1;
107                          warn "## part $part";                          my $data = data_from_tx( $tx );
108                            warn "## part $part = $data\n";
109    
                         $part =~ s!^!->{'!;  
110                          $part =~ s!/!'}->{'!;                          $part =~ s!/!'}->{'!;
                         $part =~ s/$/'}/;  
111    
                         my $data = data_from_tx( $tx );  
112                          # poor man's transaction :-)                          # poor man's transaction :-)
113                          my $code = "\$json$part = \$data; \$config$part = \$data;";                          my $code = "\$config->{'$part'} = \$data;";
114                          eval $code;                          eval $code; ## no critic
115                          if ( $@ ) {                          if ( $@ ) {
116                                  warn "ERROR: $code -> $@";                                  warn "ERROR: $code -> $@";
117                                  $status = 500;                                  $status = 500;
# Line 116  sub dispatch { Line 119  sub dispatch {
119                                  $status = 200;                                  $status = 200;
120                          }                          }
121    
122  warn "json ",dump( $json ), " config ", dump( $config );                          warn "# config after $code is ",dump( $config ),$/;
123    
124                  } elsif ( $method eq 'GET' ) {                  } elsif ( $method eq 'GET' ) {
125                          $status = 200;                          $status = 200;
# Line 146  L<http://wiki.apache.org/couchdb/HTTP_da Line 149  L<http://wiki.apache.org/couchdb/HTTP_da
149                          if ( ! -e $dir ) {                          if ( ! -e $dir ) {
150                                  $status = 404;                                  $status = 404;
151                          } else {                          } else {
152                                  remove_tree($dir);                                  rmtree($dir);
153                                  if ( ! -d $dir ) {                                  if ( ! -d $dir ) {
154                                          ok;                                          ok;
155                                  } else {                                  } else {
# Line 157  L<http://wiki.apache.org/couchdb/HTTP_da Line 160  L<http://wiki.apache.org/couchdb/HTTP_da
160                          if ( -e $dir ) {                          if ( -e $dir ) {
161                                  $status = 412;                                  $status = 412;
162                          } else {                          } else {
163                                  make_path($dir);                                  mkpath($dir);
164                                  if ( -e $path ) {                                  if ( -e $path ) {
165                                          ok;                                          ok;
166                                          $status = 201;                                          $status = 201;
# Line 198  L<http://wiki.apache.org/couchdb/HTTP_Do Line 201  L<http://wiki.apache.org/couchdb/HTTP_Do
201                          my $by = $1;                          my $by = $1;
202                          my $offset = 0;                          my $offset = 0;
203                          my $startkey = delete $arg->{startkey};                          my $startkey = delete $arg->{startkey};
204                               $startkey ||= delete $arg->{startkey_docid}; # XXX key == id
205                          my $endkey   = delete $arg->{endkey};                          my $endkey   = delete $arg->{endkey};
206                          my $limit    = delete $arg->{limit};                          my $limit    = delete $arg->{limit};
207                          my $skip     = delete $arg->{skip};                          my $skip     = delete $arg->{skip};
208                          my $total_rows = 0;                          my $total_rows = 0;
209                            my $collected_rows = 0;
210    
211                          my @docs = grep { length $_ } map {                          my @docs = grep { length($_) > 0 } map {        ## no critic
212    
213                                  if ( $limit > 0 && $total_rows == $limit ) {                                  my $id = $_;
214                                    $total_rows++;
215            
216                                    if ( $limit > 0 && $collected_rows == $limit ) {
217                                          '';                                          '';
218                                  } else {                                  } else {
           
                                         s{^$path/$database/}{};  
219    
220                                          if ( defined $endkey && $_ gt $endkey ) {                                          $id = s{^$path/$database/}{};
221    
222                                            if ( defined $endkey && $id gt $endkey ) {
223                                                  '';                                                  '';
224                                          } elsif ( $startkey ) {                                          } elsif ( $startkey ) {
225                                                  if ( $_ ge $startkey ) {                                                  if ( $id ge $startkey ) {
226                                                          $total_rows++;                                                          $collected_rows++;
227                                                          $_;                                                          $id;
228                                                  } else {                                                  } else {
229                                                          $offset++;                                                          $offset++;
230                                                          '';                                                          '';
231                                                  }                                                  }
232                                          } else {                                          } else {
233                                                  $total_rows++;                                                  $collected_rows++;
234                                                  $_;                                                  $id;
235                                          }                                          }
236                                  }                                  }
237    
# Line 355  L<http://wiki.apache.org/couchdb/HTTP_Do Line 363  L<http://wiki.apache.org/couchdb/HTTP_Do
363    
364  sub database_get {  sub database_get {
365          my ($db_name) = @_;          my ($db_name) = @_;
366          my $path = $config->{path};          my $path = $config->{database}->{path} || die;
367          warn "# collecting docs from $path/$db_name/*\n";          warn "# collecting docs from $path/$db_name/*\n";
368          my @docs = glob "$path/$db_name/*";          my @docs = glob "$path/$db_name/*";
369          my $json = {          my $json = {
Legend:
Removed from v.1060  
changed lines
  Added in v.1116
  ViewVC Help
Powered by ViewVC 1.1.26