/[couchdb]/design/design-couch.pl
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 /design/design-couch.pl

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

revision 34 by dpavlin, Tue Apr 28 15:06:02 2009 UTC revision 35 by dpavlin, Tue Apr 28 20:52:52 2009 UTC
# Line 10  use File::Path qw/mkpath/; Line 10  use File::Path qw/mkpath/;
10  use File::Slurp qw//;  use File::Slurp qw//;
11  use File::Find;  use File::Find;
12  use HTTP::Request::Common;  use HTTP::Request::Common;
13    use MIME::Base64;
14    use Media::Type::Simple;
15    
16    
17  # design-couch.pl  # design-couch.pl
18  #  #
# Line 36  sub write_file { Line 39  sub write_file {
39          $path =~ s{^/+}{};          $path =~ s{^/+}{};
40          create_path $path;          create_path $path;
41          File::Slurp::write_file $path, $content;          File::Slurp::write_file $path, $content;
42          print "$path ", -s $path, " bytes\n";          print "$path ", -s $path, " bytes created\n";
43  }  }
44    
45  sub write_attachment {  sub write_attachment {
# Line 47  sub write_attachment { Line 50  sub write_attachment {
50          print "detached $file ", -s $file, " bytes\n";          print "detached $file ", -s $file, " bytes\n";
51  }  }
52    
53    
54  sub unroll {  sub unroll {
55          my ( $tree, $path ) = @_;          my ( $tree, $path ) = @_;
56    
# Line 92  if ( $command eq 'pull' ) { Line 96  if ( $command eq 'pull' ) {
96    
97          my $json;          my $json;
98    
         my @attached;  
   
99          find({ no_chdir => 1, wanted => sub {          find({ no_chdir => 1, wanted => sub {
100                  my $path = $File::Find::name;                  my $path = $File::Find::name;
101                  return unless -f $path;                  return unless -f $path;
# Line 102  warn "## $path\n"; Line 104  warn "## $path\n";
104    
105                  $path =~ s{^\./}{};                  $path =~ s{^\./}{};
106    
107                  if ( $path =~ m{_attachemnts} ) {                  if ( $path =~ m{_attachemnts/(.+)} ) {
108                          push @attached, $path;  
109                            my $filename = $1;
110                            my $content_type = 'text/plain';
111                            $content_type = type_from_ext($1) if $filename =~ m{\.(\w+)$};
112    
113                            my $data = File::Slurp::read_file( $path );
114                            $data = encode_base64( $data );
115                            # XXX inline attachments must be single line
116                            # XXX http://wiki.apache.org/couchdb/HTTP_Document_API
117                            $data =~ s/[\n\r]+//gs;
118                            $json->{_attachments}->{ $filename } = {
119                                    content_type => $content_type,
120                                    data         => $data,
121                            };
122                          return;                          return;
123                  }                  }
124    
# Line 116  warn "## $path\n"; Line 131  warn "## $path\n";
131  #               warn "## json = ",dump( $json );  #               warn "## json = ",dump( $json );
132          }}, '.' );          }}, '.' );
133    
134          warn "# $database/_design/$design = ",dump( $json );          if ( ! defined $json->{_id} ) {
135          write_file "../$database-$design.push.js", to_json $json;                  warn "creating _id for document\n";
136                    $json->{_id} = $$ . '-' . time();
137            }
138            delete( $json->{_rev} ) && warn "removing _rev from document\n";
139    
140          die "no _id?" unless $json->{_id};          print "push $database/_design/$design\n";
141          delete( $json->{_rev} );          write_file "../$database-$design.push.js", to_json $json;
142    
143          warn "# put $url\n";          warn "# put $url\n";
144          my $response = $ua->request( HTTP::Request::Common::PUT($url, 'Content-Type' => 'application/json', Content => to_json $json ) );          my $response = $ua->request(
145                    HTTP::Request::Common::PUT(
146                            $url,
147                            'Content-Type' => 'application/json',
148                            Content => to_json $json,
149                    )
150            );
151    
152          if ( $response->code == 409 ) {          if ( $response->code == 409 ) {
153                  warn "## get old $url\n";                  warn "## update $url\n";
154                  my $response = $ua->get( $url );                  my $response = $ua->get( $url );
155                  die $response->status_line if $response->is_error;                  die $response->status_line if $response->is_error;
156    
157                  my $data = from_json $response;                  my $data = from_json $response->decoded_content;
158                  $json->{$_} = $data->{$_} foreach ( 'rev', '_id' );                  $json->{$_} = $data->{$_} foreach ( '_rev', '_id' );
159    
160                  $response = $ua->request( HTTP::Request::Common::PUT($url, 'Content-Type' => 'application/json', Content => to_json $json ) );                  $response = $ua->request( HTTP::Request::Common::PUT($url, 'Content-Type' => 'application/json', Content => to_json $json ) );
161                  die $response->status_line if $response->is_error;                  die $response->status_line if $response->is_error;
# Line 141  warn "## $path\n"; Line 165  warn "## $path\n";
165                  warn "push new $url\n";                  warn "push new $url\n";
166          }          }
167    
         warn "FIXME: ignore attachments: ",dump( @attached );  
   
168  } else {  } else {
169          die "$0: unknown command $command";          die "$0: unknown command $command";
170  }  }
Legend:
Removed from v.34  
changed lines
  Added in v.35
  ViewVC Help
Powered by ViewVC 1.1.26