/[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

Contents of /couchdb/design-couch.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 374 - (show annotations)
Sun Aug 30 13:33:09 2009 UTC (9 years, 10 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 #!/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 use autodie;
15
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 our $couchdb = $ENV{COUCHDB} || 'http://localhost:5984/';
25
26 our ( $command, $database, $design ) = @ARGV;
27
28 die "usage: $0 [push|pull] database [design]\n" unless $database;
29
30
31 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
43 sub svn {
44 my $path = shift;
45 return if $path =~ m{(_.*|.*\.(push|pull)\.js)$};
46 system "svn add --parents $path";
47 }
48
49 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 svn $path;
56 }
57
58 sub write_attachment {
59 my ( $path ) = @_;
60 my $file = "_attachemnts/$path";
61 create_path $file;
62 $ua->mirror( "$couchdb/$database/_design/$design/$path", $file );
63 print "detached $file ", -s $file, " bytes\n";
64 svn $file;
65 }
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 sub pull_design {
99 $design = shift;
100
101 my $url = "$couchdb/$database/_design/$design";
102
103 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 }
113
114 sub push_database_design {
115 $design = shift;
116
117 $ua->request( HTTP::Request::Common::PUT( "http://localhost:5984/$database" ) ) && warn "# created database $database\n";
118
119 my $json;
120
121 find({ no_chdir => 1, wanted => sub {
122 my $path = $File::Find::name;
123 return unless -f $path;
124 return if $path =~ m{/\.svn};
125
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 my $url = "$couchdb/$database/_design/$design";
167 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 }
192
193
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 } else {
237 die "$0: unknown command $command";
238 }
239

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26