/[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 371 - (show annotations)
Sun Aug 30 12:07:15 2009 UTC (10 years, 10 months ago) by dpavlin
File MIME type: text/plain
File size: 4481 byte(s)
never add _id, _rev and rest of _private variables to svn, create database if needed
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
15 use lib qw(lib ../lib);
16 use Media::Type::Simple;
17
18
19 # design-couch.pl
20 #
21 # 04/26/09 21:12:28 CEST Dobrica Pavlinusic <dpavlin@rot13.org>
22
23 my ( $command, $database, $design ) = @ARGV;
24 die "usage: $0 [push|pull] database design\n" unless $database && $design;
25
26 if ( ! -e $design && $command eq 'pull') {
27 warn "# create new design $design\n";
28 mkdir $design;
29 }
30
31 chdir $design || die "can't find $design: $!";
32
33 my $ua = LWP::UserAgent->new;
34
35 my $url = "http://localhost:5984/$database/_design/$design";
36
37 sub create_path {
38 my $path = shift;
39 if ( $path =~ m{/} ) {
40 my $dir = $path;
41 $dir =~ s{/[^/]+$}{};
42 mkpath $dir if ! -e $dir;
43 #warn "# dir $dir";
44 }
45 }
46
47 sub svn {
48 my $path = shift;
49 return if $path =~ m{(_.*|.*\.(push|pull)\.js)$};
50 system "svn add --parents $path";
51 }
52
53 sub write_file {
54 my ( $path, $content ) = @_;
55 $path =~ s{^/+}{};
56 create_path $path;
57 File::Slurp::write_file $path, $content;
58 print "$path ", -s $path, " bytes created\n";
59 svn $path;
60 }
61
62 sub write_attachment {
63 my ( $path ) = @_;
64 my $file = "_attachemnts/$path";
65 create_path $file;
66 $ua->mirror( "$url/$path", $file );
67 print "detached $file ", -s $file, " bytes\n";
68 svn $file;
69 }
70
71
72 sub unroll {
73 my ( $tree, $path ) = @_;
74
75 my $ref = ref $tree;
76 if ( $ref eq 'HASH' ) {
77 foreach my $child ( keys %$tree ) {
78 if ( $child eq '_attachments' ) {
79 write_attachment $_ foreach keys %{ $tree->{$child} };
80 } else {
81 unroll( $tree->{$child}, $path ? "$path/$child" : $child );
82 }
83 }
84 } elsif ( $ref ) {
85 warn "UNSUPPORTED $path $ref ", dump( $tree );
86 write_file "$path.json", to_json $tree;
87 } elsif ( $ref eq '' ) {
88
89 if ( $tree =~ m[^\s*(function(.*){.*}|/\*|//|var)]is ) {
90 $path .= '.js';
91 } elsif ( $tree =~ m{<%=.*%>} ) { # couchapp template
92 $path .= '.html';
93 } else {
94 warn "# can't detect type of $path\n";
95 }
96
97 write_file $path, $tree;
98 }
99
100 }
101
102 if ( $command eq 'pull' ) {
103
104 warn "# get $url\n";
105 my $response = $ua->get( $url );
106 die $response->status_line if $response->is_error;
107
108 my $json = $response->decoded_content;
109 write_file "../$database-$design.pull.js", $json;
110
111 unroll( from_json $json, '' );
112
113 } elsif ( $command eq 'push' ) {
114
115 $ua->request( HTTP::Request::Common::PUT( "http://localhost:5984/$database" ) ) && warn "# created database $database\n";
116
117 my $json;
118
119 find({ no_chdir => 1, wanted => sub {
120 my $path = $File::Find::name;
121 return unless -f $path;
122 return if $path =~ m{/\.svn};
123
124 warn "## $path\n";
125
126 $path =~ s{^\./}{};
127
128 if ( $path =~ m{_attachemnts/(.+)} ) {
129
130 my $filename = $1;
131 my $content_type = 'text/plain';
132 $content_type = type_from_ext($1) if $filename =~ m{\.(\w+)$};
133
134 my $data = File::Slurp::read_file( $path );
135 $data = encode_base64( $data );
136 # XXX inline attachments must be single line
137 # XXX http://wiki.apache.org/couchdb/HTTP_Document_API
138 $data =~ s/[\n\r]+//gs;
139 $json->{_attachments}->{ $filename } = {
140 content_type => $content_type,
141 data => $data,
142 };
143 return;
144 }
145
146 my $data = File::Slurp::read_file( $path );
147 $path =~ s[/]['}->{']g;
148 $path =~ s{\.\w+$}{};
149 my $code = "\$json->{'$path'} = \$data;";
150 eval $code;
151 die "ERROR in $code: $@" if $@;
152 # warn "## json = ",dump( $json );
153 }}, '.' );
154
155 if ( ! defined $json->{_id} ) {
156 warn "creating _id for document\n";
157 $json->{_id} = $$ . '-' . time();
158 }
159 delete( $json->{_rev} ) && warn "removing _rev from document\n";
160
161 print "push $database/_design/$design\n";
162 write_file "../$database-$design.push.js", to_json $json;
163
164 warn "# put $url\n";
165 my $response = $ua->request(
166 HTTP::Request::Common::PUT(
167 $url,
168 'Content-Type' => 'application/json',
169 Content => to_json $json,
170 )
171 );
172
173 if ( $response->code == 409 ) {
174 warn "## update $url\n";
175 my $response = $ua->get( $url );
176 die $response->status_line if $response->is_error;
177
178 my $data = from_json $response->decoded_content;
179 $json->{$_} = $data->{$_} foreach ( '_rev', '_id' );
180
181 $response = $ua->request( HTTP::Request::Common::PUT($url, 'Content-Type' => 'application/json', Content => to_json $json ) );
182 die $response->status_line if $response->is_error;
183 warn "push updated $url\n";
184 } else {
185 die $response->status_line if $response->is_error;
186 warn "push new $url\n";
187 }
188
189 } else {
190 die "$0: unknown command $command";
191 }
192

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26