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 $ua = LWP::UserAgent->new;

my $url = 'http://llin.lan:5984/blog/_design/sofa';

my $response = $ua->get( $url );

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

my $design = from_json $response->decoded_content;

my $path;

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

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";
        }

}

unroll( $design, '/' );
        
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			my $ua = LWP::UserAgent->new;
17
18			my $url = 'http://llin.lan:5984/blog/_design/sofa';
19
20			my $response = $ua->get( $url );
21
22			die $response->status_line if $response->is_error;
23
24			my $design = from_json $response->decoded_content;
25
26			my $path;
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			warn "# write_file $path $content";
37			File::Slurp::write_file $path, $content;
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			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			unroll( $design, '/' );
64