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;

# 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\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;

        my @attached;

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

warn "## $path\n";

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

                if ( $path =~ m{_attachemnts} ) {
                        push @attached, $path;
                        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 );
        }}, '.' );

        warn "# $database/_design/$design = ",dump( $json );
        write_file "../$database-$design.push.js", to_json $json;

        die "no _id?" unless $json->{_id};
        delete( $json->{_rev} );

        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 "## get old $url\n";
                my $response = $ua->get( $url );
                die $response->status_line if $response->is_error;

                my $data = from_json $response;
                $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";
        }

        warn "FIXME: ignore attachments: ",dump( @attached );

} 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	29
14			# design-couch.pl
15			#
16			# 04/26/09 21:12:28 CEST Dobrica Pavlinusic <dpavlin@rot13.org>
17
18	dpavlin	33	my ( $command, $database, $design ) = @ARGV;
19			die "usage: $0 [push\|pull] database design\n" unless $database && $design;
20	dpavlin	30
21	dpavlin	29	my $ua = LWP::UserAgent->new;
22
23	dpavlin	30	my $url = "http://llin.lan:5984/$database/_design/$design";
24	dpavlin	29
25	dpavlin	32	sub create_path {
26			my $path = shift;
27	dpavlin	29	if ( $path =~ m{/} ) {
28			my $dir = $path;
29			$dir =~ s{/[^/]+$}{};
30			mkpath $dir if ! -e $dir;
31	dpavlin	30	#warn "# dir $dir";
32	dpavlin	29	}
33	dpavlin	32	}
34			sub write_file {
35			my ( $path, $content ) = @_;
36			$path =~ s{^/+}{};
37			create_path $path;
38	dpavlin	29	File::Slurp::write_file $path, $content;
39	dpavlin	32	print "$path ", -s $path, " bytes\n";
40	dpavlin	29	}
41
42	dpavlin	32	sub write_attachment {
43			my ( $path ) = @_;
44			my $file = "_attachemnts/$path";
45			create_path $file;
46			$ua->mirror( "$url/$path", $file );
47			print "detached $file ", -s $file, " bytes\n";
48			}
49
50	dpavlin	29	sub unroll {
51			my ( $tree, $path ) = @_;
52
53			my $ref = ref $tree;
54			if ( $ref eq 'HASH' ) {
55	dpavlin	32	foreach my $child ( keys %$tree ) {
56			if ( $child eq '_attachments' ) {
57			write_attachment $_ foreach keys %{ $tree->{$child} };
58			} else {
59	dpavlin	33	unroll( $tree->{$child}, $path ? "$path/$child" : $child );
60	dpavlin	32	}
61			}
62			} elsif ( $ref ) {
63			warn "UNSUPPORTED $path $ref ", dump( $tree );
64			write_file "$path.json", to_json $tree;
65	dpavlin	29	} elsif ( $ref eq '' ) {
66
67	dpavlin	33	if ( $tree =~ m[^\s(function(.){.}\|/\\|//\|var)]is ) {
68	dpavlin	31	$path .= '.js';
69	dpavlin	32	} elsif ( $tree =~ m{<%=.*%>} ) { # couchapp template
70	dpavlin	31	$path .= '.html';
71	dpavlin	32	} else {
72	dpavlin	33	warn "# can't detect type of $path\n";
73	dpavlin	29	}
74
75	dpavlin	31	write_file $path, $tree;
76	dpavlin	29	}
77
78			}
79
80	dpavlin	33	if ( $command eq 'pull' ) {
81	dpavlin	30
82	dpavlin	33	warn "# get $url\n";
83			my $response = $ua->get( $url );
84			die $response->status_line if $response->is_error;
85
86			my $json = $response->decoded_content;
87	dpavlin	34	write_file "../$database-$design.pull.js", $json;
88	dpavlin	33
89			unroll( from_json $json, '' );
90
91			} elsif ( $command eq 'push' ) {
92
93	dpavlin	34	my $json;
94	dpavlin	33
95	dpavlin	34	my @attached;
96	dpavlin	33
97	dpavlin	34	find({ no_chdir => 1, wanted => sub {
98			my $path = $File::Find::name;
99			return unless -f $path;
100
101			warn "## $path\n";
102
103			$path =~ s{^\./}{};
104
105			if ( $path =~ m{_attachemnts} ) {
106			push @attached, $path;
107			return;
108			}
109
110			my $data = File::Slurp::read_file( $path );
111			$path =~ s[/]['}->{']g;
112			$path =~ s{\.\w+$}{};
113			my $code = "\$json->{'$path'} = \$data;";
114			eval $code;
115			die "ERROR in $code: $@" if $@;
116			# warn "## json = ",dump( $json );
117			}}, '.' );
118
119			warn "# $database/_design/$design = ",dump( $json );
120			write_file "../$database-$design.push.js", to_json $json;
121
122			die "no _id?" unless $json->{_id};
123			delete( $json->{_rev} );
124
125			warn "# put $url\n";
126			my $response = $ua->request( HTTP::Request::Common::PUT($url, 'Content-Type' => 'application/json', Content => to_json $json ) );
127
128			if ( $response->code == 409 ) {
129			warn "## get old $url\n";
130			my $response = $ua->get( $url );
131			die $response->status_line if $response->is_error;
132
133			my $data = from_json $response;
134			$json->{$_} = $data->{$_} foreach ( 'rev', '_id' );
135
136			$response = $ua->request( HTTP::Request::Common::PUT($url, 'Content-Type' => 'application/json', Content => to_json $json ) );
137			die $response->status_line if $response->is_error;
138			warn "push updated $url\n";
139			} else {
140			die $response->status_line if $response->is_error;
141			warn "push new $url\n";
142			}
143
144			warn "FIXME: ignore attachments: ",dump( @attached );
145
146	dpavlin	33	} else {
147			die "$0: unknown command $command";
148			}
149