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

Contents of /design/design-couch.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 35 - (show annotations)
Tue Apr 28 20:52:52 2009 UTC (15 years, 2 months ago) by dpavlin
File MIME type: text/plain
File size: 4007 byte(s)
correctly upload attachments (using inline) and update existing documents
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 Media::Type::Simple;
15
16
17 # design-couch.pl
18 #
19 # 04/26/09 21:12:28 CEST Dobrica Pavlinusic <dpavlin@rot13.org>
20
21 my ( $command, $database, $design ) = @ARGV;
22 die "usage: $0 [push|pull] database design\n" unless $database && $design;
23
24 my $ua = LWP::UserAgent->new;
25
26 my $url = "http://llin.lan:5984/$database/_design/$design";
27
28 sub create_path {
29 my $path = shift;
30 if ( $path =~ m{/} ) {
31 my $dir = $path;
32 $dir =~ s{/[^/]+$}{};
33 mkpath $dir if ! -e $dir;
34 #warn "# dir $dir";
35 }
36 }
37 sub write_file {
38 my ( $path, $content ) = @_;
39 $path =~ s{^/+}{};
40 create_path $path;
41 File::Slurp::write_file $path, $content;
42 print "$path ", -s $path, " bytes created\n";
43 }
44
45 sub write_attachment {
46 my ( $path ) = @_;
47 my $file = "_attachemnts/$path";
48 create_path $file;
49 $ua->mirror( "$url/$path", $file );
50 print "detached $file ", -s $file, " bytes\n";
51 }
52
53
54 sub unroll {
55 my ( $tree, $path ) = @_;
56
57 my $ref = ref $tree;
58 if ( $ref eq 'HASH' ) {
59 foreach my $child ( keys %$tree ) {
60 if ( $child eq '_attachments' ) {
61 write_attachment $_ foreach keys %{ $tree->{$child} };
62 } else {
63 unroll( $tree->{$child}, $path ? "$path/$child" : $child );
64 }
65 }
66 } elsif ( $ref ) {
67 warn "UNSUPPORTED $path $ref ", dump( $tree );
68 write_file "$path.json", to_json $tree;
69 } elsif ( $ref eq '' ) {
70
71 if ( $tree =~ m[^\s*(function(.*){.*}|/\*|//|var)]is ) {
72 $path .= '.js';
73 } elsif ( $tree =~ m{<%=.*%>} ) { # couchapp template
74 $path .= '.html';
75 } else {
76 warn "# can't detect type of $path\n";
77 }
78
79 write_file $path, $tree;
80 }
81
82 }
83
84 if ( $command eq 'pull' ) {
85
86 warn "# get $url\n";
87 my $response = $ua->get( $url );
88 die $response->status_line if $response->is_error;
89
90 my $json = $response->decoded_content;
91 write_file "../$database-$design.pull.js", $json;
92
93 unroll( from_json $json, '' );
94
95 } elsif ( $command eq 'push' ) {
96
97 my $json;
98
99 find({ no_chdir => 1, wanted => sub {
100 my $path = $File::Find::name;
101 return unless -f $path;
102
103 warn "## $path\n";
104
105 $path =~ s{^\./}{};
106
107 if ( $path =~ m{_attachemnts/(.+)} ) {
108
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;
123 }
124
125 my $data = File::Slurp::read_file( $path );
126 $path =~ s[/]['}->{']g;
127 $path =~ s{\.\w+$}{};
128 my $code = "\$json->{'$path'} = \$data;";
129 eval $code;
130 die "ERROR in $code: $@" if $@;
131 # warn "## json = ",dump( $json );
132 }}, '.' );
133
134 if ( ! defined $json->{_id} ) {
135 warn "creating _id for document\n";
136 $json->{_id} = $$ . '-' . time();
137 }
138 delete( $json->{_rev} ) && warn "removing _rev from document\n";
139
140 print "push $database/_design/$design\n";
141 write_file "../$database-$design.push.js", to_json $json;
142
143 warn "# put $url\n";
144 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 ) {
153 warn "## update $url\n";
154 my $response = $ua->get( $url );
155 die $response->status_line if $response->is_error;
156
157 my $data = from_json $response->decoded_content;
158 $json->{$_} = $data->{$_} foreach ( '_rev', '_id' );
159
160 $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;
162 warn "push updated $url\n";
163 } else {
164 die $response->status_line if $response->is_error;
165 warn "push new $url\n";
166 }
167
168 } else {
169 die "$0: unknown command $command";
170 }
171

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26