/[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 1190 by dpavlin, Sun Jul 5 21:40:16 2009 UTC revision 1191 by dpavlin, Mon Sep 28 20:25:07 2009 UTC
# Line 47  sub rewrite_urls { Line 47  sub rewrite_urls {
47  our $config = {  our $config = {
48          database => {          database => {
49                  path => '/data/webpac2/var/row',                  path => '/data/webpac2/var/row',
50                  name_glob => '/*/*',                  database_glob => '*/*',
51                    data_glob => '*',
52          }          }
53  };  };
54    
55  my $regex_dbs = '[a-z][a-z0-9_\$\(\)\+\-/]+';  $config = {
56            data => {
57                    base_path => '/home/dpavlin/x/Frey/var/svn/home/dpavlin/private/svn',
58                    database => '*',
59                    files => '*.storable',
60            },
61    };
62    
63    sub _glob_databases {
64            my $path = $config->{data}->{base_path};
65            map {
66                    my $p = $_;
67                    $p =~ s{^$path/+}{};
68                    $p;
69            } glob "$path/$config->{data}->{database}"
70    }
71    
72    sub _glob_files {
73            my $path = $config->{data}->{base_path} . '/' . shift;
74            map {
75                    my $p = $_;
76                    $p =~ s{^$path/+}{};
77                    $p;
78            } glob "$path/$config->{data}->{files}"
79    };
80    
81    my $regex_dbs = '[a-zA-Z][a-zA-Z0-9_\$\(\)\+\-/]+';
82    
83  our $json = {};  our $json = {};
84  our $status;  our $status;
# Line 80  sub dispatch { Line 107  sub dispatch {
107          my $url = $tx->req->url->to_string;          my $url = $tx->req->url->to_string;
108          $url = uri_unescape( $url );          $url = uri_unescape( $url );
109          my $method = $tx->req->method;          my $method = $tx->req->method;
110          my $path = $config->{database}->{path};          my $path = $config->{data}->{base_path};
111            
112            die "base_path $path doesn't exist" unless -e $path;
113    
114          if ( $url eq '/' ) {          if ( $url eq '/' ) {
115                  $json = {                  $json = {
116                          couchdb => "Welcome",                          couchdb => "Welcome",
# Line 94  sub dispatch { Line 123  sub dispatch {
123                                  my $db = $_;                                  my $db = $_;
124                                  $db =~ s{^\Q$path\E/*}{};                                  $db =~ s{^\Q$path\E/*}{};
125                                  $db;                                  $db;
126                          } glob $path . $config->{database}->{name_glob}                          } _glob_databases
127                  ];                  ];
128                  $status = 200;                  $status = 200;
129          } elsif ( $url =~ m{^/_config/?(.+)} ) {          } elsif ( $url =~ m{^/_config/?(.+)} ) {
# Line 217  L<http://wiki.apache.org/couchdb/HTTP_Do Line 246  L<http://wiki.apache.org/couchdb/HTTP_Do
246                                          '';                                          '';
247                                  } else {                                  } else {
248    
                                         $id = s{^$path/$database/}{};  
   
249                                          if ( defined $endkey && $id gt $endkey ) {                                          if ( defined $endkey && $id gt $endkey ) {
250                                                  '';                                                  '';
251                                          } elsif ( $startkey ) {                                          } elsif ( $startkey ) {
# Line 235  L<http://wiki.apache.org/couchdb/HTTP_Do Line 262  L<http://wiki.apache.org/couchdb/HTTP_Do
262                                          }                                          }
263                                  }                                  }
264    
265                          } glob( "$path/$database/*" );                          } _glob_files( $database );
266    
267                          $offset += $skip if $skip;                          $offset += $skip if $skip;
268    
# Line 343  L<http://wiki.apache.org/couchdb/HTTP_Do Line 370  L<http://wiki.apache.org/couchdb/HTTP_Do
370          $json = { error => 'not_found', reason => 'Missing' } if $status == 404;          $json = { error => 'not_found', reason => 'Missing' } if $status == 404;
371    
372          if ( $method =~ m{(DELETE|PUT)} ) {          if ( $method =~ m{(DELETE|PUT)} ) {
373                  $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs );  #               $tx->res->headers->add_line( 'Location' => $tx->req->url->to_abs );
374          }          }
375    
376          $tx->res->code( $status );          $tx->res->code( $status );
377          $tx->res->headers->content_type( 'text/plain;charset=utf-8' );          $tx->res->headers->content_type( 'text/plain;charset=utf-8' );
378          my $body = to_json $json;          my $body = to_json $json;
379          $tx->res->body( $body );          $tx->res->body( $body );
380          $tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' );  #       $tx->res->headers->add_line( 'Cache-Control' => 'must-revalidate' );
381          $tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" );  #       $tx->res->headers->add_line( 'Server' => "Frey::CouchAPI/$VERSION" );
382    
383          print "$method $url $status\n$body\n";          print "$method $url $status\n$body\n";
384    
# Line 363  L<http://wiki.apache.org/couchdb/HTTP_Do Line 390  L<http://wiki.apache.org/couchdb/HTTP_Do
390    
391  sub database_get {  sub database_get {
392          my ($db_name) = @_;          my ($db_name) = @_;
393          my $path = $config->{database}->{path} || die;          warn "# collecting docs for $db_name\n";
394          warn "# collecting docs from $path/$db_name/*\n";          my @docs = _glob_files( $db_name );
395          my @docs = glob "$path/$db_name/*";          warn dump @docs;
396          my $json = {          my $json = {
397                  db_name => $db_name,                  db_name => $db_name,
398                  doc_count => $#docs + 1,                  doc_count => $#docs + 1,
Legend:
Removed from v.1190  
changed lines
  Added in v.1191
  ViewVC Help
Powered by ViewVC 1.1.26