couchdb/design/design-couch.pl

#!/usr/bin/perl

use warnings;
use strict;

use LWP::UserAgent;
use JSON;
use Data::Dump qw/dump/;
use File::Path qw/mkpath/;
use File::Slurp qw//;
use File::Find;
use HTTP::Request::Common;
use MIME::Base64;
use Media::Type::Simple;


# design-couch.pl
#
# 04/26/09 21:12:28 CEST Dobrica Pavlinusic <dpavlin@rot13.org>

my ( $command, $database, $design ) = @ARGV;
die "usage: $0 [push|pull] database design\n" unless $database && $design;

my $ua = LWP::UserAgent->new;

my $url = "http://llin.lan:5984/$database/_design/$design";

sub create_path {
        my $path = shift;
        if ( $path =~ m{/} ) {
                my $dir = $path;
                $dir =~ s{/[^/]+$}{};
                mkpath $dir if ! -e $dir;
                #warn "# dir $dir";
        }
}
sub write_file {
        my ( $path, $content ) = @_;
        $path =~ s{^/+}{};
        create_path $path;
        File::Slurp::write_file $path, $content;
        print "$path ", -s $path, " bytes created\n";
}

sub write_attachment {
        my ( $path ) = @_;
        my $file = "_attachemnts/$path";
        create_path $file;
        $ua->mirror( "$url/$path", $file );
        print "detached $file ", -s $file, " bytes\n";
}


