Commit | Line | Data |
e5963c1b |
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); |
0fc424b7 |
9 | use Config::Any::JSON; |
10 | use Data::Dump::Streamer; |
11 | use File::Slurp; |
12 | use File::Path; |
13 | use Hash::Merge qw( merge ); |
e5963c1b |
14 | use Data::Dumper; |
15 | |
16 | use base qw(Class::Accessor); |
17 | |
0fc424b7 |
18 | __PACKAGE__->mk_accessors(qw(config_dir _inherited_attributes debug)); |
e5963c1b |
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 | |
0fc424b7 |
56 | =head1 METHODS |
57 | |
58 | =head2 new |
e5963c1b |
59 | |
0fc424b7 |
60 | =cut |
e5963c1b |
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 = { |
0fc424b7 |
80 | config_dir => $config_dir, |
81 | _inherited_attributes => [qw/datetime_relative might_have rules/], |
82 | debug => $params->{debug} |
e5963c1b |
83 | }; |
84 | |
85 | bless $self, $class; |
86 | |
87 | return $self; |
88 | } |
89 | |
0fc424b7 |
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 | } |
e5963c1b |
314 | 1; |