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 |
|
|
if ( $tree =~ m{^\s*function}i ) { |
50 |
dpavlin |
31 |
$path .= '.js'; |
51 |
dpavlin |
29 |
} elsif ( $tree =~ m{<\w+>} ) { |
52 |
dpavlin |
31 |
$path .= '.html'; |
53 |
dpavlin |
29 |
} |
54 |
|
|
|
55 |
dpavlin |
31 |
write_file $path, $tree; |
56 |
dpavlin |
29 |
print "$path ", -s $path, " bytes\n"; |
57 |
|
|
} |
58 |
|
|
|
59 |
|
|
} |
60 |
|
|
|
61 |
dpavlin |
30 |
my $json = $response->decoded_content; |
62 |
dpavlin |
31 |
write_file "../$database-$design.js", $json; |
63 |
dpavlin |
30 |
|
64 |
|
|
unroll( from_json $json, '/' ); |
65 |
|
|
|