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{^/+}{};

                my $ext = '';

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

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

}

my $json = $response->decoded_content;
write_file 'design.js', $json;

unroll( from_json $json, '/' );

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
12			# design-couch.pl
13			#
14			# 04/26/09 21:12:28 CEST Dobrica Pavlinusic <dpavlin@rot13.org>
15
16	dpavlin	30	my ( $database, $design ) = @ARGV;
17			die "usage: $0 database design\n" unless $database && $design;
18
19	dpavlin	29	my $ua = LWP::UserAgent->new;
20
21	dpavlin	30	my $url = "http://llin.lan:5984/$database/_design/$design";
22	dpavlin	29
23	dpavlin	30	warn "# get $url\n";
24	dpavlin	29	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	dpavlin	30	#warn "# dir $dir";
35	dpavlin	29	}
36			File::Slurp::write_file $path, $content;
37	dpavlin	30	#warn "# write_file $path ", -s $path, " bytes\n";
38	dpavlin	29	}
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			my $ext = '';
50
51			if ( $tree =~ m{^\s*function}i ) {
52			$ext = '.js';
53			} elsif ( $tree =~ m{<\w+>} ) {
54			$ext = '.html';
55			}
56
57			write_file $path . $ext , $tree;
58			print "$path ", -s $path, " bytes\n";
59			}
60
61			}
62
63	dpavlin	30	my $json = $response->decoded_content;
64			write_file 'design.js', $json;
65
66			unroll( from_json $json, '/' );
67