File Coverage

blib/lib/Test/Smoke/Syncer.pm
Criterion Covered Total %
statement 73 77 94.8
branch 17 20 85.0
condition 2 3 66.6
subroutine 16 16 100.0
pod 2 2 100.0
total 110 118 93.2


line stmt bran cond sub pod time code
1             package Test::Smoke::Syncer;
2 11     11   41283 use warnings;
  11         46  
  11         502  
3 11     11   89 use strict;
  11         36  
  11         280  
4 11     11   76 use Carp;
  11         44  
  11         1237  
5              
6 11     11   5563 use Test::Smoke::Syncer::Rsync;
  11         41  
  11         365  
7 11     11   5342 use Test::Smoke::Syncer::Git;
  11         33  
  11         363  
8 11     11   5702 use Test::Smoke::Syncer::Copy;
  11         32  
  11         316  
9 11     11   5407 use Test::Smoke::Syncer::Hardlink;
  11         44  
  11         356  
10 11     11   6282 use Test::Smoke::Syncer::Snapshot;
  11         32  
  11         405  
11 11     11   5151 use Test::Smoke::Syncer::FTP;
  11         32  
  11         360  
12 11     11   5160 use Test::Smoke::Syncer::Forest;
  11         33  
  11         387  
13              
14 11     11   75 use vars qw( $VERSION );
  11         23  
  11         800  
15             $VERSION = '0.029';
16              
17 11     11   67 use Config;
  11         73  
  11         672  
18 11     11   66 use Cwd qw( cwd abs_path);
  11         20  
  11         501  
19 11     11   58 use File::Spec;
  11         27  
  11         15540  
