/[couchdb]/design/design-couch.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /design/design-couch.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 30 by dpavlin, Sun Apr 26 20:18:17 2009 UTC revision 35 by dpavlin, Tue Apr 28 20:52:52 2009 UTC
# Line 8  use JSON; Line 8  use JSON;
8  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
9  use File::Path qw/mkpath/;  use File::Path qw/mkpath/;
10  use File::Slurp qw//;  use File::Slurp qw//;
11    use File::Find;
12    use HTTP::Request::Common;
13    use MIME::Base64;
14    use Media::Type::Simple;
15    
16    
17  # design-couch.pl  # design-couch.pl
18  #  #
19  # 04/26/09 21:12:28 CEST Dobrica Pavlinusic <dpavlin@rot13.org>  # 04/26/09 21:12:28 CEST Dobrica Pavlinusic <dpavlin@rot13.org>
20    
21  my ( $database, $design ) = @ARGV;  my ( $command, $database, $design ) = @ARGV;
22  die "usage: $0 database design\n" unless $database && $design;  die "usage: $0 [push|pull] database design\n" unless $database && $design;
23    
24  my $ua = LWP::UserAgent->new;  my $ua = LWP::UserAgent->new;
25    
26  my $url = "http://llin.lan:5984/$database/_design/$design";  my $url = "http://llin.lan:5984/$database/_design/$design";
27    
28  warn "# get $url\n";  sub create_path {
29  my $response = $ua->get( $url );          my $path = shift;
   
 die $response->status_line if $response->is_error;  
   
 sub write_file {  
         my ( $path, $content ) = @_;  
30          if ( $path =~ m{/} ) {          if ( $path =~ m{/} ) {
31                  my $dir = $path;                  my $dir = $path;
32                  $dir =~ s{/[^/]+$}{};                  $dir =~ s{/[^/]+$}{};
33                  mkpath $dir if ! -e $dir;                  mkpath $dir if ! -e $dir;
34                  #warn "# dir $dir";                  #warn "# dir $dir";
35          }          }
36    }
37    sub write_file {
38            my ( $path, $content ) = @_;
39            $path =~ s{^/+}{};
40            create_path $path;
41          File::Slurp::write_file $path, $content;          File::Slurp::write_file $path, $content;
42          #warn "# write_file $path ", -s $path, " bytes\n";          print "$path ", -s $path, " bytes created\n";
43  }  }
44    
45    sub write_attachment {
46            my ( $path ) = @_;
47            my $file = "_attachemnts/$path";
48            create_path $file;
49            $ua->mirror( "$url/$path", $file );
50            print "detached $file ", -s $file, " bytes\n";
51    }
52    
53    
54  sub unroll {  sub unroll {
55          my ( $tree, $path ) = @_;          my ( $tree, $path ) = @_;
56    
57          my $ref = ref $tree;          my $ref = ref $tree;
58          if ( $ref eq 'HASH' ) {          if ( $ref eq 'HASH' ) {
59                  unroll( $tree->{$_}, "$path/$_" ) foreach ( keys %$tree );                  foreach my $child ( keys %$tree ) {
60                            if ( $child eq '_attachments' ) {
61                                    write_attachment $_ foreach keys %{ $tree->{$child} };
62                            } else {
63                                    unroll( $tree->{$child}, $path ? "$path/$child" : $child );
64                            }
65                    }
66            } elsif ( $ref ) {
67                    warn "UNSUPPORTED $path $ref ", dump( $tree );
68                    write_file "$path.json", to_json $tree;
69          } elsif ( $ref eq '' ) {          } elsif ( $ref eq '' ) {
                 $path =~ s{^/+}{};  
70    
71                  my $ext = '';                  if ( $tree =~ m[^\s*(function(.*){.*}|/\*|//|var)]is ) {
72                            $path .= '.js';
73                  if ( $tree =~ m{^\s*function}i ) {                  } elsif ( $tree =~ m{<%=.*%>} ) { # couchapp template
74                          $ext = '.js';                          $path .= '.html';
75                  } elsif ( $tree =~ m{<\w+>} ) {                  } else {
76                          $ext = '.html';                          warn "# can't detect type of $path\n";
77                  }                  }
78    
79                  write_file $path . $ext , $tree;                  write_file $path, $tree;
                 print "$path ", -s $path, " bytes\n";  
80          }          }
81    
82  }  }
83    
84  my $json = $response->decoded_content;  if ( $command eq 'pull' ) {
85  write_file 'design.js', $json;  
86            warn "# get $url\n";
87            my $response = $ua->get( $url );
88            die $response->status_line if $response->is_error;
89    
90            my $json = $response->decoded_content;
91            write_file "../$database-$design.pull.js", $json;
92    
93            unroll( from_json $json, '' );
94    
95  unroll( from_json $json, '/' );  } elsif ( $command eq 'push' ) {
96    
97            my $json;
98    
99            find({ no_chdir => 1, wanted => sub {
100                    my $path = $File::Find::name;
101                    return unless -f $path;
102    
103    warn "## $path\n";
104    
105                    $path =~ s{^\./}{};
106    
107                    if ( $path =~ m{_attachemnts/(.+)} ) {
108    
109                            my $filename = $1;
110                            my $content_type = 'text/plain';
111                            $content_type = type_from_ext($1) if $filename =~ m{\.(\w+)$};
112    
113                            my $data = File::Slurp::read_file( $path );
114                            $data = encode_base64( $data );
115                            # XXX inline attachments must be single line
116                            # XXX http://wiki.apache.org/couchdb/HTTP_Document_API
117                            $data =~ s/[\n\r]+//gs;
118                            $json->{_attachments}->{ $filename } = {
119                                    content_type => $content_type,
120                                    data         => $data,
121                            };
122                            return;
123                    }
124    
125                    my $data = File::Slurp::read_file( $path );
126                    $path =~ s[/]['}->{']g;
127                    $path =~ s{\.\w+$}{};
128                    my $code = "\$json->{'$path'} = \$data;";
129                    eval $code;
130                    die "ERROR in $code: $@" if $@;
131    #               warn "## json = ",dump( $json );
132            }}, '.' );
133    
134            if ( ! defined $json->{_id} ) {
135                    warn "creating _id for document\n";
136                    $json->{_id} = $$ . '-' . time();
137            }
138            delete( $json->{_rev} ) && warn "removing _rev from document\n";
139    
140            print "push $database/_design/$design\n";
141            write_file "../$database-$design.push.js", to_json $json;
142    
143            warn "# put $url\n";
144            my $response = $ua->request(
145                    HTTP::Request::Common::PUT(
146                            $url,
147                            'Content-Type' => 'application/json',
148                            Content => to_json $json,
149                    )
150            );
151    
152            if ( $response->code == 409 ) {
153                    warn "## update $url\n";
154                    my $response = $ua->get( $url );
155                    die $response->status_line if $response->is_error;
156    
157                    my $data = from_json $response->decoded_content;
158                    $json->{$_} = $data->{$_} foreach ( '_rev', '_id' );
159    
160                    $response = $ua->request( HTTP::Request::Common::PUT($url, 'Content-Type' => 'application/json', Content => to_json $json ) );
161                    die $response->status_line if $response->is_error;
162                    warn "push updated $url\n";
163            } else {
164                    die $response->status_line if $response->is_error;
165                    warn "push new $url\n";
166            }
167    
168    } else {
169            die "$0: unknown command $command";
170    }
171    
Legend:
Removed from v.30  
changed lines
  Added in v.35
  ViewVC Help
Powered by ViewVC 1.1.26