/[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 367 - (hide annotations)
Sun Aug 30 11:56:31 2009 UTC (14 years, 7 months ago) by dpavlin
File MIME type: text/plain
File size: 4358 byte(s)
add to subversion on pull
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    
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 dpavlin 341 if ( ! -e $design && $command eq 'pull') {
27     warn "# create new design $design\n";
28     mkdir $design;
29     }
30    
31 dpavlin 248 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 dpavlin 367
47     sub svn {
48     my $path = shift;
49     return if $path =~ m{(_rev|.*\.(push|pull)\.js)$};
50     system "svn add --parents $path";
51     }
52    
53 dpavlin 248 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 dpavlin 367 svn $path;
60 dpavlin 248 }
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 dpavlin 367 svn $file;
69 dpavlin 248 }
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     my $json;
116    
117     find({ no_chdir => 1, wanted => sub {
118     my $path = $File::Find::name;
119     return unless -f $path;
120 dpavlin 252 return if $path =~ m{/\.svn};
121 dpavlin 248
122     warn "## $path\n";
123    
124     $path =~ s{^\./}{};
125    
126     if ( $path =~ m{_attachemnts/(.+)} ) {
127    
128     my $filename = $1;
129     my $content_type = 'text/plain';
130     $content_type = type_from_ext($1) if $filename =~ m{\.(\w+)$};
131    
132     my $data = File::Slurp::read_file( $path );
133     $data = encode_base64( $data );
134     # XXX inline attachments must be single line
135     # XXX http://wiki.apache.org/couchdb/HTTP_Document_API
136     $data =~ s/[\n\r]+//gs;
137     $json->{_attachments}->{ $filename } = {
138     content_type => $content_type,
139     data => $data,
140     };
141     return;
142     }
143    
144     my $data = File::Slurp::read_file( $path );
145     $path =~ s[/]['}->{']g;
146     $path =~ s{\.\w+$}{};
147     my $code = "\$json->{'$path'} = \$data;";
148     eval $code;
149     die "ERROR in $code: $@" if $@;
150     # warn "## json = ",dump( $json );
151     }}, '.' );
152    
153     if ( ! defined $json->{_id} ) {
154     warn "creating _id for document\n";
155     $json->{_id} = $$ . '-' . time();
156     }
157     delete( $json->{_rev} ) && warn "removing _rev from document\n";
158    
159     print "push $database/_design/$design\n";
160     write_file "../$database-$design.push.js", to_json $json;
161    
162     warn "# put $url\n";
163     my $response = $ua->request(
164     HTTP::Request::Common::PUT(
165     $url,
166     'Content-Type' => 'application/json',
167     Content => to_json $json,
168     )
169     );
170    
171     if ( $response->code == 409 ) {
172     warn "## update $url\n";
173     my $response = $ua->get( $url );
174     die $response->status_line if $response->is_error;
175    
176     my $data = from_json $response->decoded_content;
177     $json->{$_} = $data->{$_} foreach ( '_rev', '_id' );
178    
179     $response = $ua->request( HTTP::Request::Common::PUT($url, 'Content-Type' => 'application/json', Content => to_json $json ) );
180     die $response->status_line if $response->is_error;
181     warn "push updated $url\n";
182     } else {
183     die $response->status_line if $response->is_error;
184     warn "push new $url\n";
185     }
186    
187     } else {
188     die "$0: unknown command $command";
189     }
190    

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26