20             require File::Path;
21              
22             my %CONFIG = (
23             df_sync => 'rsync',
24             df_ddir => File::Spec->rel2abs( 'perl-current', abs_path() ),
25             df_v => 0,
26              
27             # these settings have to do synctype==rsync
28             df_rsync => 'rsync', # you might want a path there
29             df_opts => '-az --delete',
30             df_source => 'github.com/Perl::perl-current',
31              
32             rsync => {
33             allowed => [qw(rsync source opts)],
34             required => [qw(rsync source)],
35             class => 'Test::Smoke::Syncer::Rsync',
36             },
37              
38             # these settings have to do with synctype==snapshot
39             df_ftp => 'Net::FTP',
40             df_server => 'github.com/Perl',
41             df_sdir => '/pub/apc/perl-current-snap',
42             df_sfile => '',
43             df_snapext => 'tar.gz',
44              
45             df_tar => ( $^O eq 'MSWin32' ?
46             'Archive::Tar' : 'gzip -d -c %s | tar xf -' ),
47              
48             df_patchup => 0,
49             df_pserver => 'github.com/Perl',
50             df_pdir => '/pub/apc/perl-current-diffs',
51             df_ftpusr => 'anonymous',
52             df_ftppwd => 'smokers@perl.org',
53             df_unzip => $^O eq 'MSWin32' ? 'Compress::Zlib' : 'gzip -dc',
54             df_patchbin => 'patch',
55             df_cleanup => 1,
56             snapshot => {
57             allowed => [
58             qw( ftp server sdir sfile snapext tar ftpusr ftppwd
59             patchup pserver pdir unzip patchbin cleanup )
60             ],
61             required => [],
62             class => 'Test::Smoke::Syncer::Snapshot',
63             },
64              
65             # these settings have to do with synctype==copy
66             df_cdir => undef,
67              
68             copy => {
69             allowed => [qw(cdir)],
70             required => [qw(cdir)],
71             class => 'Test::Smoke::Syncer::Copy',
72             },
73              
74             # these settings have to do with synctype==hardlink
75             df_hdir => undef,
76             df_haslink => ($Config{d_link}||'') eq 'define',
77              
78             hardlink => {
79             allowed => [qw( hdir haslink )],
80             required => [qw(hdir)],
81             class => 'Test::Smoke::Syncer::Hardlink',
82             },
83              
84             # these have to do 'forest'
85             df_fsync => 'rsync',
86             df_mdir => undef,
87             df_fdir => undef,
88              
89             forest => {
90             allowed => [qw(fsync mdir fdir)],
91             required => [qw(mdir fdir)],
92             class => 'Test::Smoke::Syncer::Forest',
93             },
94              
95             # these settings have to do with synctype==ftp
96             df_ftphost => 'public.activestate.com',
97             df_ftpsdir => '/pub/apc/perl-current',
98             df_ftpcdir => '/pub/apc/perl-current-diffs',
99             df_ftype => undef,
100              
101             ftp => {
102             allowed => [qw(ftphost ftpusr ftppwd ftpsdir ftpcdir ftype)],
103             required => [qw()],
104             class => 'Test::Smoke::Syncer::FTP',
105             },
106              
107             # synctype: git
108             df_gitbin => 'git',
109             df_gitorigin => 'https://github.com/Perl/perl5.git',
110             df_gitdir => undef,
111             df_gitdfbranch => 'blead',
112             df_gitbranchfile => undef,
113              
114             git => {
115             allowed => [qw(gitbin gitorigin gitdir gitdfbranch gitbranchfile)],
116             required => [qw(gitbin gitorigin gitdir)],
117             class => 'Test::Smoke::Syncer::Git',
118             },
119              
120             # misc.
121             valid_type => { rsync => 1, git => 1, snapshot => 1,
122             copy => 1, hardlink => 1, ftp => 1 },
123             );
124              
125             {
126             my %allkeys = map {
127             ($_ => 1)
128             } map
129             @{ $CONFIG{ $_ }{allowed} }
130             , keys %{ $CONFIG{valid_type} };
131              
132             push @{ $CONFIG{forest}{allowed} }, keys %allkeys;
133             $CONFIG{forest}{required} = [];
134             $CONFIG{forest}{class} = 'Test::Smoke::Syncer::Forest';
135             $CONFIG{valid_type}->{forest} = 1;
136             }
137              
138             =head1 NAME
139              
140             Test::Smoke::Syncer - Factory for syncer objects.
141              
142             =head1 SYNOPSIS
143              
144             use Test::Smoke::Syncer;
145              
146             my $type = 'rsync'; # or 'snapshot' or 'copy'
147             my $syncer = Test::Smoke::Syncer->new( $type => \%sync_config );
148             my $patch_level = $syncer->sync;
149              
150             =head1 DESCRIPTION
151              
152             At this moment we support three basic types of syncing the perl source-tree.
153              
154             =over
155              
156             =item rsync
157              
158             This method uses the B program with the C<< --delete >> option
159             to get your perl source-tree up to date.
160              
161             =item snapshot
162              
163             This method uses the B or the B module to get the
164             latest snapshot. When the B attribute starts with I
165             the fetching is done by C.
166             To emulate the C<< rsync --delete >> effect, the current source-tree
167             is removed.
168              
169             The snapshot tarball is handled by either B/B or
170             B/B.
171              
172             =item copy
173              
174             This method uses the B module to copy an existing source-tree
175             from somewhere on the system (in case rsync doesn't work), this also
176             removes the current source-tree first.
177              
178             =item forest
179              
180             This method will sync the source-tree in one of the above basic methods.
181             After that, it will create an intermediate copy of the master directory
182             as hardlinks and run the F script. This should yield
183             an up-to-date source-tree. The intermadite directory is now copied as
184             hardlinks to its final directory ({ddir}).
185              
186             This can be used to change the way B is run from
187             F (removes all files that are not in the intermediate
188             directory, which may prove faster than traditional B).
189              
190             =back
191              
192             =head1 METHODS
193              
194             =head2 Test::Smoke::Syncer->new( $type, \%sync_config )
195              
196             [ Constructor | Public ]
197              
198             Initialise a new object and check all relevant arguments.
199             It returns an object of the appropriate B class.
200              
201             =cut
202              
203             sub new {
204 25     25 1 175628 my $factory = shift;
205              
206 25   66     315 my $sync_type = lc(shift || $CONFIG{df_sync});
207              
208 25 100       198 if ( !exists $CONFIG{valid_type}{$sync_type} ) {
209 1         356 croak( "Invalid sync_type '$sync_type'" );
210             };
211              
212 24 100       437 my %args_raw = @_ ? UNIVERSAL::isa( $_[0], 'HASH' ) ? %{ $_[0] } : @_ : ();
  16 100       273  
213              
214             my %args = map {
215 24         217 ( my $key = $_ ) =~ s/^-?(.+)$/lc $1/e;
  195         1029  
  195         643  
216 195         732 ( $key => $args_raw{ $_ } );
217             } keys %args_raw;
218              
219             my %fields = map {
220 196 100       781 my $value = exists $args{$_} ? $args{ $_ } : $CONFIG{ "df_$_" };
221 196         893 ( $_ => $value )
222 24         103 } ( v => ddir => @{ $CONFIG{$sync_type}{allowed} } );
  24         147  
223 24 100       542 if ( ! File::Spec->file_name_is_absolute( $fields{ddir} ) ) {
224 5         123 $fields{ddir} = File::Spec->catdir( abs_path(), $fields{ddir} );
225             }
226 24         868 $fields{ddir} = File::Spec->rel2abs( $fields{ddir}, abs_path() );
227              
228 24         95 my @missing;
229 24         71 for my $required (@{ $CONFIG{$sync_type}{required} }) {
  24         163  
230             push(
231             @missing,
232             "option '$required' missing for '$CONFIG{$sync_type}{class}'"
233 25 100       119 ) if !defined $fields{$required};
234             }
235 24 100       117 if (@missing) {
236 1         217 croak("Missing option:\n\t", join("\n\t", @missing));
237             }
238              
239 23         126 my $class = $CONFIG{$sync_type}{class};
240 23         770 return $class->new(%fields);
241             }
242              
243             =head2 Test::Smoke::Syncer->config( $key[, $value] )
244              
245             [ Accessor | Public ]
246              
247             C is an interface to the package lexical C<%CONFIG>,
248             which holds all the default values for the C arguments.
249              
250             With the special key B this returns a reference
251             to a hash holding all the default values.
252              
253             =cut
254              
255             sub config {
256 1     1 1 543 my $dummy = shift;
257              
258 1         3 my $key = lc shift;
259              
260 1 50       5 if ( $key eq 'all_defaults' ) {
261             my %default = map {
262 0         0 my( $pass_key ) = $_ =~ /^df_(.+)/;
  0         0  
263 0         0 ( $pass_key => $CONFIG{ $_ } );
264             } grep /^df_/ => keys %CONFIG;
265 0         0 return \%default;
266             }
267              
268 1 50       7 return undef unless exists $CONFIG{ "df_$key" };
269              
270 1 50       4 $CONFIG{ "df_$key" } = shift if @_;
271              
272 1         7 return $CONFIG{ "df_$key" };
273             }
274              
275             =head1 SEE ALSO
276              
277             L, L, L, L, L,
278             L, L
279              
280             =head1 COPYRIGHT
281              
282             (c) 2002-2013, All rights reserved.
283              
284             * Abe Timmerman
285              
286             This library is free software; you can redistribute it and/or modify
287             it under the same terms as Perl itself.
288              
289             See:
290              
291             * ,
292             *
293              
294             This program is distributed in the hope that it will be useful,
295             but WITHOUT ANY WARRANTY; without even the implied warranty of
296             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
297              
298             =cut