/[pxelator]/couchdb/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

Annotation of /couchdb/design-couch.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 374 - (hide annotations)
Sun Aug 30 13:33:09 2009 UTC (14 years, 7 months ago) by dpavlin
File MIME type: text/plain
File size: 5262 byte(s)
rewrite design couch to support push/pull of all _design documents by itself
1 dpavlin 248 #!/usr/bin/perl
2    
3     use warnings;
4     use strict;
5    
6     use LWP::UserAgent;
7     use JSON;
8     use Data::Dump qw/dump/;
9     use File::Path qw/mkpath/;
10     use File::Slurp qw//;
11     use File::Find;
12     use HTTP::Request::Common;
13     use MIME::Base64;
14 dpavlin 374 use autodie;
15 dpavlin 248
16     use lib qw(lib ../lib);
17     use Media::Type::Simple;
18    
19    
20     # design-couch.pl
21     #
22     # 04/26/09 21:12:28 CEST Dobrica Pavlinusic <dpavlin@rot13.org>
23    
24 dpavlin 374 our $couchdb = $ENV{COUCHDB} || 'http://localhost:5984/';
25 dpavlin 248
26 dpavlin 374 our ( $command, $database, $design ) = @ARGV;
27 dpavlin 341
28 dpavlin 374 die "usage: $0 [push|pull] database [design]\n" unless $database;
29 dpavlin 248
30 dpavlin 374
31 dpavlin 248 my $ua = LWP::UserAgent->new;
32    
33     sub create_path {
34     my $path = shift;
35     if ( $path =~ m{/} ) {
36     my $dir = $path;
37     $dir =~ s{/[^/]+$}{};
38     mkpath $dir if ! -e $dir;
39     #warn "# dir $dir";
40     }
41     }
42 dpavlin 367
43     sub svn {
44     my $path = shift;
45 dpavlin 371 return if $path =~ m{(_.*|.*\.(push|pull)\.js)$};
46 dpavlin 367 system "svn add --parents $path";
47     }
48    
49 dpavlin 248 sub write_file {
50     my ( $path, $content ) = @_;
51     $path =~ s{^/+}{};
52     create_path $path;
53     File::Slurp::write_file $path, $content;
54     print "$path ", -s $path, " bytes created\n";
55 dpavlin 367 svn $path;
56 dpavlin 248 }
57    
58     sub write_attachment {
59     my ( $path ) = @_;
60     my $file = "_attachemnts/$path";
61     create_path $file;
62 dpavlin 374 $ua->mirror( "$couchdb/$database/_design/$design/$path", $file );
63 dpavlin 248 print "detached $file ", -s $file, " bytes\n";
64 dpavlin 367 svn $file;
65 dpavlin 248 }
66    
67    
68     sub unroll {
69     my ( $tree, $path ) = @_;
70    
71     my $ref = ref $tree;
72     if ( $ref eq 'HASH' ) {
73     foreach my $child ( keys %$tree ) {
74     if ( $child eq '_attachments' ) {
75     write_attachment $_ foreach keys %{ $tree->{$child} };
76     } else {
77     unroll( $tree->{$child}, $path ? "$path/$child" : $child );
78     }
79     }
80     } elsif ( $ref ) {
81     warn "UNSUPPORTED $path $ref ", dump( $tree );
82     write_file "$path.json", to_json $tree;
83     } elsif ( $ref eq '' ) {
84    
85     if ( $tree =~ m[^\s*(function(.*){.*}|/\*|//|var)]is ) {
86     $path .= '.js';
87     } elsif ( $tree =~ m{<%=.*%>} ) { # couchapp template
88     $path .= '.html';
89     } else {
90     warn "# can't detect type of $path\n";
91     }
92    
93     write_file $path, $tree;
94     }
95    
96     }
97    
98 dpavlin 374 sub pull_design {
99     $design = shift;
100 dpavlin 248
101 dpavlin 374 my $url = "$couchdb/$database/_design/$design";
102    
103 dpavlin 248 warn "# get $url\n";
104     my $response = $ua->get( $url );
105     die $response->status_line if $response->is_error;
106    
107     my $json = $response->decoded_content;
108     write_file "../$database-$design.pull.js", $json;
109    
110     unroll( from_json $json, '' );
111    
112 dpavlin 374 }
113 dpavlin 248
114 dpavlin 374 sub push_database_design {
115     $design = shift;
116    
117 dpavlin 371 $ua->request( HTTP::Request::Common::PUT( "http://localhost:5984/$database" ) ) && warn "# created database $database\n";
118    
119 dpavlin 248 my $json;
120    
121     find({ no_chdir => 1, wanted => sub {
122     my $path = $File::Find::name;
123     return unless -f $path;
124 dpavlin 252 return if $path =~ m{/\.svn};
125 dpavlin 248
126     warn "## $path\n";
127    
128     $path =~ s{^\./}{};
129    
130     if ( $path =~ m{_attachemnts/(.+)} ) {
131    
132     my $filename = $1;
133     my $content_type = 'text/plain';
134     $content_type = type_from_ext($1) if $filename =~ m{\.(\w+)$};
135    
136     my $data = File::Slurp::read_file( $path );
137     $data = encode_base64( $data );
138     # XXX inline attachments must be single line
139     # XXX http://wiki.apache.org/couchdb/HTTP_Document_API
140     $data =~ s/[\n\r]+//gs;
141     $json->{_attachments}->{ $filename } = {
142     content_type => $content_type,
143     data => $data,
144     };
145     return;
146     }
147    
148     my $data = File::Slurp::read_file( $path );
149     $path =~ s[/]['}->{']g;
150     $path =~ s{\.\w+$}{};
151     my $code = "\$json->{'$path'} = \$data;";
152     eval $code;
153     die "ERROR in $code: $@" if $@;
154     # warn "## json = ",dump( $json );
155     }}, '.' );
156    
157     if ( ! defined $json->{_id} ) {
158     warn "creating _id for document\n";
159     $json->{_id} = $$ . '-' . time();
160     }
161     delete( $json->{_rev} ) && warn "removing _rev from document\n";
162    
163     print "push $database/_design/$design\n";
164     write_file "../$database-$design.push.js", to_json $json;
165    
166 dpavlin 374 my $url = "$couchdb/$database/_design/$design";
167 dpavlin 248 warn "# put $url\n";
168     my $response = $ua->request(
169     HTTP::Request::Common::PUT(
170     $url,
171     'Content-Type' => 'application/json',
172     Content => to_json $json,
173     )
174     );
175    
176     if ( $response->code == 409 ) {
177     warn "## update $url\n";
178     my $response = $ua->get( $url );
179     die $response->status_line if $response->is_error;
180    
181     my $data = from_json $response->decoded_content;
182     $json->{$_} = $data->{$_} foreach ( '_rev', '_id' );
183    
184     $response = $ua->request( HTTP::Request::Common::PUT($url, 'Content-Type' => 'application/json', Content => to_json $json ) );
185     die $response->status_line if $response->is_error;
186     warn "push updated $url\n";
187     } else {
188     die $response->status_line if $response->is_error;
189     warn "push new $url\n";
190     }
191 dpavlin 374 }
192 dpavlin 248
193 dpavlin 374
194     # XXX main
195    
196    
197     if ( $command eq 'push' ) {
198    
199     my @designs = map { (split(m{/},2))[0] } @{ glob '*/views' };
200     @designs = ( $design ) if $design;
201    
202     warn "XX ",dump( @designs );
203    
204     foreach my $design ( @designs ) {
205    
206     chdir $design;
207     push_design( $design );
208     chdir '..';
209    
210     }
211    
212     } elsif ( $command eq 'pull' ) {
213    
214     my $designs = from_json $ua->get( "$couchdb/$database/_all_docs?startkey=%22_design%2F%22&endkey=%22_design0%22" )->decoded_content;
215     my @designs =
216     map {
217     my $name = $_->{id};
218     $name =~ s{^_design/}{};
219     $name;
220     } @{ $designs->{rows} }
221     ;
222    
223     warn "# $database/_design ",dump( @designs );
224    
225     @designs = ( $design ) if $design;
226    
227     foreach my $design ( @designs ) {
228    
229     mkdir $design unless -e $design;
230     chdir $design;
231     pull_design( $design );
232     chdir '..';
233    
234     }
235    
236 dpavlin 248 } else {
237     die "$0: unknown command $command";
238     }
239    

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26