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	#!/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