/[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 1059 by dpavlin, Fri Apr 24 15:32:04 2009 UTC revision 1061 by dpavlin, Fri Apr 24 21:51:03 2009 UTC
# Line 23  use URI::Escape; Line 23  use URI::Escape;
23  use File::Path qw(make_path remove_tree);  use File::Path qw(make_path remove_tree);
24  use Storable;  use Storable;
25    
26  our $VERSION = '0.2';  our $VERSION = '0.3';
27  $VERSION .= " (Frey $Frey::VERSION)" if $Frey::VERSION;  $VERSION .= " (Frey $Frey::VERSION)" if $Frey::VERSION;
28    
29  our $debug = $Frey::debug || 0;  our $debug = $Frey::debug || 0;
# Line 43  sub rewrite_urls { Line 43  sub rewrite_urls {
43  }  }
44    
45  our $config = {  our $config = {
46          path => '/data/webpac2/var/row',          database => {
47                    path => '/data/webpac2/var/row',
48                    name_glob => '/*/*',
49            }
50  };  };
51    
 my $p = $config->{path};  
 my @all_dbs = map {  
         s{^\Q$p\E/*}{};  
         $_;  
 } glob "$p/*/*";  
   
52  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';
53    
54  our $json = {};  our $json = {};
# Line 65  sub ok { Line 62  sub ok {
62    
63  sub file_rev { (stat($_[0]))[9] } # mtime  sub file_rev { (stat($_[0]))[9] } # mtime
64    
65    sub data_from_tx {
66            my $tx = shift;
67            my $data = $tx->req->content->file->slurp;
68            $data = JSON->new->allow_nonref->decode( $data );
69            warn "## data ",dump( $data );
70            return $data;
71    }
72    
73  sub dispatch {  sub dispatch {
74          my ($self,$tx) = @_;          my ($self,$tx) = @_;
75    
# Line 73  sub dispatch { Line 78  sub dispatch {
78          my $url = $tx->req->url->to_string;          my $url = $tx->req->url->to_string;
79          $url = uri_unescape( $url );          $url = uri_unescape( $url );
80          my $method = $tx->req->method;          my $method = $tx->req->method;
81          my $path = $config->{path};          my $path = $config->{database}->{path};
82                    
83          if ( $url eq '/' ) {          if ( $url eq '/' ) {
84                  $json = {                  $json = {
# Line 82  sub dispatch { Line 87  sub dispatch {
87                  };                  };
88                  $status = 200;                  $status = 200;
89          } elsif ( $url eq '/_all_dbs' ) {          } elsif ( $url eq '/_all_dbs' ) {
90                  $json = [ @all_dbs ];                  $json = [
91                            map {
92                                    s{^\Q$path\E/*}{};
93                                    $_;
94                            } glob $path . $config->{database}->{name_glob}
95                    ];
96                  $status = 200;                  $status = 200;
97          } elsif ( $url =~ m{^/_config/?(.+)} ) {          } elsif ( $url =~ m{^/_config/?(.+)} ) {
98    
99                  $json = { CouchAPI => $config };                  $json = $config;
100    
101                  if ( $method eq 'PUT' ) {                  if ( $method eq 'PUT' ) {
102    
103                          my $part = $1;                          my $part = $1;
104                          warn "## part $part";                          my $data = data_from_tx( $tx );
105                            warn "## part $part = $data\n";
106    
                         $part =~ s!^!->{'!;  
107                          $part =~ s!/!'}->{'!;                          $part =~ s!/!'}->{'!;
                         $part =~ s/$/'}/;  
108    
                         my $data = $tx->req->content->file->slurp;  
                         $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 = "\$config->{'$part'} = \$data;";
111                          eval $code;                          eval $code;
112                          if ( $@ ) {                          if ( $@ ) {
113                                  warn "ERROR: $code -> $@";                                  warn "ERROR: $code -> $@";
# Line 110  sub dispatch { Line 116  sub dispatch {
116                                  $status = 200;                                  $status = 200;
117                          }                          }
118    
119  warn "json ",dump( $json ), " config ", dump( $config );                          warn "# config after $code is ",dump( $config ),$/;
120    
121                  } elsif ( $method eq 'GET' ) {                  } elsif ( $method eq 'GET' ) {
122                          $status = 200;                          $status = 200;
# Line 194  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 222  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 307  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                  }                  }
# Line 343  L<http://wiki.apache.org/couchdb/HTTP_Do Line 355  L<http://wiki.apache.org/couchdb/HTTP_Do
355    
356  sub database_get {  sub database_get {
357          my ($db_name) = @_;          my ($db_name) = @_;
358          my $path = $config->{path};          my $path = $config->{database}->{path} || die;
359          warn "# collecting docs from $path/$db_name/*\n";          warn "# collecting docs from $path/$db_name/*\n";
360          my @docs = glob "$path/$db_name/*";          my @docs = glob "$path/$db_name/*";
361          my $json = {          my $json = {
Legend:
Removed from v.1059  
changed lines
  Added in v.1061
  ViewVC Help
Powered by ViewVC 1.1.26