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

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

my ( $database, $design ) = @ARGV;
die "usage: $0 database design\n" unless $database && $design;

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

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

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

die $response->status_line if $response->is_error;

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

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

        my $ref = ref $tree;
        if ( $ref eq 'HASH' ) {
                unroll( $tree->{$_}, "$path/$_" ) foreach ( keys %$tree );
        } elsif ( $ref eq '' ) {
                $path =~ s{^/+}{};

                if ( $tree =~ m{^\s*function}i ) {
                        $path .= '.js';
                } elsif ( $tree =~ m{<\w+>} ) {
                        $path .= '.html';
                }

                write_file $path, $tree;
                print "$path ", -s $path, " bytes\n";
        }

}

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

unroll( from_json $json, '/' );

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
12	# design-couch.pl
13	#
14	# 04/26/09 21:12:28 CEST Dobrica Pavlinusic <dpavlin@rot13.org>
15
16	my ( $database, $design ) = @ARGV;
17	die "usage: $0 database design\n" unless $database && $design;
18
19	my $ua = LWP::UserAgent->new;
20
21	my $url = "http://llin.lan:5984/$database/_design/$design";
22
23	warn "# get $url\n";
24	my $response = $ua->get( $url );
25
26	die $response->status_line if $response->is_error;
27
28	sub write_file {
29	my ( $path, $content ) = @_;
30	if ( $path =~ m{/} ) {
31	my $dir = $path;
32	$dir =~ s{/[^/]+$}{};
33	mkpath $dir if ! -e $dir;
34	#warn "# dir $dir";
35	}
36	File::Slurp::write_file $path, $content;
37	#warn "# write_file $path ", -s $path, " bytes\n";
38	}
39
40	sub unroll {
41	my ( $tree, $path ) = @_;
42
43	my $ref = ref $tree;
44	if ( $ref eq 'HASH' ) {
45	unroll( $tree->{$_}, "$path/$_" ) foreach ( keys %$tree );
46	} elsif ( $ref eq '' ) {
47	$path =~ s{^/+}{};
48
49	if ( $tree =~ m{^\s*function}i ) {
50	$path .= '.js';
51	} elsif ( $tree =~ m{<\w+>} ) {
52	$path .= '.html';
53	}
54
55	write_file $path, $tree;
56	print "$path ", -s $path, " bytes\n";
57	}
58
59	}
60
61	my $json = $response->decoded_content;
62	write_file "../$database-$design.js", $json;
63
64	unroll( from_json $json, '/' );
65