File Coverage

blib/lib/Socialtext/Resting/LocalCopy.pm
Criterion Covered Total %
statement 60 60 100.0
branch 12 20 60.0
condition n/a
subroutine 7 7 100.0
pod 3 3 100.0
total 82 90 91.1


line stmt bran cond sub pod time code
1             package Socialtext::Resting::LocalCopy;
2 1     1   52938 use strict;
  1         3  
  1         41  
3 1     1   7 use warnings;
  1         2  
  1         32  
4 1     1   5 use JSON::XS;
  1         2  
  1         854  
5              
6             =head1 NAME
7              
8             Socialtext::Resting::LocalCopy - Maintain a copy on disk of a workspace
9              
10             =head1 SYNOPSIS
11              
12             Socialtext::Resting::LocalCopy allows one to copy a workspace into files
13             on the local disk, and to update a workspace from files on disk.
14              
15             =cut
16              
17             our $VERSION = '0.01';
18              
19             =head1 METHODS
20              
21             =head2 new
22              
23             Create a new LocalCopy object. Requires a C parameter, which should
24             be a Socialtext::Rester-like object.
25              
26             =cut
27              
28             sub new {
29 3     3 1 27 my $class = shift;
30 3         7 my $self = { @_ };
31              
32 3 50       9 die 'rester is mandatory' unless $self->{rester};
33 3         14 bless $self, $class;
34 3         7 return $self;
35             }
36              
37             =head2 pull
38              
39             Reads a workspace and pulls all of the pages into files in the specified
40             directory. Options are passed in as a list of named options:
41              
42             =over 4
43              
44             =item dir - The directory the files should be saved to.
45              
46             =item tag - an optional tag. If specified, only tagged files will be pulled.
47              
48             =back
49              
50             =cut
51              
52             sub pull {
53 2     2 1 1130 my $self = shift;
54 2         7 my %opts = @_;
55 2         4 my $dir = $opts{dir};
56 2         4 my $tag = $opts{tag};
57 2         6 my $r = $self->{rester};
58              
59 2         10 $r->accept('text/plain');
60 2 100       15 my @pages = $tag ? $r->get_taggedpages($tag) : $r->get_pages();
61 2         9 $r->accept('application/json');
62 2         9 $r->json_verbose(1);
63 2         4 for my $p (@pages) {
64 2         450 print "Saving $p ...\n";
65 2         13 my $obj = decode_json($r->get_page($p));
66              
67             # Trim the content
68 2         19 my %to_keep = map { $_ => 1 } $self->_keys_to_keep;
  8         20  
69 2         11 for my $k (keys %$obj) {
70 24 100       47 delete $obj->{$k} unless $to_keep{$k};
71             }
72              
73 2         8 my $wikitext_file = "$dir/$obj->{page_id}";
74 2 50       156 open(my $fh, ">$wikitext_file") or die "Can't open $wikitext_file: $!";
75 2         11 binmode $fh, ':utf8';
76 2         29 print $fh delete $obj->{wikitext};
77 2 50       81 close $fh or die "Can't write $wikitext_file: $!";
78              
79 2         14 my $json_file = "$wikitext_file.json";
80 2 50       115 open(my $jfh, ">$json_file") or die "Can't open $json_file: $!";
81 2         31 print $jfh encode_json($obj);
82 2 50       78 close $jfh or die "Can't write $json_file: $!";
83             }
84             }
85              
86 2     2   7 sub _keys_to_keep { qw/page_id name wikitext tags/ }
87              
88             =head2 push
89              
90             Reads a directory and pushes all the files in that directory up to
91             the specified workspace. Options are passed in as a list of named options:
92              
93             =over 4
94              
95             =item dir - The directory the files should be saved to.
96              
97             =item tag - an optional tag. If specified, only tagged files will be pushed.
98              
99             Note - tag is not yet implemented.
100              
101             =back
102              
103             =cut
104              
105             sub push {
106 1     1 1 12 my $self = shift;
107 1         2 my %opts = @_;
108 1         2 my $dir = $opts{dir};
109 1         2 my $tag = $opts{tag};
110 1         2 my $r = $self->{rester};
111              
112 1 50       3 die "Sorry - push by tag is not yet implemented!" if $tag;
113              
114 1         101 my @files = glob("$dir/*.json");
115 1         4 for my $f (@files) {
116 1 50       30 open(my $fh, $f) or die "Can't open $f: $!";
117 1         4 local $/ = undef;
118 1         25 my $obj = decode_json(<$fh>);
119 1         9 close $fh;
120              
121 1         5 (my $wikitext_file = $f) =~ s/\.json$//;
122 1 50       38 open(my $wtfh, $wikitext_file) or die "Can't open $wikitext_file: $!";
123 1         19 $obj->{wikitext} = <$wtfh>;
124 1         9 close $wtfh;
125              
126 1         109 print "Putting $obj->{page_id} ...\n";
127 1         8 $r->put_page($obj->{name}, $obj->{wikitext});
128 1         1 $r->put_pagetag($obj->{name}, $_) for @{ $obj->{tags} };
  1         7  
129             }
130             }
131              
132             =head1 BUGS
133              
134             Attachments are not yet supported.
135             Push by tag is not yet supported.
136              
137             =head1 AUTHOR
138              
139             Luke Closs, C<< >>
140              
141             =head1 COPYRIGHT & LICENSE
142              
143             Copyright 2007 Luke Closs, all rights reserved.
144              
145             This program is free software; you can redistribute it and/or modify it
146             under the same terms as Perl itself.
147              
148             =cut
149              
150             1;