dump functionality added
[dbsrgits/DBIx-Class-Fixtures.git] / lib / DBIx / Class / Fixtures.pm
1 package DBIx::Class::Fixtures;
2
3 use strict;
4 use warnings;
5
6 use DBIx::Class::Exception;
7 use Class::Accessor;
8 use Path::Class qw(dir file);
9 use Config::Any::JSON;
10 use Data::Dump::Streamer;
11 use File::Slurp;
12 use File::Path;
13 use Hash::Merge qw( merge );
14 use Data::Dumper;
15
16 use base qw(Class::Accessor);
17
18 __PACKAGE__->mk_accessors(qw(config_dir _inherited_attributes debug));
19
20 =head1 VERSION
21
22 Version 1.000
23
24 =cut
25
26 our $VERSION = '1.000';
27
28 =head1 NAME
29
30 =head1 SYNOPSIS
31
32   use DBIx::Class::Fixtures;
33
34   ...
35
36   my $fixtures = DBIx::Class::Fixtures->new({ config_dir => '/home/me/app/fixture_configs' });
37
38   $fixtures->dump({
39     config => 'set_config.json',
40     schema => $source_dbic_schema,
41     directory => '/home/me/app/fixtures'
42   });
43
44   $fixtures->populate({
45     directory => '/home/me/app/fixtures',
46     ddl => '/home/me/app/sql/ddl.sql',
47     connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password']
48   });
49
50 =head1 DESCRIPTION
51
52 =head1 AUTHOR
53
54 =head1 CONTRIBUTORS
55
56 =head1 METHODS
57
58 =head2 new
59
60 =cut
61
62 sub new {
63   my $class = shift;
64
65   my ($params) = @_;
66   unless (ref $params eq 'HASH') {
67     return DBIx::Class::Exception->throw('first arg to DBIx::Class::Fixtures->new() must be hash ref');
68   }
69
70   unless ($params->{config_dir}) {
71     return DBIx::Class::Exception->throw('config_dir param not specified');
72   }
73
74   my $config_dir = dir($params->{config_dir});
75   unless (-e $params->{config_dir}) {
76     return DBIx::Class::Exception->throw('config_dir directory doesn\'t exist');
77   }
78
79   my $self = {
80               config_dir => $config_dir,
81               _inherited_attributes => [qw/datetime_relative might_have rules/],
82               debug => $params->{debug}
83   };
84
85   bless $self, $class;
86
87   return $self;
88 }
89
90 =head2 dump
91
92 =cut
93
94 sub dump {
95   my $self = shift;
96
97   my ($params) = @_;
98   unless (ref $params eq 'HASH') {
99     return DBIx::Class::Exception->throw('first arg to dump must be hash ref');
100   }
101
102   foreach my $param (qw/config schema directory/) {
103     unless ($params->{$param}) {
104       return DBIx::Class::Exception->throw($param . ' param not specified');
105     }
106   }
107
108   my $config_file = file($self->config_dir, $params->{config});
109   unless (-e $config_file) {
110     return DBIx::Class::Exception->throw('config does not exist at ' . $config_file);
111   }
112
113   my $config = Config::Any::JSON->load($config_file);
114   unless ($config && $config->{sets} && ref $config->{sets} eq 'ARRAY' && scalar(@{$config->{sets}})) {
115     return DBIx::Class::Exception->throw('config has no sets');
116   }
117
118   my $output_dir = dir($params->{directory});
119   unless (-e $output_dir) {
120     return DBIx::Class::Exception->throw('output directory does not exist at ' . $output_dir);
121   }
122
123   my $schema = $params->{schema};
124
125   $self->msg("generating  fixtures\n");
126   my $tmp_output_dir = dir($output_dir, '-~dump~-');
127
128   unless (-e $tmp_output_dir) {
129     $self->msg("- creating $tmp_output_dir");
130     mkdir($tmp_output_dir, 0777);
131   }else {
132     $self->msg("- clearing existing $tmp_output_dir");
133     # delete existing fixture set
134     system("rm -rf $tmp_output_dir/*");
135   }
136
137   # write version file (for the potential benefit of populate)
138   my $version_file = file($tmp_output_dir, '_dumper_version');
139   write_file($version_file->stringify, $VERSION);
140
141   $config->{rules} ||= {};
142   my @sources = sort { $a->{class} cmp $b->{class} } @{delete $config->{sets}};
143   my %options = ( is_root => 1 );
144   foreach my $source (@sources) {
145     # apply rule to set if specified
146     my $rule = $config->{rules}->{$source->{class}};
147     $source = merge( $source, $rule ) if ($rule);
148
149     # fetch objects
150     my $rs = $schema->resultset($source->{class});      
151         $rs = $rs->search($source->{cond}, { join => $source->{join} }) if ($source->{cond});
152     $self->msg("- dumping $source->{class}");
153     my @objects;
154     my %source_options = ( set => { %{$config}, %{$source} } );
155     if ($source->{quantity}) {
156       $rs = $rs->search({}, { order_by => $source->{order_by} }) if ($source->{order_by});
157       if ($source->{quantity} eq 'all') {
158         push (@objects, $rs->all);
159       } elsif ($source->{quantity} =~ /^\d+$/) {
160         push (@objects, $rs->search({}, { rows => $source->{quantity} }));
161       } else {
162         DBIx::Class::Exception->throw('invalid value for quantity - ' . $source->{quantity});
163       }
164     }
165     if ($source->{ids}) {
166       my @ids = @{$source->{ids}};
167       my @id_objects = grep { $_ } map { $rs->find($_) } @ids;
168       push (@objects, @id_objects);
169     }
170     unless ($source->{quantity} || $source->{ids}) {
171       DBIx::Class::Exception->throw('must specify either quantity or ids');
172     }
173
174     # dump objects
175     foreach my $object (@objects) {
176       $source_options{set_dir} = $tmp_output_dir;
177       $self->dump_object($object, { %options, %source_options } );
178       next;
179     }
180   }
181
182   foreach my $dir ($output_dir->children) {
183     next if ($dir eq $tmp_output_dir);
184     $dir->remove || $dir->rmtree;
185   }
186
187   $self->msg("- moving temp dir to $output_dir");
188   system("mv $tmp_output_dir/* $output_dir/");
189   if (-e $output_dir) {
190     $self->msg("- clearing tmp dir $tmp_output_dir");
191     # delete existing fixture set
192     $tmp_output_dir->remove;
193   }
194
195   $self->msg("done");
196
197   return 1;
198 }
199
200 sub dump_object {
201   my ($self, $object, $params, $rr_info) = @_;  
202   my $set = $params->{set};
203   die 'no dir passed to dump_object' unless $params->{set_dir};
204   die 'no object passed to dump_object' unless $object;
205
206   my @inherited_attrs = @{$self->_inherited_attributes};
207
208   # write dir and gen filename
209   my $source_dir = dir($params->{set_dir}, lc($object->result_source->from));
210   mkdir($source_dir->stringify, 0777);
211   my $file = file($source_dir, join('-', map { $object->get_column($_) } sort $object->primary_columns) . '.fix');
212
213   # write file
214   my $exists = (-e $file->stringify) ? 1 : 0;
215   unless ($exists) {
216     $self->msg('-- dumping ' . $file->stringify, 2);
217     my %ds = $object->get_columns;
218
219     # mess with dates if specified
220     if ($set->{datetime_relative}) {     
221       my $dt;
222       if ($set->{datetime_relative} eq 'today') {
223         $dt = DateTime->today;
224       } else {
225         require DateTime::Format::MySQL;
226         $dt = DateTime::Format::MySQL->parse_datetime($set->{datetime_relative});
227       }
228
229       while (my ($col, $value) = each %ds) {
230         my $col_info = $object->result_source->column_info($col);
231
232         next unless $value
233           && $col_info->{_inflate_info}
234             && uc($col_info->{data_type}) eq 'DATETIME';
235
236         $ds{$col} = $object->get_inflated_column($col)->subtract_datetime($dt);
237       }
238     }
239
240     # do the actual dumping
241     my $serialized = Dump(\%ds)->Out();
242     write_file($file->stringify, $serialized);
243     my $mode = 0777; chmod $mode, $file->stringify;  
244   }
245
246   # dump rels of object
247   my $s = $object->result_source;
248   unless ($exists) {
249     foreach my $name (sort $s->relationships) {
250       my $info = $s->relationship_info($name);
251       my $r_source = $s->related_source($name);
252       # if belongs_to or might_have with might_have param set or has_many with has_many param set then
253       if (($info->{attrs}{accessor} eq 'single' && (!$info->{attrs}{join_type} || ($set->{might_have} && $set->{might_have}->{fetch}))) || $info->{attrs}{accessor} eq 'filter' || ($info->{attrs}{accessor} eq 'multi' && ($set->{has_many} && $set->{has_many}->{fetch}))) {
254         my $related_rs = $object->related_resultset($name);       
255         my $rule = $set->{rules}->{$related_rs->result_source->source_name};
256         # these parts of the rule only apply to has_many rels
257         if ($rule && $info->{attrs}{accessor} eq 'multi') {               
258           $related_rs = $related_rs->search($rule->{cond}, { join => $rule->{join} }) if ($rule->{cond});
259           $related_rs = $related_rs->search({}, { rows => $rule->{quantity} }) if ($rule->{quantity} && $rule->{quantity} ne 'all');
260           $related_rs = $related_rs->search({}, { order_by => $rule->{order_by} }) if ($rule->{order_by});                
261         }
262         if ($set->{has_many}->{quantity} && $set->{has_many}->{quantity} =~ /^\d+$/) {
263           $related_rs = $related_rs->search({}, { rows => $set->{has_many}->{quantity} });
264         }
265         my %c_params = %{$params};
266         # inherit date param
267         my %mock_set = map { $_ => $set->{$_} } grep { $set->{$_} } @inherited_attrs;
268         $c_params{set} = \%mock_set;
269         #               use Data::Dumper; print ' -- ' . Dumper($c_params{set}, $rule->{fetch}) if ($rule && $rule->{fetch});
270         $c_params{set} = merge( $c_params{set}, $rule) if ($rule && $rule->{fetch});
271         #               use Data::Dumper; print ' -- ' . Dumper(\%c_params) if ($rule && $rule->{fetch});
272         dump_object($_, \%c_params) foreach $related_rs->all;     
273       } 
274     }
275   }
276   
277   return unless $set && $set->{fetch};
278   foreach my $fetch (@{$set->{fetch}}) {
279     # inherit date param
280     $fetch->{$_} = $set->{$_} foreach grep { !$fetch->{$_} && $set->{$_} } @inherited_attrs;
281     my $related_rs = $object->related_resultset($fetch->{rel});
282     my $rule = $set->{rules}->{$related_rs->result_source->source_name};
283     if ($rule) {
284       my $info = $object->result_source->relationship_info($fetch->{rel});
285       if ($info->{attrs}{accessor} eq 'multi') {
286         $fetch = merge( $fetch, $rule );
287       } elsif ($rule->{fetch}) {
288         $fetch = merge( $fetch, { fetch => $rule->{fetch} } );
289       }
290     } 
291     die "relationship " . $fetch->{rel} . " does not exist for " . $s->source_name unless ($related_rs);
292     if ($fetch->{cond} and ref $fetch->{cond} eq 'HASH') {
293       # if value starts with / assume it's meant to be passed as a scalar ref to dbic
294       # ideally this would substitute deeply
295       $fetch->{cond} = { map { $_ => ($fetch->{cond}->{$_} =~ s/^\\//) ? \$fetch->{cond}->{$_} : $fetch->{cond}->{$_} } keys %{$fetch->{cond}} };
296     }
297     $related_rs = $related_rs->search($fetch->{cond}, { join => $fetch->{join} }) if ($fetch->{cond});
298     $related_rs = $related_rs->search({}, { rows => $fetch->{quantity} }) if ($fetch->{quantity} && $fetch->{quantity} ne 'all');
299     $related_rs = $related_rs->search({}, { order_by => $fetch->{order_by} }) if ($fetch->{order_by});
300     dump_object($_, { %{$params}, set => $fetch }) foreach $related_rs->all;
301   }
302 }
303
304 sub msg {
305   my $self = shift;
306   my $subject = shift || return;
307   return unless $self->debug;
308   if (ref $subject) {
309         print Dumper($subject);
310   } else {
311         print $subject . "\n";
312   }
313 }
314 1;