sub unroll {
        my ( $tree, $path ) = @_;

        my $ref = ref $tree;
        if ( $ref eq 'HASH' ) {
                foreach my $child ( keys %$tree ) {
                        if ( $child eq '_attachments' ) {
                                write_attachment $_ foreach keys %{ $tree->{$child} };
                        } else {
                                unroll( $tree->{$child}, $path ? "$path/$child" : $child );
                        }
                }
        } elsif ( $ref ) {
                warn "UNSUPPORTED $path $ref ", dump( $tree );
                write_file "$path.json", to_json $tree;
        } elsif ( $ref eq '' ) {

                if ( $tree =~ m[^\s*(function(.*){.*}|/\*|//|var)]is ) {
                        $path .= '.js';
                } elsif ( $tree =~ m{<%=.*%>} ) { # couchapp template
                        $path .= '.html';
                } else {
                        warn "# can't detect type of $path\n";
                }

                write_file $path, $tree;
        }

}

if ( $command eq 'pull' ) {

        warn "# get $url\n";
        my $response = $ua->get( $url );
        die $response->status_line if $response->is_error;

        my $json = $response->decoded_content;
        write_file "../$database-$design.pull.js", $json;

        unroll( from_json $json, '' );

} elsif ( $command eq 'push' ) {

        my $json;

        find({ no_chdir => 1, wanted => sub {
                my $path = $File::Find::name;
                return unless -f $path;

warn "## $path\n";

                $path =~ s{^\./}{};

                if ( $path =~ m{_attachemnts/(.+)} ) {

                        my $filename = $1;
                        my $content_type = 'text/plain';
                        $content_type = type_from_ext($1) if $filename =~ m{\.(\w+)$};

                        my $data = File::Slurp::read_file( $path );
                        $data = encode_base64( $data );
                        # XXX inline attachments must be single line
                        # XXX http://wiki.apache.org/couchdb/HTTP_Document_API
                        $data =~ s/[\n\r]+//gs;
                        $json->{_attachments}->{ $filename } = {
                                content_type => $content_type,
                                data         => $data,
                        };
                        return;
                }

                my $data = File::Slurp::read_file( $path );
                $path =~ s[/]['}->{']g;
                $path =~ s{\.\w+$}{};
                my $code = "\$json->{'$path'} = \$data;";
                eval $code;
                die "ERROR in $code: $@" if $@;
#               warn "## json = ",dump( $json );
        }}, '.' );

        if ( ! defined $json->{_id} ) {
                warn "creating _id for document\n";
                $json->{_id} = $$ . '-' . time();
        }
        delete( $json->{_rev} ) && warn "removing _rev from document\n";

        print "push $database/_design/$design\n";
        write_file "../$database-$design.push.js", to_json $json;

        warn "# put $url\n";
        my $response = $ua->request(
                HTTP::Request::Common::PUT(
                        $url,
                        'Content-Type' => 'application/json',
                        Content => to_json $json,
                )
        );

        if ( $response->code == 409 ) {
                warn "## update $url\n";
                my $response = $ua->get( $url );
                die $response->status_line if $response->is_error;

                my $data = from_json $response->decoded_content;
                $json->{$_} = $data->{$_} foreach ( '_rev', '_id' );

                $response = $ua->request( HTTP::Request::Common::PUT($url, 'Content-Type' => 'application/json', Content => to_json $json ) );
                die $response->status_line if $response->is_error;
                warn "push updated $url\n";
        } else {
                die $response->status_line if $response->is_error;
                warn "push new $url\n";
        }

} else {
        die "$0: unknown command $command";
}

1	dpavlin	29	#!/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	dpavlin	34	use File::Find;
12			use HTTP::Request::Common;
13	dpavlin	35	use MIME::Base64;
14			use Media::Type::Simple;
15	dpavlin	29
16	dpavlin	35
17	dpavlin	29	# design-couch.pl
18			#
19			# 04/26/09 21:12:28 CEST Dobrica Pavlinusic <dpavlin@rot13.org>
20
21	dpavlin	33	my ( $command, $database, $design ) = @ARGV;
22			die "usage: $0 [push\|pull] database design\n" unless $database && $design;
23	dpavlin	30
24	dpavlin	29	my $ua = LWP::UserAgent->new;
25
26	dpavlin	30	my $url = "http://llin.lan:5984/$database/_design/$design";
27	dpavlin	29
28	dpavlin	32	sub create_path {
29			my $path = shift;
30	dpavlin	29	if ( $path =~ m{/} ) {
31			my $dir = $path;
32			$dir =~ s{/[^/]+$}{};
33			mkpath $dir if ! -e $dir;
34	dpavlin	30	#warn "# dir $dir";
35	dpavlin	29	}
36	dpavlin	32	}
37			sub write_file {
38			my ( $path, $content ) = @_;
39			$path =~ s{^/+}{};
40			create_path $path;
41	dpavlin	29	File::Slurp::write_file $path, $content;
42	dpavlin	35	print "$path ", -s $path, " bytes created\n";
43	dpavlin	29	}
44
45	dpavlin	32	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	dpavlin	35
54	dpavlin	29	sub unroll {
55			my ( $tree, $path ) = @_;
56
57			my $ref = ref $tree;
58			if ( $ref eq 'HASH' ) {
59	dpavlin	32	foreach my $child ( keys %$tree ) {
60			if ( $child eq '_attachments' ) {
61			write_attachment $_ foreach keys %{ $tree->{$child} };
62			} else {
63	dpavlin	33	unroll( $tree->{$child}, $path ? "$path/$child" : $child );
64	dpavlin	32	}
65			}
66			} elsif ( $ref ) {
67			warn "UNSUPPORTED $path $ref ", dump( $tree );
68			write_file "$path.json", to_json $tree;
69	dpavlin	29	} elsif ( $ref eq '' ) {
70
71	dpavlin	33	if ( $tree =~ m[^\s(function(.){.}\|/\\|//\|var)]is ) {
72	dpavlin	31	$path .= '.js';
73	dpavlin	32	} elsif ( $tree =~ m{<%=.*%>} ) { # couchapp template
74	dpavlin	31	$path .= '.html';
75	dpavlin	32	} else {
76	dpavlin	33	warn "# can't detect type of $path\n";
77	dpavlin	29	}
78
79	dpavlin	31	write_file $path, $tree;
80	dpavlin	29	}
81
82			}
83
84	dpavlin	33	if ( $command eq 'pull' ) {
85	dpavlin	30
86	dpavlin	33	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	dpavlin	34	write_file "../$database-$design.pull.js", $json;
92	dpavlin	33
93			unroll( from_json $json, '' );
94
95			} elsif ( $command eq 'push' ) {
96
97	dpavlin	34	my $json;
98	dpavlin	33
99	dpavlin	34	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	dpavlin	35	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	dpavlin	34	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	dpavlin	35	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	dpavlin	34	write_file "../$database-$design.push.js", to_json $json;
142
143			warn "# put $url\n";
144	dpavlin	35	my $response = $ua->request(
145			HTTP::Request::Common::PUT(
146			$url,
147			'Content-Type' => 'application/json',
148			Content => to_json $json,
149			)
150			);
151	dpavlin	34
152			if ( $response->code == 409 ) {
153	dpavlin	35	warn "## update $url\n";
154	dpavlin	34	my $response = $ua->get( $url );
155			die $response->status_line if $response->is_error;
156
157	dpavlin	35	my $data = from_json $response->decoded_content;
158			$json->{$_} = $data->{$_} foreach ( '_rev', '_id' );
159	dpavlin	34
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	dpavlin	33	} else {
169			die "$0: unknown command $command";
170			}
171