| 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; |
projects / dbsrgits/DBIx-Class-Fixtures.git / blame